explore.scm 22 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587
  1. #!/bin/sh
  2. exec "${GUILE:-guile}" -e "(@ (explore) guix-explore)" -s "$0" "$@"
  3. !#
  4. ;;; GNU Guix --- Functional package management for GNU
  5. ;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
  6. ;;;
  7. ;;; This file is part of GNU Guix.
  8. ;;;
  9. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  10. ;;; under the terms of the GNU General Public License as published by
  11. ;;; the Free Software Foundation; either version 3 of the License, or (at
  12. ;;; your option) any later version.
  13. ;;;
  14. ;;; GNU Guix is distributed in the hope that it will be useful, but
  15. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  17. ;;; GNU General Public License for more details.
  18. ;;;
  19. ;;; You should have received a copy of the GNU General Public License
  20. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  21. (define-module (explore)
  22. #:use-module (gnu)
  23. #:use-module (guix)
  24. #:use-module (guix i18n)
  25. #:use-module (gnu services)
  26. #:autoload (gnu services desktop) (%desktop-services)
  27. #:use-module (guix gexp)
  28. #:use-module (guix ui)
  29. #:use-module (guix store)
  30. #:use-module (json)
  31. #:use-module (sxml simple)
  32. #:autoload (syntax-highlight) (highlight highlights->sxml)
  33. #:autoload (syntax-highlight scheme)
  34. (make-scheme-lexer %default-special-symbols)
  35. #:autoload (texinfo) (texi-fragment->stexi)
  36. #:autoload (texinfo html) (stexi->shtml)
  37. #:autoload (ice-9 pretty-print) (truncated-print)
  38. #:use-module (web request)
  39. #:use-module (web response)
  40. #:use-module (web server)
  41. #:use-module (web uri)
  42. #:use-module (srfi srfi-1)
  43. #:use-module (srfi srfi-9)
  44. #:use-module (srfi srfi-9 gnu)
  45. #:use-module (srfi srfi-26)
  46. #:use-module (srfi srfi-71)
  47. #:use-module (ice-9 match)
  48. #:use-module (ice-9 binary-ports)
  49. #:autoload (ice-9 ftw) (scandir)
  50. #:autoload (ice-9 pretty-print) (pretty-print)
  51. #:export (guix-explore)
  52. #:declarative? #f) ;for Geiser
  53. ;;; Commentary:
  54. ;;;
  55. ;;; Serve a web page that provides an interactive view of the services of a
  56. ;;; system.
  57. ;;;
  58. ;;; Code:
  59. (define* (not-found request
  60. #:key (phrase "Resource not found")
  61. ttl)
  62. "Render 404 response for REQUEST."
  63. (values (build-response #:code 404
  64. #:headers (if ttl
  65. `((cache-control (max-age . ,ttl)))
  66. '()))
  67. (string-append phrase ": "
  68. (uri-path (request-uri request)))))
  69. (define (request-path-components request)
  70. "Split the URI path of REQUEST into a list of component strings. For
  71. example: \"/foo/bar\" yields '(\"foo\" \"bar\")."
  72. (split-and-decode-uri-path (uri-path (request-uri request))))
  73. (define (render-home-page request)
  74. (values '((content-type . (text/html (charset . "UTF-8"))))
  75. (call-with-output-string
  76. (lambda (port)
  77. (sxml->xml `(html
  78. (head (title "GNU Guix System Explorer")
  79. (link (@ (rel "stylesheet")
  80. (type "text/css")
  81. (href "/static/css/style.css")))
  82. (link (@ (rel "stylesheet")
  83. (type "text/css")
  84. (href "/static/css/code.css"))))
  85. (body
  86. (h1 "Exploring Your System!")
  87. (div (@ (id "container") (class "svg-container"))
  88. ;; (svg (@ (id "graph")))
  89. )
  90. (script (@ (type "text/javascript")
  91. (src "/static/js/d3.v6.js"))
  92. "script")
  93. (script (@ (type "text/javascript")
  94. (src "/static/js/graph.js"))
  95. "script")))
  96. port)))))
  97. (define (service-node-id service)
  98. "Return an identifier for SERVICE, then used to uniquely identify it in the
  99. serialized JSON representation of the graph."
  100. (string-append (symbol->string (service-type-name (service-kind service)))
  101. "-"
  102. (number->string (object-address service) 16)))
  103. (define (service-html-description service)
  104. "Return the localized description of SERVICE's type as HTML."
  105. (call-with-output-string
  106. (lambda (port)
  107. (sxml->xml (stexi->shtml
  108. (texi-fragment->stexi
  109. (match (service-type-description (service-kind service))
  110. (#f "")
  111. (str (P_ str)))))
  112. port))))
  113. (define* (render-nodes request services
  114. #:key (category (const 'base)))
  115. "Respond to REQUEST by rendering SERVICES as a set of graph nodes, as
  116. JSON."
  117. (define (service->json-node service)
  118. `((id . ,(service-node-id service))
  119. (label . ,(symbol->string
  120. (service-type-name (service-kind service))))
  121. (category . ,(category service))
  122. (description . ,(service-html-description service))))
  123. (values '((content-type . (application/json (charset . "UTF-8"))))
  124. (scm->json-string
  125. (list->vector
  126. (map service->json-node services)))))
  127. (define service-back-edges
  128. (@@ (gnu services) service-back-edges))
  129. (define (render-edges request services)
  130. "Respond to REQUEST by rendering the edges among SERVICES as JSON."
  131. (define back-edges
  132. (service-back-edges services))
  133. (define (service->edges service)
  134. (map (lambda (dependent)
  135. `((target . ,(service-node-id service))
  136. (source . ,(service-node-id dependent))))
  137. (back-edges service)))
  138. (values '((content-type . (application/json (charset . "UTF-8"))))
  139. (scm->json-string
  140. (list->vector
  141. (append-map service->edges services)))))
  142. (define (at-most max-length lst) ;from (guix scripts substitute)
  143. "If LST is shorter than MAX-LENGTH, return it and the empty list; otherwise
  144. return its MAX-LENGTH first elements and its tail."
  145. (let loop ((len 0)
  146. (lst lst)
  147. (result '()))
  148. (match lst
  149. (()
  150. (values (reverse result) '()))
  151. ((head . tail)
  152. (if (>= len max-length)
  153. (values (reverse result) lst)
  154. (loop (+ 1 len) tail (cons head result)))))))
  155. (define (store-link file)
  156. "Return SHTML containing a link to FILE, a file in the store."
  157. (define store-prefix-len
  158. (+ (string-length (%store-prefix))
  159. 32 2))
  160. `(a (@ (href ,(store-file-url file))
  161. (class "store-link"))
  162. ,(string-append (%store-prefix) "/…-"
  163. (string-drop file store-prefix-len))))
  164. (define (link-store-items sxml)
  165. "Recurse over SXML and syntax-highlight code snippets."
  166. (define min-length
  167. (+ (string-length (%store-prefix)) 32 1))
  168. (define (quoted-string? str)
  169. (and (string-prefix? "\"" str)
  170. (string-suffix? "\"" str)))
  171. (match sxml
  172. ((tag ('@ attributes ...) body ...)
  173. `(,tag (@ ,@attributes) ,@(map link-store-items body)))
  174. ((tag body ...)
  175. `(,tag ,@(map link-store-items body)))
  176. ((? string? str)
  177. (if (quoted-string? str)
  178. (let ((unquoted (string-drop (string-drop-right str 1) 1)))
  179. (if (and (store-path? unquoted)
  180. (> (string-length unquoted) min-length))
  181. `("\"" ,(store-link unquoted) "\"")
  182. str))
  183. str))))
  184. (define* (value->shtml store value
  185. #:key (limit 20))
  186. "Render VALUE, an arbitrary Scheme value (a service value),
  187. as SHTML. Display at most LIMIT elements for lists."
  188. ;; Note: If the author was versed in JavaScript, they'd send the value as
  189. ;; JSON to the browser, and let JS code in the browser present it. But
  190. ;; hey, SXML is so comfortable!
  191. (define scheme-lexer
  192. (make-scheme-lexer %default-special-symbols
  193. '("define" "syntax")))
  194. (define (object->pretty-string obj)
  195. (call-with-output-string
  196. (lambda (port)
  197. (pretty-print obj port #:width 50))))
  198. (define (highlight-scheme str)
  199. (link-store-items
  200. (highlights->sxml (highlight scheme-lexer str))))
  201. (match value
  202. ((? package? package)
  203. `(a (@ (href ,(string-append "https://hpc.guix.info/package/"
  204. (package-name package))))
  205. ,(package-full-name package)))
  206. ((? file-like? file)
  207. ;; Clever trick: use 'lower-gexp' to combine lowering and expansion;
  208. ;; 'lower-object' would get expansion wrong for 'file-append' and such.
  209. (match (lowered-gexp-sexp (run-with-store store
  210. (lower-gexp #~(-> #$file))))
  211. (('-> (? string? file))
  212. `(span "\"" ,(store-link file) "\""))))
  213. ((? gexp? gexp)
  214. (let ((sexp (lowered-gexp-sexp (run-with-store store
  215. (lower-gexp gexp)))))
  216. `(pre (@ (class "scheme-value"))
  217. ,(highlight-scheme (object->pretty-string sexp)))))
  218. ((? struct? record)
  219. (let ((rtd (record-type-descriptor record)))
  220. `(div (@ (class "scheme-record"))
  221. ,@(map (lambda (field)
  222. `(div (@ (class "scheme-record-field"))
  223. (span (@ (class "scheme-record-field-name"))
  224. ,field)
  225. (span (@ (class "scheme-record-field-value"))
  226. ,(value->shtml
  227. store
  228. ((record-accessor rtd field) record)
  229. #:limit limit))))
  230. (record-type-fields rtd)))))
  231. ((lst ...)
  232. (let ((lst tail (at-most limit lst)))
  233. `(span (@ (class "scheme-list")) "("
  234. ,@(map (lambda (item)
  235. `(span (@ (class "scheme-list-element"))
  236. ,(value->shtml store item #:limit limit)))
  237. lst)
  238. ,@(if (null? tail)
  239. '()
  240. `((span (@ (class "scheme-list-ellipsis"))
  241. "…")))
  242. ")")))
  243. ((? array? array) ;string, bytevector, etc.
  244. (let ((str (call-with-output-string
  245. (lambda (port)
  246. (truncated-print array port
  247. #:width 50)))))
  248. `(pre (@ (class "scheme-value"))
  249. ,(highlight-scheme str))))
  250. ;; TODO: Add 'plain-file', etc.
  251. (x
  252. `(pre (@ (class "scheme-value"))
  253. ,(highlight-scheme (object->pretty-string x))))))
  254. (define (query-parameters str)
  255. "Return an alist corresponding to the query parameter string STR, a string
  256. like \"?x=a%20b&y=42\"."
  257. (define not-equal
  258. (char-set-complement (char-set #\=)))
  259. (define not-question-ampersand
  260. (char-set-complement (char-set #\? #\&)))
  261. (filter-map (lambda (key=value)
  262. (match (string-tokenize key=value not-equal)
  263. ((key value)
  264. (cons (string->symbol (uri-decode key))
  265. (uri-decode value)))
  266. (_ #f)))
  267. (string-tokenize str not-question-ampersand)))
  268. (define* (request-query-parameter request parameter
  269. #:optional (default #f))
  270. "Return the PARAMETER query parameter of REQUEST, where PARAMETER is a
  271. symbol, or DEFAULT if PARAMETER was not given."
  272. (define parameters
  273. (or (and=> (uri-query (request-uri request)) query-parameters)
  274. '()))
  275. (or (assoc-ref parameters parameters)
  276. default))
  277. (define (render-node-value request store services id)
  278. "Render as JSON the value of the service with the given ID among SERVICES."
  279. (define limit
  280. (or (and=> (request-query-parameter request 'limit) string->number)
  281. 20))
  282. (match (find (lambda (service)
  283. (string=? (service-node-id service) id))
  284. services)
  285. (#f (not-found request))
  286. (service
  287. (values '((content-type . (text/html (charset . "UTF-8"))))
  288. (call-with-output-string
  289. (lambda (port)
  290. (sxml->xml (value->shtml store (service-value service)
  291. #:limit limit)
  292. port)))))))
  293. (define (render-edge-value request store services source-id target-id)
  294. "Render the value of the edge from SOURCE-ID to TARGET-ID."
  295. (define limit
  296. (or (and=> (request-query-parameter request 'limit) string->number)
  297. 20))
  298. (define (matching-id? id)
  299. (lambda (service)
  300. (string=? (service-node-id service) id)))
  301. (define source
  302. (find (matching-id? source-id) services))
  303. (define target
  304. (find (matching-id? target-id) services))
  305. (if (and source target)
  306. (let* ((extension (find (lambda (extension)
  307. (eq? (service-extension-target extension)
  308. (service-kind target)))
  309. (service-type-extensions
  310. (service-kind source))))
  311. (compute (service-extension-compute extension))
  312. (value (compute (service-value source))))
  313. (values '((content-type . (text/html (charset . "UTF-8"))))
  314. (call-with-output-string
  315. (lambda (port)
  316. (sxml->xml (value->shtml store value #:limit limit)
  317. port)))))
  318. (not-found request)))
  319. (define (render-file request file)
  320. (let* ((file (string-append (dirname (current-filename))
  321. "/" (basename file)))
  322. (mime-type (cond ((string-suffix? ".js" file)
  323. '(text/javascript))
  324. ((string-suffix? ".css" file)
  325. '(text/css))
  326. (else
  327. '(application/octet-stream)))))
  328. (if (file-exists? file)
  329. (values `((content-type . ,mime-type))
  330. (call-with-input-file file
  331. get-bytevector-all))
  332. (not-found request))))
  333. (define (store-file-url file)
  334. "Return a URI reference for FILE, a store file."
  335. (uri->string
  336. (build-uri-reference #:path (string-append "/store" file))))
  337. (define (render-directory directory)
  338. (values '((content-type . (text/html (charset . "UTF-8"))))
  339. (call-with-output-string
  340. (lambda (port)
  341. (sxml->xml
  342. `(html
  343. (head (title "Directory Listing"))
  344. (body
  345. (h1 (tt ,directory))
  346. (ul
  347. ,@(map (lambda (file)
  348. (let ((full (string-append directory "/" file)))
  349. `(li (a (@ (href ,(store-file-url full)))
  350. (tt ,file)))))
  351. (scandir directory
  352. (match-lambda
  353. ((or "." "..") #f)
  354. (_ #t)))))))
  355. port)))))
  356. (define %text-extensions
  357. ;; Extensions of text files.
  358. '("rc" ".txt" ".org" ".scm" ".js" ".conf" ".cnf" "_config"
  359. "motd" ".service" "-mcron-job" ".rules" "fstab"))
  360. (define (render-store-item request file)
  361. "Render FILE, a store item."
  362. (if (and (store-path? file) (file-exists? file))
  363. (if (file-is-directory? file)
  364. (render-directory file)
  365. (let ((mime (if (any (cut string-suffix? <> file)
  366. %text-extensions)
  367. '(text/plain) ;unknown charset?
  368. '(application/octet-stream))))
  369. (values `((content-type . ,mime))
  370. (call-with-input-file file
  371. get-bytevector-all)))) ;FIXME: argh!
  372. ;; TODO: If there's a deriver for FILE, add a "build" button.
  373. (not-found request)))
  374. ;; State of what's currently represented.
  375. (define-record-type <view>
  376. (view user essential initial services previous)
  377. view?
  378. (user view-user-services)
  379. (essential view-essential-services)
  380. (initial view-initial-services)
  381. (services view-services)
  382. (previous view-previous-view))
  383. (define-syntax-rule (thread-state exp state ...)
  384. (call-with-values
  385. (lambda ()
  386. exp)
  387. (lambda (response body . rest)
  388. (apply values response body (append rest (list state ...))))))
  389. (define (compute-folding services root)
  390. "Fold SERVICES to ROOT (a service). Return the updated root along with the
  391. remaining services--i.e., those that have not been folded."
  392. (define updated-root
  393. (fold-services services
  394. #:target-type (service-kind root)))
  395. (define back-edges
  396. (service-back-edges services))
  397. (define dependents
  398. (let loop ((nodes (list root))
  399. (result '()))
  400. (match nodes
  401. (() result)
  402. (nodes (loop (append-map back-edges nodes)
  403. (append nodes result))))))
  404. (values (cons updated-root
  405. ;; FIXME: Remove the edges to ROOT rather than all of
  406. ;; DEPENDENTS.
  407. (remove (lambda (service)
  408. (memq service dependents))
  409. services))
  410. updated-root))
  411. (define (render-folding request view id)
  412. "Respond to REQUEST, which is about folding services to ID."
  413. (define root
  414. (find (lambda (service)
  415. (string=? (service-node-id service) id))
  416. (view-services view)))
  417. (let ((services updated-root (compute-folding (view-services view)
  418. root)))
  419. (values '((content-type . (application/json (charset . "UTF-8"))))
  420. ;; Return the ID of UPDATED-ROOT so it can be highlighted.
  421. (scm->json-string
  422. `((id . ,(service-node-id updated-root))))
  423. (set-fields view
  424. ((view-services) services)
  425. ((view-previous-view) view)))))
  426. (define (render-previous-view request view)
  427. "Respond to REQUEST by restoring the previous view--IOW, \"undoing\" the
  428. latest changes."
  429. (if (view-previous-view view)
  430. (values (build-response #:code 200)
  431. "Undone!"
  432. (view-previous-view view))
  433. (values (build-response #:code 404
  434. #:reason-phrase "Nothing to undo.")
  435. ""
  436. view)))
  437. (define (render-initial-view request view)
  438. "Respond to REQUEST by restoring the initial view."
  439. (values (build-response #:code 200)
  440. "Reset!"
  441. (set-fields view
  442. ((view-services)
  443. (view-initial-services view))
  444. ((view-previous-view)
  445. #f))))
  446. (define (handle-request request body view store)
  447. (define (service-category service)
  448. (cond ((memq service (view-essential-services view))
  449. 'essential)
  450. ((memq service %base-services) 'base)
  451. ((memq service %desktop-services) 'desktop)
  452. (else 'user)))
  453. (define services
  454. (view-services view))
  455. (pk 'req (request-method request)
  456. (uri->string (request-uri request)))
  457. (if (eq? 'GET (request-method request))
  458. (match (request-path-components request)
  459. ((or () ("index.html"))
  460. (thread-state (render-home-page request) view store))
  461. (("static" _ ... file)
  462. (thread-state (render-file request file) view store))
  463. (("store" file ...)
  464. (thread-state (render-store-item request
  465. (string-join file "/" 'prefix))
  466. view store))
  467. (("edges")
  468. (thread-state (render-edges request services)
  469. view store))
  470. (("nodes")
  471. (thread-state (render-nodes request services
  472. #:category service-category)
  473. view store))
  474. (("value" id)
  475. (thread-state (render-node-value request store services id)
  476. view store))
  477. (("edge" source target)
  478. (thread-state (render-edge-value request store
  479. services source target)
  480. view store))
  481. (("fold" id)
  482. (thread-state (render-folding request view id)
  483. store))
  484. (("undo")
  485. (thread-state (render-previous-view request view)
  486. store))
  487. (("reset")
  488. (thread-state (render-initial-view request view)
  489. store))
  490. (("quit")
  491. (throw 'quit 1))
  492. (_
  493. (thread-state (not-found request) view store)))
  494. (thread-state (not-found request) view store)))
  495. (define* (run-explore-server os #:key (port 8080))
  496. (define user-services
  497. (operating-system-user-services os))
  498. (define essential-services
  499. (operating-system-essential-services os))
  500. (define services
  501. (instantiate-missing-services
  502. (append user-services essential-services)))
  503. (info (G_ "Open a browser at ~a and start exploring!~%")
  504. (string-append "http://localhost:" (number->string port)))
  505. (with-store store
  506. (run-server handle-request (lookup-server-impl 'http)
  507. `(#:port ,port)
  508. (view user-services essential-services
  509. services services #f)
  510. store)))
  511. (define (guix-explore args)
  512. (define %user-module ;copied from (guix scripts system)
  513. ;; Module in which the machine description file is loaded.
  514. (make-user-module '((gnu system)
  515. (gnu services)
  516. (gnu system shadow))))
  517. (with-error-handling
  518. (match args
  519. ((_ file)
  520. (run-explore-server (load* file %user-module)))
  521. (_
  522. (leave (G_ "Usage: explore FILE~%"))))))