[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
01/01: hydra: Add simple log viewer.
From: |
Ricardo Wurmus |
Subject: |
01/01: hydra: Add simple log viewer. |
Date: |
Thu, 27 Jun 2019 16:43:30 -0400 (EDT) |
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))))