01/01: hydra: Add simple log viewer.

[Ricardo Wurmus]

rekado pushed a commit to branch master
in repository maintenance.

commit 3402dda36bd14b47f583ce0c4bb0f2c355a0a036
Author: Ricardo Wurmus <address@hidden>
Date:   Thu Jun 27 22:43:00 2019 +0200

    hydra: Add simple log viewer.
    
    * hydra/goggles.scm: New file.
---
 hydra/goggles.scm | 171 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 171 insertions(+)

diff --git a/hydra/goggles.scm b/hydra/goggles.scm
new file mode 100644
index 0000000..ba63bf2
--- /dev/null
+++ b/hydra/goggles.scm
@@ -0,0 +1,171 @@
+#!/run/current-system/profile/bin/guile \
+--no-auto-compile -e main -s
+!#
+(use-modules (web http)
+             (web request)
+             (web response)
+             (web server)
+             (web uri)
+             (sxml simple)
+             (srfi srfi-1)
+             (srfi srfi-26)
+             (ice-9 ftw)
+             (ice-9 match)
+             (ice-9 regex)
+             (ice-9 textual-ports))
+
+(define %log-root "/var/www/.well-known/logs/")
+(define %config
+  '((host . "0.0.0.0")
+    (port . 3333)))
+
+(define file-mime-types
+  '(("css" . (text/css))
+    ("js"  . (text/javascript))
+    ("png" . (image/png))
+    ("gif" . (image/gif))
+    ("woff" . (application/font-woff))
+    ("ttf"  . (application/octet-stream))
+    ("html" . (text/html))))
+
+(define (render-html sxml)
+  (list '((content-type . (text/html)))
+        (lambda (port)
+          (sxml->xml sxml port))))
+
+(define css
+  "\
+html {
+  background: #fdfdfd;
+}
+
+.nick {
+  margin-right: 0.5rem;
+  font-weight: bold;
+}
+
+.notice {
+  color: #859900;
+}
+
+.time a {
+  color: #999;
+  margin-right: 0.5rem;
+}
+")
+
+(define colors
+  (circular-list "#389600" "#8dd3c7" "#bebada" "#fb8072"
+                 "#80b1d3" "#fdb462" "#b3de69" "#fccde5"
+                 "#d9d9d9" "#bc80bd" "#ccebc5" "#ffed6f"))
+
+(define (not-found uri)
+  (list (build-response #:code 404)
+        (string-append "Resource not found: " (uri->string uri))))
+
+(define (directory? filename)
+  (string=? filename (dirname filename)))
+
+(define (make-line-renderer lines)
+  "Return a procedure that converts a line into an SXML
+representation highlighting certain parts."
+  (define participants
+    (delete-duplicates (filter-map (match-lambda
+                                     ((_ nick . anything) nick)
+                                     (_ #f))
+                                   lines)
+                       string=?))
+  (define (nick-color who)
+    (or (and=> (assoc-ref (zip participants colors) who)
+               first)
+        (first colors)))
+  (match-lambda
+    (("") '(br))
+    ((time "***" . msg)
+     (let ((id (string-filter char-set:digit time)))
+       `(div (@ (class "line") (id ,id))
+             (span (@ (class "time"))
+                   (a (@ (href ,(string-append "#" id)))
+                      ,time))
+             (span (@ (class "notice")) "*** " ,(string-join msg)))))
+    ((time nick . rest)
+     (let ((id (string-filter char-set:digit time)))
+       `(div (@ (class "line") (id ,id))
+             (span (@ (class "time"))
+                   (a (@ (href ,(string-append "#" id)))
+                      ,time))
+             (span (@ (class "nick")
+                      (style ,(string-append "color:" (nick-color nick))))
+                   ,nick)
+             ,@(reverse (fold (lambda (chunk acc)
+                                (cond
+                                 ((string-match "http.?://.+" chunk)
+                                  (cons* " "
+                                         `(a (@ (href ,chunk)) ,chunk)
+                                         " "
+                                         acc))
+                                 (else
+                                  (match acc
+                                    (((? string? s) . rest)
+                                     (cons (string-append s " " chunk) (cdr 
acc)))
+                                    (_ (cons chunk acc)))))) '()
+                                    rest)))))))
+
+(define (render-log root path)
+  ;; PATH is a list of path components
+  (let ((file-name (string-join (cons* root path) "/")))
+    (if (and (not (any (cut string-contains <> "..") path))
+             (file-exists? file-name)
+             (not (directory? file-name)))
+        (let* ((text (call-with-input-file file-name get-string-all))
+               (lines (string-split text #\newline))
+               (split-lines (map (cut string-split <> #\space) lines))
+               (handle-line (make-line-renderer split-lines)))
+          (render-html
+           `(html
+             (head (style ,css))
+             (body
+              (h1 "#guix channel logs")
+              (h2 ,path)
+              (a (@ (href "/")) "back to list of logs") (br)
+              ,@(map handle-line split-lines)))))
+        (not-found (build-uri 'http
+                              #:host (assoc-ref %config 'host)
+                              #:port (assoc-ref %config 'port)
+                              #:path (string-join path "/" 'prefix))))))
+
+(define (index)
+  `(html
+    (head (title "Guix IRC channel logs"))
+    (body
+     (h1 "Guix IRC channel logs")
+     (p "These are the channel logs for the #guix IRC channel on
+freenode.")
+     (ul
+      ,@(map (lambda (file)
+               `(li (a (@ (href ,file)) ,file)))
+             (or (scandir %log-root (lambda (name)
+                                      (not (member name '("." ".." 
"index.html")))))
+                 '()))))))
+
+(define %controller
+  (match-lambda
+    ((GET)
+     (render-html (index)))
+    ((GET path ...)
+     (render-log %log-root path))))
+
+(define (request-path-components request)
+  (split-and-decode-uri-path (uri-path (request-uri request))))
+
+(define (handler request . _)
+  (apply values (%controller
+                 (cons (request-method request)
+                       (request-path-components request)))))
+
+(define (main . args)
+  (let ((port (assoc-ref %config 'port)))
+    (run-server handler
+                'http
+                `(#:addr ,INADDR_ANY
+                  #:port ,port))))