Archiver GUI super-reset button

archiver/archiver-gui.rkt

@@ -2,11 +2,14 @@
 (require racket/class
          racket/draw
          racket/format
+         racket/function
          racket/list
+         racket/math
          racket/port
          racket/set
          racket/splicing
          racket/string
+         (except-in pict text table)
          db
          net/http-easy
          memo
@@ -65,7 +68,7 @@
 
 (define/obs @auto-retry #f)
 
-(define-struct qi^ (wikiname st stage progress max-progress eta th) #:transparent) ;; queue item
+(define-struct qi^ (wikiname st stage progress max-progress ticks eta th) #:transparent) ;; queue item
 
 (define rows (query-rows* "select wikiname, progress from wiki where progress < 4"))
 (define/obs @queue null)
@@ -74,7 +77,7 @@
                    (define already-exists? (findf (λ (qi) (equal? (qi^-wikiname qi) wikiname)) queue))
                    (if already-exists?
                        queue
-                       (append queue (list (qi^ wikiname st stage 0 1 "..." #f)))))))
+                       (append queue (list (qi^ wikiname st stage 0 1 0 "..." #f)))))))
 (for ([row rows])
   (add-wikiname-to-queue (vector-ref row 0)
                          (if (= (vector-ref row 1) 4)
@@ -88,36 +91,67 @@
 
 (define color-green (make-color 90 212 68))
 
-(define/obs @input "")
+(define (resize coords fraction)
+  (for/list ([coord (in-list coords)])
+    (cons (* fraction (car coord))
+          (* fraction (cdr coord)))))
 
-(splicing-let ([frame-count 30])
+(define (flat-right-arrow #:height [height 32] #:color [color #f])
+  ((if color
+       (curryr colorize color)
+       values)
+   (dc (λ (dc dx dy)
+         (send dc draw-polygon (resize
+                                (list '(0 . 9) '(15 . 9) '(14 . 0)
+                                      '(31 . 15.5)
+                                      '(14 . 31) '(15 . 22) '(0 . 22))
+                                (/ height 32))))
+       height height)))
+
+(define (double-left-arrow-icon #:height [height 32])
+  (define shift (/ height 48))
+  (pict->bitmap
+   (scale-to-fit
+    (panorama
+     (pin-under
+      (bitmap
+       (left-over-arrow-icon #:color halt-icon-color #:height height
+                             #:material rubber-icon-material))
+      (- (* -20 shift) 2) (+ (* 6 shift) 1)
+      (bitmap
+       (bitmap-render-icon
+        (pict->bitmap
+         (rotate
+          (flat-right-arrow #:color (make-object color% 255 64 64) #:height (/ height 1.26))
+          (* pi 1.23)))))
+      #;(rotate
+         (flat-right-arrow #:color (make-object color% 255 64 64) #:height (/ height 1.26))
+         (* pi 1.23))))
+    height height #:mode 'preserve/max)))
+
+(splicing-let ([frame-count 20])
   (define stickman-frames
     (for/vector ([s (in-range 0 1 (/ 1 frame-count))])
       (running-stickman-icon
        s
        #:height status-icon-size
-       #:material (default-icon-material))))
+       #:material (default-icon-material)))))
 
-  (define/obs @stick-frame-no 0)
+(define (stick n)
-  (define stick-timer
+  (vector-ref stickman-frames (modulo n (vector-length stickman-frames))))
-    (new timer%
-         [notify-callback (λ () (@stick-frame-no . <~ . add1))]
-         [interval (truncate (/ 1000 frame-count))]))
-  (define/obs @stick
-    (@stick-frame-no . ~> . (λ (n) (vector-ref stickman-frames
-                                               (modulo n (vector-length stickman-frames)))))))
 
 (define status-icons
   (hasheq 'queued (stop-icon #:color syntax-icon-color #:height status-icon-size)
           'paused (continue-forward-icon #:color syntax-icon-color #:height status-icon-size)
-          'running @stick
+          'running (stick 0)
           'error (x-icon #:height status-icon-size)
           'complete (check-icon #:color color-green #:height status-icon-size)))
 
 (define action-icons
   (hasheq 'pause (pause-icon #:color syntax-icon-color #:height button-icon-size)
           'resume (play-icon #:color color-green #:height button-icon-size)
-          'reset (left-over-arrow-icon #:color halt-icon-color #:height button-icon-size)))
+          'reset (left-over-arrow-icon #:color halt-icon-color #:height button-icon-size)
+          'reseter (double-left-arrow-icon #:height button-icon-size)))
 
 (define (bitmap-view @the-bitmap [min-width 1])
   (pict-canvas #:min-size (@> (list (max min-width (send @the-bitmap get-width)) (send @the-bitmap get-height))) #;(if min-size (list min-size min-size) #f)
@@ -155,7 +189,7 @@
                  #:mixin (λ (%) (class % (super-new)
                                   (obs-observe! @visible? (λ (visible?) (send this show visible?)))))
                  (vpanel #:margin '(15 15)
-                         (text "Encountered this error while downloading:")
+                         (text (format "Encountered this error while downloading ~a:" (qi^-wikiname (obs-peek @qi))))
                          (input #:style '(multiple hscroll)
                                 #:min-size '(#f 200)
                                 (exn->string e))
@@ -223,7 +257,9 @@
 
 (define ((make-progress-updater @qi) a b c)
   ;; (printf "~a: ~a/~a ~a~n" (qi^-wikiname (obs-peek @qi)) a b c)
-  (update-qi @qi [progress a] [max-progress b]))
+  (update-qi @qi [progress a] [max-progress b] [ticks (add1 (qi^-ticks (obs-peek @qi)))]))
+
+(define/obs @input "")
 
 (define (do-add-to-queue)
   (define wikiname (string-trim (obs-peek @input)))
@@ -259,15 +295,20 @@
   (update-qi @qi [th #f] [st 'paused]))
 
 (define (do-reset-qi @qi)
+  (define reset-progress-to 0)
   (define th (qi^-th (obs-peek @qi)))
   (when th (kill-thread th))
-  (update-qi @qi [th #f] [st 'queued] [stage 0] [progress 0] [max-progress 0])
+  (update-qi @qi [th #f] [st 'queued] [stage reset-progress-to] [progress 0] [max-progress 0])
-  (query-exec* "update wiki set progress = 0 where wikiname = ?" (qi^-wikiname (obs-peek @qi))))
+  (query-exec* "update wiki set progress = ? where wikiname = ?" reset-progress-to (qi^-wikiname (obs-peek @qi))))
+
+(define (do-reseter-qi @qi)
+  (do-reset-qi @qi)
+  (query-exec* "delete from page where wikiname = ?" (qi^-wikiname (obs-peek @qi))))
 
 (define (do-try-unpause-next-entry)
   (define queue (obs-peek @queue))
-  (define next-qi (for/first ([qi queue]
+  (define next-qi (for/last ([qi queue]
-                              #:when (memq (qi^-st qi) '(paused queued error)))
+                             #:when (memq (qi^-st qi) '(paused queued)))
                     qi))
   (when next-qi
     (define @qi (@queue . ~> . (λ (queue) (findf (λ (qi) (equal? (qi^-wikiname qi) (qi^-wikiname next-qi))) queue))))
@@ -281,7 +322,6 @@
     #:mixin (λ (%) (class %
                      (super-new)
                      (define/augment (on-close)
-                       (send stick-timer stop)
                        (for ([qi (obs-peek @queue)])
                          (when (qi^-th qi)
                            (kill-thread (qi^-th qi))))
@@ -307,7 +347,7 @@
       (λ (k @qi)
         (define @status-icons
           (@> (case (qi^-st @qi)
-                [(running) @stick]
+                [(running) (stick (qi^-ticks @qi))]
                 [else (hash-ref status-icons (qi^-st @qi))])))
         (define @is-running?
           (@> (memq (qi^-st @qi) '(running))))
@@ -325,15 +365,18 @@
                          (spacer)
                          (hpanel
                           #:stretch '(#f #f)
-                          (if-view @is-complete?
+
-                                   (button (hash-ref action-icons 'reset)
-                                           (λ () (do-reset-qi @qi)))
-                                   (spacer))
                           (if-view @is-running?
                                    (button (hash-ref action-icons 'pause)
                                            (λ () (do-stop-qi @qi)))
+                                   (hpanel
+                                    #:stretch '(#f #f)
+                                    (button (hash-ref action-icons 'reseter)
+                                            (λ () (do-reseter-qi @qi)))
+                                    (button (hash-ref action-icons 'reset)
+                                            (λ () (do-reset-qi @qi)))
                                     (button (hash-ref action-icons 'resume)
-                                           (λ () (do-start-qi @qi))))))
+                                            (λ () (do-start-qi @qi)))))))
                  ;; progress bar (bottom half)
                  (hpanel
                   (canvas

archiver/archiver.rkt

@@ -86,14 +86,17 @@
                              (string-contains? url "/drm_fonts/")
                              (string-contains? url "//db.onlinewebfonts.com/")
                              (string-contains? url "//bits.wikimedia.org/")
+                             (string-contains? url "mygamercard.net/")
                              (string-contains? url "dropbox")
                              (string-contains? url "only=styles")
                              (string-contains? url "https://https://")
                              (regexp-match? #rx"^%20" url)
-                             (regexp-match? #rx"^data:" url))))
+                             (regexp-match? #rx"^data:" url)
+                             (regexp-match? #rx"^file:" url))))
     (cond
       [(string-prefix? url "https://") url]
       [(string-prefix? url "http://") (regexp-replace #rx"http:" url "https:")]
+      [(string-prefix? url "httpshttps://") (regexp-replace #rx"httpshttps://" url "https://")]
       [(string-prefix? url "//") (string-append "https:" url)]
       [(string-prefix? url "/") (format "https://~a.fandom.com~a" wikiname url)]
       [else (raise-user-error "While calling check-style-for-images, this URL had an unknown format and couldn't be saved:" url path)])))
@@ -244,7 +247,7 @@
   ;; save redirects as well
   (save-redirects wikiname callback (+ already-done-count (length basenames)) total-count)
   ;; saved all pages, register that fact in the database
-  (query-exec* "update wiki set progress = 2 where wikiname = ?" wikiname))
+  (query-exec* "update wiki set progress = 2 where wikiname = ? and progress <= 2" wikiname))
 
 
 ;; 2.5. Download each redirect-target via API and save mapping in database
@@ -335,7 +338,7 @@
     (define hash (vector-ref row 1))
     ;; check
     #;(printf "~a -> ~a~n" url hash)
-    (define r (get url))
+    (define r (get url #:timeouts (make-timeout-config #:connect 15)))
     (define declared-type (response-headers-ref r 'content-type))
     (define final-type (if (equal? declared-type #"application/octet-stream")
                            (let ([sniff-entity (message-entity (mime-analyze (response-body r)))])

lib/mime.types

@@ -22,6 +22,7 @@ image/x-jng                           jng
 image/x-ms-bmp                        bmp
 image/svg+xml                         svg
 image/webp                            webp
+image/avif                            avif
 
 application/font-woff2                woff2
 application/acad                      woff2
@@ -31,6 +32,7 @@ font/woff                             woff
 application/x-font-ttf                ttf
 application/x-font-truetype           ttf
 application/x-truetype-font           ttf
+font/ttf                              ttf
 application/font-sfnt                 ttf
 font/sfnt                             ttf
 application/vnd.oasis.opendocument.formula-template otf

src/page-static-archive.rkt

@@ -30,16 +30,19 @@
            (string-contains? url "/drm_fonts/")
            (string-contains? url "//db.onlinewebfonts.com/")
            (string-contains? url "//bits.wikimedia.org/")
+           (string-contains? url "mygamercard.net/")
            (string-contains? url "dropbox")
            (string-contains? url "only=styles")
            (string-contains? url "https://https://")
            (regexp-match? #rx"^%20|^'" url)
-           (regexp-match? #rx"^\"?data:" url))
+           (regexp-match? #rx"^\"?data:" url)
+           (regexp-match? #rx"^file:" url))
        url
        (let* ([norm-url
                (cond
                  [(string-prefix? url "https://") url]
                  [(string-prefix? url "http://") (regexp-replace #rx"http:" url "https:")]
+                 [(string-prefix? url "httpshttps://") (regexp-replace #rx"httpshttps://" url "https://")]
                  [(string-prefix? url "//") (string-append "https:" url)]
                  [(string-prefix? url "/") (format "https://~a.fandom.com~a" wikiname url)]
                  [else (error 'replace-style-for-images "unknown URL format: ~a" url)])])