Minor improvements to archiver
This commit is contained in:
parent
a57445abcb
commit
9c3125d6be
4 changed files with 27 additions and 27 deletions
|
@ -90,27 +90,21 @@
|
||||||
|
|
||||||
(define/obs @input "")
|
(define/obs @input "")
|
||||||
|
|
||||||
(splicing-let ([frame-count 30])
|
(splicing-let ([frame-count 20])
|
||||||
(define stickman-frames
|
(define stickman-frames
|
||||||
(for/vector ([s (in-range 0 1 (/ 1 frame-count))])
|
(for/vector ([s (in-range 0 1 (/ 1 frame-count))])
|
||||||
(running-stickman-icon
|
(running-stickman-icon
|
||||||
s
|
s
|
||||||
#:height status-icon-size
|
#: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
|
(define status-icons
|
||||||
(hasheq 'queued (stop-icon #:color syntax-icon-color #:height status-icon-size)
|
(hasheq 'queued (stop-icon #:color syntax-icon-color #:height status-icon-size)
|
||||||
'paused (continue-forward-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)
|
'error (x-icon #:height status-icon-size)
|
||||||
'complete (check-icon #:color color-green #:height status-icon-size)))
|
'complete (check-icon #:color color-green #:height status-icon-size)))
|
||||||
|
|
||||||
|
@ -155,7 +149,7 @@
|
||||||
#:mixin (λ (%) (class % (super-new)
|
#:mixin (λ (%) (class % (super-new)
|
||||||
(obs-observe! @visible? (λ (visible?) (send this show visible?)))))
|
(obs-observe! @visible? (λ (visible?) (send this show visible?)))))
|
||||||
(vpanel #:margin '(15 15)
|
(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)
|
(input #:style '(multiple hscroll)
|
||||||
#:min-size '(#f 200)
|
#:min-size '(#f 200)
|
||||||
(exn->string e))
|
(exn->string e))
|
||||||
|
@ -259,15 +253,16 @@
|
||||||
(update-qi @qi [th #f] [st 'paused]))
|
(update-qi @qi [th #f] [st 'paused]))
|
||||||
|
|
||||||
(define (do-reset-qi @qi)
|
(define (do-reset-qi @qi)
|
||||||
|
(define reset-progress-to 0)
|
||||||
(define th (qi^-th (obs-peek @qi)))
|
(define th (qi^-th (obs-peek @qi)))
|
||||||
(when th (kill-thread th))
|
(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-try-unpause-next-entry)
|
(define (do-try-unpause-next-entry)
|
||||||
(define queue (obs-peek @queue))
|
(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))
|
qi))
|
||||||
(when next-qi
|
(when next-qi
|
||||||
(define @qi (@queue . ~> . (λ (queue) (findf (λ (qi) (equal? (qi^-wikiname qi) (qi^-wikiname next-qi))) queue))))
|
(define @qi (@queue . ~> . (λ (queue) (findf (λ (qi) (equal? (qi^-wikiname qi) (qi^-wikiname next-qi))) queue))))
|
||||||
|
@ -281,7 +276,6 @@
|
||||||
#:mixin (λ (%) (class %
|
#:mixin (λ (%) (class %
|
||||||
(super-new)
|
(super-new)
|
||||||
(define/augment (on-close)
|
(define/augment (on-close)
|
||||||
(send stick-timer stop)
|
|
||||||
(for ([qi (obs-peek @queue)])
|
(for ([qi (obs-peek @queue)])
|
||||||
(when (qi^-th qi)
|
(when (qi^-th qi)
|
||||||
(kill-thread (qi^-th qi))))
|
(kill-thread (qi^-th qi))))
|
||||||
|
@ -307,7 +301,7 @@
|
||||||
(λ (k @qi)
|
(λ (k @qi)
|
||||||
(define @status-icons
|
(define @status-icons
|
||||||
(@> (case (qi^-st @qi)
|
(@> (case (qi^-st @qi)
|
||||||
[(running) @stick]
|
[(running) (stick (qi^-progress @qi))]
|
||||||
[else (hash-ref status-icons (qi^-st @qi))])))
|
[else (hash-ref status-icons (qi^-st @qi))])))
|
||||||
(define @is-running?
|
(define @is-running?
|
||||||
(@> (memq (qi^-st @qi) '(running))))
|
(@> (memq (qi^-st @qi) '(running))))
|
||||||
|
@ -325,10 +319,8 @@
|
||||||
(spacer)
|
(spacer)
|
||||||
(hpanel
|
(hpanel
|
||||||
#:stretch '(#f #f)
|
#:stretch '(#f #f)
|
||||||
(if-view @is-complete?
|
|
||||||
(button (hash-ref action-icons 'reset)
|
(button (hash-ref action-icons 'reset)
|
||||||
(λ () (do-reset-qi @qi)))
|
(λ () (do-reset-qi @qi)))
|
||||||
(spacer))
|
|
||||||
(if-view @is-running?
|
(if-view @is-running?
|
||||||
(button (hash-ref action-icons 'pause)
|
(button (hash-ref action-icons 'pause)
|
||||||
(λ () (do-stop-qi @qi)))
|
(λ () (do-stop-qi @qi)))
|
||||||
|
|
|
@ -86,14 +86,17 @@
|
||||||
(string-contains? url "/drm_fonts/")
|
(string-contains? url "/drm_fonts/")
|
||||||
(string-contains? url "//db.onlinewebfonts.com/")
|
(string-contains? url "//db.onlinewebfonts.com/")
|
||||||
(string-contains? url "//bits.wikimedia.org/")
|
(string-contains? url "//bits.wikimedia.org/")
|
||||||
|
(string-contains? url "mygamercard.net/")
|
||||||
(string-contains? url "dropbox")
|
(string-contains? url "dropbox")
|
||||||
(string-contains? url "only=styles")
|
(string-contains? url "only=styles")
|
||||||
(string-contains? url "https://https://")
|
(string-contains? url "https://https://")
|
||||||
(regexp-match? #rx"^%20" url)
|
(regexp-match? #rx"^%20" url)
|
||||||
(regexp-match? #rx"^data:" url))))
|
(regexp-match? #rx"^data:" url)
|
||||||
|
(regexp-match? #rx"^file:" url))))
|
||||||
(cond
|
(cond
|
||||||
[(string-prefix? url "https://") url]
|
[(string-prefix? url "https://") url]
|
||||||
[(string-prefix? url "http://") (regexp-replace #rx"http:" url "https:")]
|
[(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 "//") (string-append "https:" url)]
|
||||||
[(string-prefix? url "/") (format "https://~a.fandom.com~a" wikiname 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)])))
|
[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 as well
|
||||||
(save-redirects wikiname callback (+ already-done-count (length basenames)) total-count)
|
(save-redirects wikiname callback (+ already-done-count (length basenames)) total-count)
|
||||||
;; saved all pages, register that fact in the database
|
;; 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
|
;; 2.5. Download each redirect-target via API and save mapping in database
|
||||||
|
@ -335,7 +338,7 @@
|
||||||
(define hash (vector-ref row 1))
|
(define hash (vector-ref row 1))
|
||||||
;; check
|
;; check
|
||||||
#;(printf "~a -> ~a~n" url hash)
|
#;(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 declared-type (response-headers-ref r 'content-type))
|
||||||
(define final-type (if (equal? declared-type #"application/octet-stream")
|
(define final-type (if (equal? declared-type #"application/octet-stream")
|
||||||
(let ([sniff-entity (message-entity (mime-analyze (response-body r)))])
|
(let ([sniff-entity (message-entity (mime-analyze (response-body r)))])
|
||||||
|
|
|
@ -22,6 +22,7 @@ image/x-jng jng
|
||||||
image/x-ms-bmp bmp
|
image/x-ms-bmp bmp
|
||||||
image/svg+xml svg
|
image/svg+xml svg
|
||||||
image/webp webp
|
image/webp webp
|
||||||
|
image/avif avif
|
||||||
|
|
||||||
application/font-woff2 woff2
|
application/font-woff2 woff2
|
||||||
application/acad woff2
|
application/acad woff2
|
||||||
|
@ -31,6 +32,7 @@ font/woff woff
|
||||||
application/x-font-ttf ttf
|
application/x-font-ttf ttf
|
||||||
application/x-font-truetype ttf
|
application/x-font-truetype ttf
|
||||||
application/x-truetype-font ttf
|
application/x-truetype-font ttf
|
||||||
|
font/ttf ttf
|
||||||
application/font-sfnt ttf
|
application/font-sfnt ttf
|
||||||
font/sfnt ttf
|
font/sfnt ttf
|
||||||
application/vnd.oasis.opendocument.formula-template otf
|
application/vnd.oasis.opendocument.formula-template otf
|
||||||
|
|
|
@ -30,16 +30,19 @@
|
||||||
(string-contains? url "/drm_fonts/")
|
(string-contains? url "/drm_fonts/")
|
||||||
(string-contains? url "//db.onlinewebfonts.com/")
|
(string-contains? url "//db.onlinewebfonts.com/")
|
||||||
(string-contains? url "//bits.wikimedia.org/")
|
(string-contains? url "//bits.wikimedia.org/")
|
||||||
|
(string-contains? url "mygamercard.net/")
|
||||||
(string-contains? url "dropbox")
|
(string-contains? url "dropbox")
|
||||||
(string-contains? url "only=styles")
|
(string-contains? url "only=styles")
|
||||||
(string-contains? url "https://https://")
|
(string-contains? url "https://https://")
|
||||||
(regexp-match? #rx"^%20|^'" url)
|
(regexp-match? #rx"^%20|^'" url)
|
||||||
(regexp-match? #rx"^\"?data:" url))
|
(regexp-match? #rx"^\"?data:" url)
|
||||||
|
(regexp-match? #rx"^file:" url))
|
||||||
url
|
url
|
||||||
(let* ([norm-url
|
(let* ([norm-url
|
||||||
(cond
|
(cond
|
||||||
[(string-prefix? url "https://") url]
|
[(string-prefix? url "https://") url]
|
||||||
[(string-prefix? url "http://") (regexp-replace #rx"http:" url "https:")]
|
[(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 "//") (string-append "https:" url)]
|
||||||
[(string-prefix? url "/") (format "https://~a.fandom.com~a" wikiname url)]
|
[(string-prefix? url "/") (format "https://~a.fandom.com~a" wikiname url)]
|
||||||
[else (error 'replace-style-for-images "unknown URL format: ~a" url)])])
|
[else (error 'replace-style-for-images "unknown URL format: ~a" url)])])
|
||||||
|
|
Loading…
Reference in a new issue