123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587 |
- #!/bin/sh
- exec "${GUILE:-guile}" -e "(@ (explore) guix-explore)" -s "$0" "$@"
- !#
- ;;; GNU Guix --- Functional package management for GNU
- ;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
- ;;;
- ;;; This file is part of GNU Guix.
- ;;;
- ;;; GNU Guix is free software; you can redistribute it and/or modify it
- ;;; under the terms of the GNU General Public License as published by
- ;;; the Free Software Foundation; either version 3 of the License, or (at
- ;;; your option) any later version.
- ;;;
- ;;; GNU Guix is distributed in the hope that it will be useful, but
- ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
- ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ;;; GNU General Public License for more details.
- ;;;
- ;;; You should have received a copy of the GNU General Public License
- ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
- (define-module (explore)
- #:use-module (gnu)
- #:use-module (guix)
- #:use-module (guix i18n)
- #:use-module (gnu services)
- #:autoload (gnu services desktop) (%desktop-services)
- #:use-module (guix gexp)
- #:use-module (guix ui)
- #:use-module (guix store)
- #:use-module (json)
- #:use-module (sxml simple)
- #:autoload (syntax-highlight) (highlight highlights->sxml)
- #:autoload (syntax-highlight scheme)
- (make-scheme-lexer %default-special-symbols)
- #:autoload (texinfo) (texi-fragment->stexi)
- #:autoload (texinfo html) (stexi->shtml)
- #:autoload (ice-9 pretty-print) (truncated-print)
- #:use-module (web request)
- #:use-module (web response)
- #:use-module (web server)
- #:use-module (web uri)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-9)
- #:use-module (srfi srfi-9 gnu)
- #:use-module (srfi srfi-26)
- #:use-module (srfi srfi-71)
- #:use-module (ice-9 match)
- #:use-module (ice-9 binary-ports)
- #:autoload (ice-9 ftw) (scandir)
- #:autoload (ice-9 pretty-print) (pretty-print)
- #:export (guix-explore)
- #:declarative? #f) ;for Geiser
- ;;; Commentary:
- ;;;
- ;;; Serve a web page that provides an interactive view of the services of a
- ;;; system.
- ;;;
- ;;; Code:
- (define* (not-found request
- #:key (phrase "Resource not found")
- ttl)
- "Render 404 response for REQUEST."
- (values (build-response #:code 404
- #:headers (if ttl
- `((cache-control (max-age . ,ttl)))
- '()))
- (string-append phrase ": "
- (uri-path (request-uri request)))))
- (define (request-path-components request)
- "Split the URI path of REQUEST into a list of component strings. For
- example: \"/foo/bar\" yields '(\"foo\" \"bar\")."
- (split-and-decode-uri-path (uri-path (request-uri request))))
- (define (render-home-page request)
- (values '((content-type . (text/html (charset . "UTF-8"))))
- (call-with-output-string
- (lambda (port)
- (sxml->xml `(html
- (head (title "GNU Guix System Explorer")
- (link (@ (rel "stylesheet")
- (type "text/css")
- (href "/static/css/style.css")))
- (link (@ (rel "stylesheet")
- (type "text/css")
- (href "/static/css/code.css"))))
- (body
- (h1 "Exploring Your System!")
- (div (@ (id "container") (class "svg-container"))
- ;; (svg (@ (id "graph")))
- )
- (script (@ (type "text/javascript")
- (src "/static/js/d3.v6.js"))
- "script")
- (script (@ (type "text/javascript")
- (src "/static/js/graph.js"))
- "script")))
- port)))))
- (define (service-node-id service)
- "Return an identifier for SERVICE, then used to uniquely identify it in the
- serialized JSON representation of the graph."
- (string-append (symbol->string (service-type-name (service-kind service)))
- "-"
- (number->string (object-address service) 16)))
- (define (service-html-description service)
- "Return the localized description of SERVICE's type as HTML."
- (call-with-output-string
- (lambda (port)
- (sxml->xml (stexi->shtml
- (texi-fragment->stexi
- (match (service-type-description (service-kind service))
- (#f "")
- (str (P_ str)))))
- port))))
- (define* (render-nodes request services
- #:key (category (const 'base)))
- "Respond to REQUEST by rendering SERVICES as a set of graph nodes, as
- JSON."
- (define (service->json-node service)
- `((id . ,(service-node-id service))
- (label . ,(symbol->string
- (service-type-name (service-kind service))))
- (category . ,(category service))
- (description . ,(service-html-description service))))
- (values '((content-type . (application/json (charset . "UTF-8"))))
- (scm->json-string
- (list->vector
- (map service->json-node services)))))
- (define service-back-edges
- (@@ (gnu services) service-back-edges))
- (define (render-edges request services)
- "Respond to REQUEST by rendering the edges among SERVICES as JSON."
- (define back-edges
- (service-back-edges services))
- (define (service->edges service)
- (map (lambda (dependent)
- `((target . ,(service-node-id service))
- (source . ,(service-node-id dependent))))
- (back-edges service)))
- (values '((content-type . (application/json (charset . "UTF-8"))))
- (scm->json-string
- (list->vector
- (append-map service->edges services)))))
- (define (at-most max-length lst) ;from (guix scripts substitute)
- "If LST is shorter than MAX-LENGTH, return it and the empty list; otherwise
- return its MAX-LENGTH first elements and its tail."
- (let loop ((len 0)
- (lst lst)
- (result '()))
- (match lst
- (()
- (values (reverse result) '()))
- ((head . tail)
- (if (>= len max-length)
- (values (reverse result) lst)
- (loop (+ 1 len) tail (cons head result)))))))
- (define (store-link file)
- "Return SHTML containing a link to FILE, a file in the store."
- (define store-prefix-len
- (+ (string-length (%store-prefix))
- 32 2))
- `(a (@ (href ,(store-file-url file))
- (class "store-link"))
- ,(string-append (%store-prefix) "/…-"
- (string-drop file store-prefix-len))))
- (define (link-store-items sxml)
- "Recurse over SXML and syntax-highlight code snippets."
- (define min-length
- (+ (string-length (%store-prefix)) 32 1))
- (define (quoted-string? str)
- (and (string-prefix? "\"" str)
- (string-suffix? "\"" str)))
- (match sxml
- ((tag ('@ attributes ...) body ...)
- `(,tag (@ ,@attributes) ,@(map link-store-items body)))
- ((tag body ...)
- `(,tag ,@(map link-store-items body)))
- ((? string? str)
- (if (quoted-string? str)
- (let ((unquoted (string-drop (string-drop-right str 1) 1)))
- (if (and (store-path? unquoted)
- (> (string-length unquoted) min-length))
- `("\"" ,(store-link unquoted) "\"")
- str))
- str))))
- (define* (value->shtml store value
- #:key (limit 20))
- "Render VALUE, an arbitrary Scheme value (a service value),
- as SHTML. Display at most LIMIT elements for lists."
- ;; Note: If the author was versed in JavaScript, they'd send the value as
- ;; JSON to the browser, and let JS code in the browser present it. But
- ;; hey, SXML is so comfortable!
- (define scheme-lexer
- (make-scheme-lexer %default-special-symbols
- '("define" "syntax")))
- (define (object->pretty-string obj)
- (call-with-output-string
- (lambda (port)
- (pretty-print obj port #:width 50))))
- (define (highlight-scheme str)
- (link-store-items
- (highlights->sxml (highlight scheme-lexer str))))
- (match value
- ((? package? package)
- `(a (@ (href ,(string-append "https://hpc.guix.info/package/"
- (package-name package))))
- ,(package-full-name package)))
- ((? file-like? file)
- ;; Clever trick: use 'lower-gexp' to combine lowering and expansion;
- ;; 'lower-object' would get expansion wrong for 'file-append' and such.
- (match (lowered-gexp-sexp (run-with-store store
- (lower-gexp #~(-> #$file))))
- (('-> (? string? file))
- `(span "\"" ,(store-link file) "\""))))
- ((? gexp? gexp)
- (let ((sexp (lowered-gexp-sexp (run-with-store store
- (lower-gexp gexp)))))
- `(pre (@ (class "scheme-value"))
- ,(highlight-scheme (object->pretty-string sexp)))))
- ((? struct? record)
- (let ((rtd (record-type-descriptor record)))
- `(div (@ (class "scheme-record"))
- ,@(map (lambda (field)
- `(div (@ (class "scheme-record-field"))
- (span (@ (class "scheme-record-field-name"))
- ,field)
- (span (@ (class "scheme-record-field-value"))
- ,(value->shtml
- store
- ((record-accessor rtd field) record)
- #:limit limit))))
- (record-type-fields rtd)))))
- ((lst ...)
- (let ((lst tail (at-most limit lst)))
- `(span (@ (class "scheme-list")) "("
- ,@(map (lambda (item)
- `(span (@ (class "scheme-list-element"))
- ,(value->shtml store item #:limit limit)))
- lst)
- ,@(if (null? tail)
- '()
- `((span (@ (class "scheme-list-ellipsis"))
- "…")))
- ")")))
- ((? array? array) ;string, bytevector, etc.
- (let ((str (call-with-output-string
- (lambda (port)
- (truncated-print array port
- #:width 50)))))
- `(pre (@ (class "scheme-value"))
- ,(highlight-scheme str))))
- ;; TODO: Add 'plain-file', etc.
- (x
- `(pre (@ (class "scheme-value"))
- ,(highlight-scheme (object->pretty-string x))))))
- (define (query-parameters str)
- "Return an alist corresponding to the query parameter string STR, a string
- like \"?x=a%20b&y=42\"."
- (define not-equal
- (char-set-complement (char-set #\=)))
- (define not-question-ampersand
- (char-set-complement (char-set #\? #\&)))
- (filter-map (lambda (key=value)
- (match (string-tokenize key=value not-equal)
- ((key value)
- (cons (string->symbol (uri-decode key))
- (uri-decode value)))
- (_ #f)))
- (string-tokenize str not-question-ampersand)))
- (define* (request-query-parameter request parameter
- #:optional (default #f))
- "Return the PARAMETER query parameter of REQUEST, where PARAMETER is a
- symbol, or DEFAULT if PARAMETER was not given."
- (define parameters
- (or (and=> (uri-query (request-uri request)) query-parameters)
- '()))
- (or (assoc-ref parameters parameters)
- default))
- (define (render-node-value request store services id)
- "Render as JSON the value of the service with the given ID among SERVICES."
- (define limit
- (or (and=> (request-query-parameter request 'limit) string->number)
- 20))
- (match (find (lambda (service)
- (string=? (service-node-id service) id))
- services)
- (#f (not-found request))
- (service
- (values '((content-type . (text/html (charset . "UTF-8"))))
- (call-with-output-string
- (lambda (port)
- (sxml->xml (value->shtml store (service-value service)
- #:limit limit)
- port)))))))
- (define (render-edge-value request store services source-id target-id)
- "Render the value of the edge from SOURCE-ID to TARGET-ID."
- (define limit
- (or (and=> (request-query-parameter request 'limit) string->number)
- 20))
- (define (matching-id? id)
- (lambda (service)
- (string=? (service-node-id service) id)))
- (define source
- (find (matching-id? source-id) services))
- (define target
- (find (matching-id? target-id) services))
- (if (and source target)
- (let* ((extension (find (lambda (extension)
- (eq? (service-extension-target extension)
- (service-kind target)))
- (service-type-extensions
- (service-kind source))))
- (compute (service-extension-compute extension))
- (value (compute (service-value source))))
- (values '((content-type . (text/html (charset . "UTF-8"))))
- (call-with-output-string
- (lambda (port)
- (sxml->xml (value->shtml store value #:limit limit)
- port)))))
- (not-found request)))
- (define (render-file request file)
- (let* ((file (string-append (dirname (current-filename))
- "/" (basename file)))
- (mime-type (cond ((string-suffix? ".js" file)
- '(text/javascript))
- ((string-suffix? ".css" file)
- '(text/css))
- (else
- '(application/octet-stream)))))
- (if (file-exists? file)
- (values `((content-type . ,mime-type))
- (call-with-input-file file
- get-bytevector-all))
- (not-found request))))
- (define (store-file-url file)
- "Return a URI reference for FILE, a store file."
- (uri->string
- (build-uri-reference #:path (string-append "/store" file))))
- (define (render-directory directory)
- (values '((content-type . (text/html (charset . "UTF-8"))))
- (call-with-output-string
- (lambda (port)
- (sxml->xml
- `(html
- (head (title "Directory Listing"))
- (body
- (h1 (tt ,directory))
- (ul
- ,@(map (lambda (file)
- (let ((full (string-append directory "/" file)))
- `(li (a (@ (href ,(store-file-url full)))
- (tt ,file)))))
- (scandir directory
- (match-lambda
- ((or "." "..") #f)
- (_ #t)))))))
- port)))))
- (define %text-extensions
- ;; Extensions of text files.
- '("rc" ".txt" ".org" ".scm" ".js" ".conf" ".cnf" "_config"
- "motd" ".service" "-mcron-job" ".rules" "fstab"))
- (define (render-store-item request file)
- "Render FILE, a store item."
- (if (and (store-path? file) (file-exists? file))
- (if (file-is-directory? file)
- (render-directory file)
- (let ((mime (if (any (cut string-suffix? <> file)
- %text-extensions)
- '(text/plain) ;unknown charset?
- '(application/octet-stream))))
- (values `((content-type . ,mime))
- (call-with-input-file file
- get-bytevector-all)))) ;FIXME: argh!
- ;; TODO: If there's a deriver for FILE, add a "build" button.
- (not-found request)))
- ;; State of what's currently represented.
- (define-record-type <view>
- (view user essential initial services previous)
- view?
- (user view-user-services)
- (essential view-essential-services)
- (initial view-initial-services)
- (services view-services)
- (previous view-previous-view))
- (define-syntax-rule (thread-state exp state ...)
- (call-with-values
- (lambda ()
- exp)
- (lambda (response body . rest)
- (apply values response body (append rest (list state ...))))))
- (define (compute-folding services root)
- "Fold SERVICES to ROOT (a service). Return the updated root along with the
- remaining services--i.e., those that have not been folded."
- (define updated-root
- (fold-services services
- #:target-type (service-kind root)))
- (define back-edges
- (service-back-edges services))
- (define dependents
- (let loop ((nodes (list root))
- (result '()))
- (match nodes
- (() result)
- (nodes (loop (append-map back-edges nodes)
- (append nodes result))))))
- (values (cons updated-root
- ;; FIXME: Remove the edges to ROOT rather than all of
- ;; DEPENDENTS.
- (remove (lambda (service)
- (memq service dependents))
- services))
- updated-root))
- (define (render-folding request view id)
- "Respond to REQUEST, which is about folding services to ID."
- (define root
- (find (lambda (service)
- (string=? (service-node-id service) id))
- (view-services view)))
- (let ((services updated-root (compute-folding (view-services view)
- root)))
- (values '((content-type . (application/json (charset . "UTF-8"))))
- ;; Return the ID of UPDATED-ROOT so it can be highlighted.
- (scm->json-string
- `((id . ,(service-node-id updated-root))))
- (set-fields view
- ((view-services) services)
- ((view-previous-view) view)))))
- (define (render-previous-view request view)
- "Respond to REQUEST by restoring the previous view--IOW, \"undoing\" the
- latest changes."
- (if (view-previous-view view)
- (values (build-response #:code 200)
- "Undone!"
- (view-previous-view view))
- (values (build-response #:code 404
- #:reason-phrase "Nothing to undo.")
- ""
- view)))
- (define (render-initial-view request view)
- "Respond to REQUEST by restoring the initial view."
- (values (build-response #:code 200)
- "Reset!"
- (set-fields view
- ((view-services)
- (view-initial-services view))
- ((view-previous-view)
- #f))))
- (define (handle-request request body view store)
- (define (service-category service)
- (cond ((memq service (view-essential-services view))
- 'essential)
- ((memq service %base-services) 'base)
- ((memq service %desktop-services) 'desktop)
- (else 'user)))
- (define services
- (view-services view))
- (pk 'req (request-method request)
- (uri->string (request-uri request)))
- (if (eq? 'GET (request-method request))
- (match (request-path-components request)
- ((or () ("index.html"))
- (thread-state (render-home-page request) view store))
- (("static" _ ... file)
- (thread-state (render-file request file) view store))
- (("store" file ...)
- (thread-state (render-store-item request
- (string-join file "/" 'prefix))
- view store))
- (("edges")
- (thread-state (render-edges request services)
- view store))
- (("nodes")
- (thread-state (render-nodes request services
- #:category service-category)
- view store))
- (("value" id)
- (thread-state (render-node-value request store services id)
- view store))
- (("edge" source target)
- (thread-state (render-edge-value request store
- services source target)
- view store))
- (("fold" id)
- (thread-state (render-folding request view id)
- store))
- (("undo")
- (thread-state (render-previous-view request view)
- store))
- (("reset")
- (thread-state (render-initial-view request view)
- store))
- (("quit")
- (throw 'quit 1))
- (_
- (thread-state (not-found request) view store)))
- (thread-state (not-found request) view store)))
- (define* (run-explore-server os #:key (port 8080))
- (define user-services
- (operating-system-user-services os))
- (define essential-services
- (operating-system-essential-services os))
- (define services
- (instantiate-missing-services
- (append user-services essential-services)))
- (info (G_ "Open a browser at ~a and start exploring!~%")
- (string-append "http://localhost:" (number->string port)))
- (with-store store
- (run-server handle-request (lookup-server-impl 'http)
- `(#:port ,port)
- (view user-services essential-services
- services services #f)
- store)))
- (define (guix-explore args)
- (define %user-module ;copied from (guix scripts system)
- ;; Module in which the machine description file is loaded.
- (make-user-module '((gnu system)
- (gnu services)
- (gnu system shadow))))
- (with-error-handling
- (match args
- ((_ file)
- (run-explore-server (load* file %user-module)))
- (_
- (leave (G_ "Usage: explore FILE~%"))))))
|