From 7352d1932e15b6da85774853e6953c0b390fd75b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Mon, 18 Mar 2019 14:57:14 +0100
Subject: Working.

---
 main.scm | 147 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 147 insertions(+)
 create mode 100755 main.scm

(limited to 'main.scm')

diff --git a/main.scm b/main.scm
new file mode 100755
index 0000000..fd4489e
--- /dev/null
+++ b/main.scm
@@ -0,0 +1,147 @@
+#!/usr/bin/guile \
+-q -e main -s
+!#
+
+(add-to-load-path (dirname (current-filename)))
+(add-to-load-path (string-append (dirname (current-filename)) "/monad/"))
+(add-to-load-path "/home/hugo/lib/guile")
+
+(add-to-load-path "/home/hugo/code/calparse")  ; For (util), move that to a library
+
+(setenv "LD_LIBRARY_PATH" (dirname (current-filename)))
+
+(use-modules #; (sxml simple)
+             ;; (sxml match)
+
+             (srfi srfi-1)
+             (srfi srfi-26)
+             (srfi srfi-43)             ; Vector iteration
+
+             ;; (ice-9 rdelim)
+             (ice-9 regex)
+             (ice-9 popen)
+
+             (macros arrow)
+             (util)
+
+             (control monad)
+             (control monad state)
+             (data stack)
+
+             (fmt-stack)
+             (html)
+             (json))
+
+(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 (substr-1 match)
+  (match:substring match 1))
+
+(define (class-handlers class)
+  (fold (lambda (cl obj)
+          (regex-case
+           cl
+           ("^DH$"           (set-style obj 'bold))
+           ("^bg([BYC])$" => (compose (cut set-bg obj <>) string->symbol substr-1))
+           ("^([BYC])$"   => (compose (cut set-fg obj <>) string->symbol substr-1))
+           (else obj)))
+        (empty-fmt-frame)
+        (string-split class #\space)))
+
+;;; TODO every push and pop should emit current ANSI-escape after it has run.
+
+(use-modules (ice-9 match))
+
+;;; TODO Every clause should return a string, in the state context of a state.
+
+;;                  +-- State storage, "mutable"
+;;                  |          +- Return value, static
+;;                  V          V
+;; sxml → State <fmt-stack> <string>
+(define (fmt-tag tag)
+  (match tag
+
+    [('a _ body ...)
+     (do fmt-before <- (get-attr)
+         (push (make-fmt-frame 'underline 'B #f))
+         fmt-with <- (get-attr)
+         (pop)
+         (return-state
+          (string-append fmt-with (car body) fmt-before)))]
+
+    [((or 'h1 'span) attrs nodes ...)
+     (do let class = (hashq-ref attrs 'class)
+         fmt-before <- (get-attr)
+         (push (class-handlers class))
+         fmt-with <- (get-attr)
+         ret <- (fmap (cut string-append fmt-with <> fmt-before)
+                      (fmap string-concatenate (sequence (map fmt-tag nodes))))
+         (pop)
+         (return-state ret))]
+
+    ;; Default rule, since the above case requires a class list
+    [(tag _ node nodes ...)
+     (fmap string-concatenate (sequence (map fmt-tag (cons node nodes))))]
+
+    ;; Just ignore tags without children
+    [(tag _) (return-state "")]
+
+    [(? string? str) (return-state str)]
+
+    [default (return-state (format #f "[|~a|]" default))]))
+
+(define (parse-html-string str)
+  (let ((fname (tmpnam)))
+    (with-output-to-file fname
+      (lambda () (display str)))
+    (parse-html fname)))
+
+(define (text-for-num j int)
+  (let* ((table (vector-ref j (- int 100)))
+         (arr (hashq-ref table 'content))
+         (text (array-ref arr 0)))
+    text))
+
+(define (max-date vect)
+  (vector-fold (lambda (i accum el) (max accum (hashq-ref el 'date_updated_unix)))
+               0 vect))
+
+(define (main args)
+  (let* (((self filename pagestr) args)
+         (page (string->number pagestr)))
+
+    (let ((last-updated (call-with-input-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" filename)
+
+       (let* ((json (get-json filename))
+              (update (max-date json)))
+
+         (with-output-to-file ".last-updated" (lambda () (display update)))
+
+         (vector-for-each
+          (lambda (i el)
+            (let ((num (hashq-ref el 'num))
+                  (text (vector-ref (hashq-ref el 'content) 0)))
+              (with-output-to-file (format #f "cache/~a.ansi" num)
+                (lambda () (-> (parse-html-string text)
+                          fmt-tag
+                          (run-state (list (make-fmt-frame "" "" "")))
+                          car display)))))
+          json)))
+
+     (let ((p1 (format #f "cache/~a.ansi" page))
+           (p2 (format #f "cache/~a.ansi" (1+ page))))
+       (system* "paste" p1 p2))
+     )))
-- 
cgit v1.2.3