diff --git a/archiver/archiver-gui.rkt b/archiver/archiver-gui.rkt index 25f447f..6f09cb8 100644 --- a/archiver/archiver-gui.rkt +++ b/archiver/archiver-gui.rkt @@ -2,14 +2,11 @@ (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 @@ -68,7 +65,7 @@ (define/obs @auto-retry #f) -(define-struct qi^ (wikiname st stage progress max-progress ticks eta th) #:transparent) ;; queue item +(define-struct qi^ (wikiname st stage progress max-progress eta th) #:transparent) ;; queue item (define rows (query-rows* "select wikiname, progress from wiki where progress < 4")) (define/obs @queue null) @@ -77,7 +74,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 0 "..." #f))))))) + (append queue (list (qi^ wikiname st stage 0 1 "..." #f))))))) (for ([row rows]) (add-wikiname-to-queue (vector-ref row 0) (if (= (vector-ref row 1) 4) @@ -91,67 +88,36 @@ (define color-green (make-color 90 212 68)) -(define (resize coords fraction) - (for/list ([coord (in-list coords)]) - (cons (* fraction (car coord)) - (* fraction (cdr coord))))) +(define/obs @input "") -(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]) +(splicing-let ([frame-count 30]) (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 (stick n) - (vector-ref stickman-frames (modulo n (vector-length stickman-frames)))) + (define/obs @stick-frame-no 0) + (define stick-timer + (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 0) + 'running @stick '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) - 'reseter (double-left-arrow-icon #:height button-icon-size))) + 'reset (left-over-arrow-icon #:color halt-icon-color #: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) @@ -189,7 +155,7 @@ #:mixin (λ (%) (class % (super-new) (obs-observe! @visible? (λ (visible?) (send this show visible?))))) (vpanel #:margin '(15 15) - (text (format "Encountered this error while downloading ~a:" (qi^-wikiname (obs-peek @qi)))) + (text "Encountered this error while downloading:") (input #:style '(multiple hscroll) #:min-size '(#f 200) (exn->string e)) @@ -257,9 +223,7 @@ (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] [ticks (add1 (qi^-ticks (obs-peek @qi)))])) - -(define/obs @input "") + (update-qi @qi [progress a] [max-progress b])) (define (do-add-to-queue) (define wikiname (string-trim (obs-peek @input))) @@ -295,20 +259,15 @@ (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 reset-progress-to] [progress 0] [max-progress 0]) - (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)))) + (update-qi @qi [th #f] [st 'queued] [stage 0] [progress 0] [max-progress 0]) + (query-exec* "update wiki set progress = 0 where wikiname = ?" (qi^-wikiname (obs-peek @qi)))) (define (do-try-unpause-next-entry) (define queue (obs-peek @queue)) - (define next-qi (for/last ([qi queue] - #:when (memq (qi^-st qi) '(paused queued))) + (define next-qi (for/first ([qi queue] + #:when (memq (qi^-st qi) '(paused queued error))) qi)) (when next-qi (define @qi (@queue . ~> . (λ (queue) (findf (λ (qi) (equal? (qi^-wikiname qi) (qi^-wikiname next-qi))) queue)))) @@ -322,6 +281,7 @@ #: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)))) @@ -347,7 +307,7 @@ (λ (k @qi) (define @status-icons (@> (case (qi^-st @qi) - [(running) (stick (qi^-ticks @qi))] + [(running) @stick] [else (hash-ref status-icons (qi^-st @qi))]))) (define @is-running? (@> (memq (qi^-st @qi) '(running)))) @@ -365,18 +325,15 @@ (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))))))) + (button (hash-ref action-icons 'resume) + (λ () (do-start-qi @qi)))))) ;; progress bar (bottom half) (hpanel (canvas diff --git a/archiver/archiver.rkt b/archiver/archiver.rkt index 01f03ad..84fd16f 100644 --- a/archiver/archiver.rkt +++ b/archiver/archiver.rkt @@ -86,17 +86,14 @@ (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"^file:" url)))) + (regexp-match? #rx"^data:" 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)]))) @@ -247,7 +244,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 = ? and progress <= 2" wikiname)) + (query-exec* "update wiki set progress = 2 where wikiname = ?" wikiname)) ;; 2.5. Download each redirect-target via API and save mapping in database @@ -337,8 +334,8 @@ (define url (vector-ref row 0)) (define hash (vector-ref row 1)) ;; check - #;(printf "~a -> ~a~n" url hash) - (define r (get url #:timeouts (make-timeout-config #:connect 15))) + #; (printf "~a -> ~a~n" url hash) + (define r (get url)) (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)))]) diff --git a/lib/mime.types b/lib/mime.types index 4ae48d8..c06a1e9 100644 --- a/lib/mime.types +++ b/lib/mime.types @@ -22,7 +22,6 @@ 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 @@ -32,7 +31,6 @@ 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 diff --git a/src/page-static-archive.rkt b/src/page-static-archive.rkt index 501bda7..c0c2e09 100644 --- a/src/page-static-archive.rkt +++ b/src/page-static-archive.rkt @@ -30,19 +30,16 @@ (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"^file:" url)) + (regexp-match? #rx"^\"?data:" 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)])])