breezewiki/archiver/archiver-gui.rkt

#lang racket/base
(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
         (only-in racket/gui timer%)
         racket/gui/easy
         racket/gui/easy/operator
         (only-in pict bitmap)
         images/icons/arrow
         images/icons/control
         images/icons/stickman
         images/icons/style
         images/icons/symbol
         "archiver-database.rkt"
         "archiver.rkt"
         "../lib/url-utils.rkt"
         "../lib/xexpr-utils.rkt")

(default-icon-material rubber-icon-material)

(require (for-syntax racket/base racket/match racket/set racket/string))

(define-syntax (@> stx)
  (define form (cdr (syntax->datum stx)))
  (match form
    [(list form) ; (@> (fn @obs))
     ;; identify the observables and replace with non-@ symbols
     (define collection (mutable-set))
     (define updated
       (let loop ([sexp form])
         (cond [(symbol? sexp)
                (let ([as-s (symbol->string sexp)])
                  (if (string-prefix? as-s "@")
                      (let ([without-@ (string->symbol (substring as-s 1))])
                        (set-add! collection (cons sexp without-@))
                        without-@)
                      sexp))]
               [(pair? sexp) (cons (loop (car sexp)) (loop (cdr sexp)))]
               [#t sexp])))
     (define collection-l (set->list collection))
     ;; return obs-combine -> updated-form
     (datum->syntax stx `(obs-combine (λ (,@(map cdr collection-l)) ,updated) ,@(map car collection-l)))]
    [(list (? string? str) args ...) ; (@> "Blah: ~a/~a" @arg1 arg2)
     ;; identify the observables and replace with non-@ symbols
     (define collection-l
       (for/list ([arg args])
         (if (symbol? arg)
             (let ([as-s (symbol->string arg)])
               (if (string-prefix? as-s "@")
                   (let ([without-@ (string->symbol (substring as-s 1))])
                     (cons arg without-@))
                   (cons #f arg)))
             (cons #f arg))))
     (define collection-lo (filter car collection-l))
     ;; return obs-combine -> format
     (datum->syntax stx `(obs-combine (λ (,@(map cdr collection-lo)) (format ,str ,@(map cdr collection-l))) ,@(map car collection-lo)))]))

(define/obs @auto-retry #f)

(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)
(define (add-wikiname-to-queue wikiname st stage)
  (@queue . <~ . (λ (queue)
                   (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)))))))
(for ([row rows])
  (add-wikiname-to-queue (vector-ref row 0)
                         (if (= (vector-ref row 1) 4)
                             'complete
                             'queued)
                         (vector-ref row 1)))

(define status-icon-size 32)
(define status-icon-min-width 36)
(define button-icon-size 12)

(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 (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)))))

(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 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)
          '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)
               #:stretch '(#f #f)
               #:style '(transparent)
               @the-bitmap
               bitmap))

(define (exn->string e)
  (with-output-to-string
    (λ ()
      (displayln (exn-message e))
      (displayln "context:")
      (for ([item (continuation-mark-set->context (exn-continuation-marks e))])
        (printf "  ~a" (srcloc->string (cdr item)))
        (when (car item)
          (printf ": ~a" (car item)))
        (displayln "")))))

