Compare commits

..

2 commits

Author SHA1 Message Date
723bb92b0a
Archiver GUI super-reset button 2023-12-15 21:23:12 +13:00
9c3125d6be
Minor improvements to archiver 2023-12-13 23:09:00 +13:00
4 changed files with 85 additions and 34 deletions

View file

@ -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-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 (stick 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])
(query-exec* "update wiki set progress = 0 where wikiname = ?" (qi^-wikiname (obs-peek @qi))))
(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))))
(define (do-try-unpause-next-entry)
(define queue (obs-peek @queue))
(define next-qi (for/first ([qi queue]
#:when (memq (qi^-st qi) '(paused queued error)))
(define next-qi (for/last ([qi queue]
#: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)))
(button (hash-ref action-icons 'resume)
(λ () (do-start-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)))))))
;; progress bar (bottom half)
(hpanel
(canvas

View file

@ -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
@ -334,8 +337,8 @@
(define url (vector-ref row 0))
(define hash (vector-ref row 1))
;; check
#; (printf "~a -> ~a~n" url hash)
(define r (get url))
#;(printf "~a -> ~a~n" url hash)
(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)))])

View file

@ -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

View file

@ -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)])])