diff options
Diffstat (limited to 'main.scm')
| -rwxr-xr-x | main.scm | 236 |
1 files changed, 168 insertions, 68 deletions
@@ -11,6 +11,7 @@ (srfi srfi-1) (srfi srfi-43) ; Vector iteration + ((srfi srfi-60) :select (list->integer)) (srfi srfi-71) (ice-9 regex) @@ -26,32 +27,38 @@ (monad stack) (fmt-stack) + (img-parse) + (sxml gumbo) (json parser) ((xdg basedir) :prefix xdg-)) -(define-macro (regex-case str . cases) - `(cond - ,@(map (lambda (case) - (let ((pattern (car case)) - (rest (cdr case))) - (if (eq? pattern 'else) - `(else ,@rest) - `((string-match ,pattern ,str) ,@rest)))) - cases))) +(define-syntax regex-case + (syntax-rules (else) + ((_ str var (else body ...)) + (begin body ...)) -(define (substr-1 match) - (match:substring match 1)) + ((_ str var (pat body ...) rest ...) + (cond ((string-match pat str) + => (lambda (var) body ...)) + (else (regex-case str var rest ...)))))) (define (class-handlers class) (fold (lambda (cl obj) (regex-case - cl - ("^DH$" (set-style obj 'bold)) - ("^bg([BYC])$" => (lambda (m) (->> (substr-1 m) string->symbol (set-bg obj)))) - ("^([BYC])$" => (lambda (m) (->> (substr-1 m) string->symbol (set-fg obj)))) + cl m + ("^DH$" (set-style obj 'bold)) + ("^bgImg$" obj) + ("^bg([BCGMRWY]|Bl)$" (->> (match:substring m 1) + string-upcase + string->symbol + (set-bg obj))) + ("^([BCGMRWY]|bl)$" (->> (match:substring m 1) + string-upcase + string->symbol + (set-fg obj))) (else obj))) (empty-fmt-frame) (string-split class #\space))) @@ -60,12 +67,68 @@ ;;; TODO Every clause should return a string, in the state context of a state. -(define (handle-h1-or-span class nodes) +;; "<id>.gif": #\x<num> +(define bg-cache (make-hash-table)) + +(define (save-bg-cache) + (with-output-to-file (cache-file "bg.scm") + (lambda () + (write (hash-map->list list bg-cache)) + (newline)))) + +(define (load-bg-cache) + (define file (cache-file "bg.scm")) + (when (file-exists? file) + (let ((forms (call-with-input-file file read))) + (when (list? forms) + (for-each (lambda (form) (apply hash-set! bg-cache form)) + forms))))) + + +(define bg-img-url "https://l.texttv.nu/storage/chars") + +(define (get-bg-image-char frame img) + (or (and=> (hash-ref bg-cache img) string) + (let ((img-file (cache-file (path-append "img" img)))) + (unless (file-exists? img-file) + (download-file (format #f "~a/~a" bg-img-url img) + img-file)) + + (let ((char + (->> (map (lambda (x) + (cond ((eq? x (get-fg frame)) #t) + ((eq? x (get-bg frame)) #f) + (else (scm-error 'misc-error "get-bg-image-char" + "Color neither foreground or background. fg: ~s, bg: ~s, file: ~s" + (list (get-fg frame) (get-bg frame) + img-file) + #f)))) + (parse-image-file img-file)) + list->integer + (vector-ref lookup-table)))) + (hash-set! bg-cache img char) + (return-state (string char)))))) + + +(define bg-rx (make-regexp (format #f "background: url\\(~a/([^)]*)\\)" bg-img-url))) + +(define (handle-h1-or-span class style nodes) + (define (err fmt . args) + (scm-error 'misc-error "handle-h1-or-span" + fmt args + #f)) + (do fmt-before <- (get-attr) (push (class-handlers class)) fmt-with <- (get-attr) + frame <- (get-frame) ret <- (<$> (lambda (s) (string-append fmt-with s fmt-before)) - (<$> string-concatenate (sequence (map fmt-tag nodes)))) + (if (member "bgImg" (string-split class #\space)) + (cond ((regexp-exec bg-rx style) + => (lambda (m) (get-bg-image-char frame (match:substring m 1)))) + (else (err "bgImg without background image style"))) + (<$> string-concatenate (sequence (map fmt-tag nodes))))) + (pop) (return-state ret))) @@ -78,29 +141,29 @@ tag [(a ,body ...) (do fmt-before <- (get-attr) - (push (make-fmt-frame 'underline 'B #f)) + (push (make-fmt-frame 'underline #f #f)) fmt-with <- (get-attr) (pop) (return-state (string-append fmt-with (car body) fmt-before)))] - [(h1 (@ (class ,class)) ,nodes ...) - (handle-h1-or-span class nodes)] + [(h1 (@ (class ,class) (style (,style ""))) ,nodes ...) + (handle-h1-or-span class style nodes)] - [(span (@ (class ,class)) ,nodes ...) - (handle-h1-or-span class nodes)] + [(span (@ (class ,class) (style (,style ""))) ,nodes ...) + (handle-h1-or-span class style nodes)] [,str (guard (string? str)) (return-state str)] - ;; Just ignore tags without children [,default (match default - ((tag ('@ args ..) node nodes ...) - (<$> string-concatenate (sequence (map fmt-tag (cons node nodes))))) - ((tag node nodes ...) - (<$> string-concatenate (sequence (map fmt-tag (cons node nodes))))) ((tag) (return-state "")) + ((tag ('@ args ...)) (return-state "")) + ((tag ('@ args ...) nodes ...) + (<$> string-concatenate (sequence (map fmt-tag nodes)))) + ((tag nodes ...) + (<$> string-concatenate (sequence (map fmt-tag nodes)))) (default (return-state (format #f "[|~a|]" default))))])) (define (text-for-num j int) @@ -130,47 +193,84 @@ (make-string (- 60 trnc) #\-) (truncate (* 100 progress))))) +(define (build-cache-dir) + (unless (file-exists? (cache-path)) + (mkdir (cache-path))) + + (let ((last-updated (cache-file "last-updated"))) + (unless (file-exists? last-updated) + (with-output-to-file last-updated + (lambda () (display 0))))) + + (unless (file-exists? (cache-file "img")) + (mkdir (cache-file "img"))) + + (unless (file-exists? (cache-file "rendered")) + (mkdir (cache-file "rendered"))) + + ) + +(define (render-page file el) + (with-output-to-file file + (lambda () + (-> el + (assoc-ref "content") + (vector-ref 0) + (html->sxml #:trim-whitespace? #f + #:full-document? #f) + fmt-tag + (run-state (list (make-fmt-frame "" "" ""))) + car + display)))) + + +;; Render all pages in vector +(define (render-pages vect) + (define (status i) + (display-status-bar i (vector-length vect) (current-error-port))) + + (format (current-error-port) "~%Rendering HTML~%") + + (vector-for-each + (lambda (i el) + (status i) + (render-page (cache-file (path-append + "rendered" + (format #f "~a.ansi" (assoc-ref el "num")))) + el)) + vect) + + (display-status-bar 1 1 (current-error-port)) + (newline (current-error-port))) + +(define (download-file url destination) + (system* "curl" + "-s" url + "-o" destination)) + (define (main args) - (let* ((self filename pagestr (apply values args)) + (let* ((self base-filename pagestr (apply values args)) + (json-cache (cache-file base-filename)) (page (string->number pagestr))) - (unless (file-exists? (cache-path)) - (mkdir (cache-path)) - (with-output-to-file (cache-file "last-updated") - (lambda () (display 0)))) - - (let ((last-updated (call-with-input-file (cache-file "last-updated") read))) - (when (> (- (current-time) last-updated) 10000) - (display "Downloading new data, please stand by...") - (system* "curl" - "-s" "http://api.texttv.nu/api/get/100-999?app=hugonikanor" - "-o" (cache-file filename)) - - (let* ((json (call-with-input-file (cache-file filename) json->scm)) - (update (max-date json))) - - (with-output-to-file (cache-file "last-updated") (lambda () (display update))) - - (let ((vlen (vector-length json))) - (format (current-error-port) - "~%Rendering HTML~%") - (vector-for-each - (lambda (i el) - (let ((num (assoc-ref el "num")) - (text (-> el (assoc-ref "content") (vector-ref 0)))) - (with-output-to-file (cache-file (format #f "~a.ansi" num)) - (lambda () - (display-status-bar i vlen (current-error-port)) - (-> (html->sxml text - #:trim-whitespace? #f - #:full-document? #f) - fmt-tag - (run-state (list (make-fmt-frame "" "" ""))) - car display))))) - json)) - (display-status-bar 1 1 (current-error-port)) - (newline (current-error-port)))) - - (let ((p1 (cache-file (format #f "~a.ansi" page))) - (p2 (cache-file (format #f "~a.ansi" (1+ page))))) - (system* "paste" p1 p2))))) + (build-cache-dir) + (load-bg-cache) + + (let ((last-updated + (call-with-input-file (cache-file "last-updated") read))) + (when (> (- (current-time) last-updated) 10000) + (display "Downloading new data, please stand by...") + (download-file "http://api.texttv.nu/api/get/100-999?app=hugonikanor" + json-cache) + (newline) + + (let ((page-data (call-with-input-file json-cache json->scm))) + (with-output-to-file (cache-file "last-updated") + (lambda () (write (max-date page-data)) (newline))) + (render-pages page-data)))) + + (let ((p1 (cache-file (path-append "rendered" (format #f "~a.ansi" page)))) + (p2 (cache-file (path-append "rendered" (format #f "~a.ansi" (1+ page)))))) + (system* "paste" p1 p2)) + + (save-bg-cache))) |