(define ((handle-graphical-exn @qi) e)
  (displayln (exn->string e) (current-error-port))
  (cond
    [(obs-peek @auto-retry)
     (void) ;; TODO
     #;(do-retry-end wikiname)]
    [#t
     (update-qi @qi [st 'error])
     (do-try-unpause-next-entry)
     (thread
      (λ ()
        (define/obs @visible? #t)
        (render
         (dialog #:title "Download Error"
                 #:style '(resize-border)
                 #: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))))
                         (input #:style '(multiple hscroll)
                                #:min-size '(#f 200)
                                (exn->string e))
                         ;; TODO
                         #;(button "Retry Now" (λ () (:= @visible? #f) (do-retry-now wikiname)))
                         #;(button "Retry Round-Robin" (λ () (:= @visible? #f) (do-retry-end wikiname)))
                         #;(button "Skip Wiki" (λ () (:= @visible? #f) (do-continue)))
                         #;(button "Use Auto-Retry" (λ ()
                                                      (:= @auto-retry #t)
                                                      (:= @visible? #f)
                                                      (do-retry-end wikiname)))
                         #;(text "Be careful not to auto-retry an infinite loop!")))
         main-window)))
     (sleep)
     ; make sure the broken thread is gone
     (define th (qi^-th (obs-peek @qi)))
     (when th (kill-thread th))]))

(define segments
  (list
   (list 5/100 (make-color 0 223 217))
   (list 88/100 color-green)
   (list 2/100 (make-color 0 223 217))
   (list 5/100 color-green)))
(define segment-spacing 2)
(unless (= (apply + (map car segments)) 1)
  (error 'segments "segments add up to ~a, not 1" (apply + (map car segments))))

;; return the new bitmap, which can be drawn on a dc<%>
(define/memoize (ray-trace width height stage progress max-progress)
  ;; (printf "rendering ~a ~a/~a at ~a~n" stage progress max-progress (current-inexact-milliseconds))
  (define bm (make-object bitmap% width height #f #t))
  (define dc (make-object bitmap-dc% bm))
  (define width-available (- width (* (length segments) segment-spacing)))
  (send dc set-smoothing 'unsmoothed)
  (send dc set-pen "black" 0 'transparent)
  (for/fold ([offset 0])
            ([segment segments]
             [i (in-naturals 0)]) ;; zero indexed stages?
    ;; calculate start and end locations of grey bar
    (define-values (segment-proportion segment-color) (apply values segment))
    (define segment-start (if (= offset 0) 0 (+ offset segment-spacing)))
    (define segment-width (* width-available segment-proportion))
    ;; draw grey bar
    (send dc set-brush (make-color 180 180 180 0.4) 'solid)
    (send dc draw-rectangle segment-start 0 segment-width height)
    ;; draw solid bar according to the current item's progress
    (define proportion
      (cond [(stage . < . i) 0]
            [(stage . > . i) 1]
            [(max-progress . <= . 0) 0]
            [(progress . < . 0) 0]
            [(progress . >= . max-progress) 1]
            [else (progress . / . max-progress)]))
    (send dc set-brush segment-color 'solid)
    (send dc draw-rectangle segment-start 0 (* proportion segment-width) height)
    (+ segment-start segment-width))
  (bitmap-render-icon bm 6/8))

;; get ray traced bitmap (possibly from cache) and draw on dc<%>
(define (draw-bar orig-dc qi)
  ;; (println ray-traced)
  (define-values (width height) (send orig-dc get-size))
  (send orig-dc draw-bitmap (ray-trace width height  (qi^-stage qi) (qi^-progress qi) (qi^-max-progress qi)) 0 0))

(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 "")

(define (do-add-to-queue)
  (define wikiname (string-trim (obs-peek @input)))
  (when ((string-length wikiname) . > . 0)
    (add-wikiname-to-queue wikiname 'queued 0)) ;; TODO: automatically start?
  (:= @input ""))

(define-syntax-rule (update-qi @qi args ...)
  (let ([wikiname (qi^-wikiname (obs-peek @qi))])
    (@queue . <~ . (λ (queue)
                     (for/list ([qi queue])
                       (if (equal? (qi^-wikiname qi) wikiname)
                           (struct-copy qi^ qi args ...)
                           qi))))))

(define (do-start-qi @qi)
  (define th
    (thread (λ ()
              (with-handlers ([exn? (handle-graphical-exn @qi)])
                (define last-stage
                  (for/last ([stage all-stages]
                             [i (in-naturals)])
                    (update-qi @qi [stage i])
                    (stage (qi^-wikiname (obs-peek @qi)) (make-progress-updater @qi))
                    i))
                (update-qi @qi [st 'complete] [stage (add1 last-stage)])
                (do-try-unpause-next-entry)))))
  (update-qi @qi [st 'running] [th th]))

(define (do-stop-qi @qi)
  (define th (qi^-th (obs-peek @qi)))
  (when th (kill-thread th))
  (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))))

(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)))
                    qi))
  (when next-qi
    (define @qi (@queue . ~> . (λ (queue) (findf (λ (qi) (equal? (qi^-wikiname qi) (qi^-wikiname next-qi))) queue))))
    (do-start-qi @qi)))

(define main-window
  (render
   (window
    #:title "Fandom Archiver"
    #:size '(400 300)
    #:mixin (λ (%) (class %
                     (super-new)
                     (define/augment (on-close)
                       (for ([qi (obs-peek @queue)])
                         (when (qi^-th qi)
                           (kill-thread (qi^-th qi))))
                       #;(disconnect*))))
    (vpanel
     #:spacing 10
     #:margin '(5 5)
     (hpanel
      #:stretch '(#t #f)
      #:spacing 10
      (hpanel
       (text "https://")
       (input @input
              (λ (event data) (cond
                                [(eq? event 'input) (:= @input data)]
                                [(eq? event 'return) (do-add-to-queue)])))
       (text ".fandom.com"))
      (button "Download Wiki" do-add-to-queue))
     (list-view
      #:style '(vertical)
      @queue
      #:key qi^-wikiname
      (λ (k @qi)
        (define @status-icons
          (@> (case (qi^-st @qi)
                [(running) (stick (qi^-ticks @qi))]
                [else (hash-ref status-icons (qi^-st @qi))])))
        (define @is-running?
          (@> (memq (qi^-st @qi) '(running))))
        (define @is-complete?
          (@> (eq? (qi^-st @qi) 'complete)))
        ;; state icon at the left side
        (hpanel #:stretch '(#t #f)
                #:alignment '(left center)
                #:spacing 8
                (bitmap-view @status-icons status-icon-min-width)
                (vpanel
                 ;; name and buttons (top half)
                 (hpanel #:alignment '(left bottom)
                         (text (@> (qi^-wikiname @qi)))
                         (spacer)
                         (hpanel
                          #:stretch '(#f #f)

                          (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)))))))
                 ;; progress bar (bottom half)
                 (hpanel
                  (canvas
                   @qi
                   #:style '(transparent)
                   #:margin '(3 3)
                   draw-bar)
                  (hpanel #:min-size '(68 #f)
                          #:stretch '(#f #f)
                          #:alignment '(right center)
                          (text (@> (format "eta ~a" (qi^-eta @qi))))))))))))))