You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

844 lines
36 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
  3. ;;;
  4. ;;; This file is part of GNU Guix.
  5. ;;;
  6. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  7. ;;; under the terms of the GNU General Public License as published by
  8. ;;; the Free Software Foundation; either version 3 of the License, or (at
  9. ;;; your option) any later version.
  10. ;;;
  11. ;;; GNU Guix is distributed in the hope that it will be useful, but
  12. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  14. ;;; GNU General Public License for more details.
  15. ;;;
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  18. ;; This file contains machinery to build HTML and PDF copies of the manual
  19. ;; that can be readily published on the web site. To do that, run:
  20. ;;
  21. ;; guix build -f build.scm
  22. ;;
  23. ;; The result is a directory hierarchy that can be used as the manual/
  24. ;; sub-directory of the web site.
  25. (use-modules (guix)
  26. (guix gexp)
  27. (guix git)
  28. (guix git-download)
  29. (guix utils)
  30. (git)
  31. (gnu packages base)
  32. (gnu packages gawk)
  33. (gnu packages gettext)
  34. (gnu packages guile)
  35. (gnu packages guile-xyz)
  36. (gnu packages iso-codes)
  37. (gnu packages texinfo)
  38. (gnu packages tex)
  39. (srfi srfi-19)
  40. (srfi srfi-71))
  41. (define file-append*
  42. (@@ (guix self) file-append*))
  43. (define translated-texi-manuals
  44. (@@ (guix self) translate-texi-manuals))
  45. (define info-manual
  46. (@@ (guix self) info-manual))
  47. (define %manual
  48. ;; The manual to build--i.e., the base name of a .texi file, such as "guix"
  49. ;; or "guix-cookbook".
  50. (or (getenv "GUIX_MANUAL")
  51. "guix"))
  52. (define %languages
  53. '("de" "en" "es" "fr" "ru" "zh_CN"))
  54. (define (texinfo-manual-images source)
  55. "Return a directory containing all the images used by the user manual, taken
  56. from SOURCE, the root of the source tree."
  57. (define graphviz
  58. (module-ref (resolve-interface '(gnu packages graphviz))
  59. 'graphviz))
  60. (define images
  61. (file-append* source "doc/images"))
  62. (define build
  63. (with-imported-modules '((guix build utils))
  64. #~(begin
  65. (use-modules (guix build utils)
  66. (srfi srfi-26))
  67. (define (dot->image dot-file format)
  68. (invoke #+(file-append graphviz "/bin/dot")
  69. "-T" format "-Gratio=.9" "-Gnodesep=.005"
  70. "-Granksep=.00005" "-Nfontsize=9"
  71. "-Nheight=.1" "-Nwidth=.1"
  72. "-o" (string-append #$output "/"
  73. (basename dot-file ".dot")
  74. "." format)
  75. dot-file))
  76. ;; Build graphs.
  77. (mkdir-p #$output)
  78. (for-each (lambda (dot-file)
  79. (for-each (cut dot->image dot-file <>)
  80. '("png" "pdf")))
  81. (find-files #$images "\\.dot$"))
  82. ;; Copy other PNGs.
  83. (for-each (lambda (png-file)
  84. (install-file png-file #$output))
  85. (find-files #$images "\\.png$")))))
  86. (computed-file "texinfo-manual-images" build))
  87. (define* (texinfo-manual-source source #:key
  88. (version "0.0")
  89. (languages %languages)
  90. (date 1))
  91. "Gather all the source files of the Texinfo manuals from SOURCE--.texi file
  92. as well as images, OS examples, and translations."
  93. (define documentation
  94. (file-append* source "doc"))
  95. (define examples
  96. (file-append* source "gnu/system/examples"))
  97. (define build
  98. (with-imported-modules '((guix build utils))
  99. #~(begin
  100. (use-modules (guix build utils)
  101. (srfi srfi-19))
  102. (define (make-version-texi language)
  103. ;; Create the 'version.texi' file for LANGUAGE.
  104. (let ((file (if (string=? language "en")
  105. "version.texi"
  106. (string-append "version-" language ".texi"))))
  107. (call-with-output-file (string-append #$output "/" file)
  108. (lambda (port)
  109. (let* ((version #$version)
  110. (time (make-time time-utc 0 #$date))
  111. (date (time-utc->date time)))
  112. (format port "
  113. @set UPDATED ~a
  114. @set UPDATED-MONTH ~a
  115. @set EDITION ~a
  116. @set VERSION ~a\n"
  117. (date->string date "~e ~B ~Y")
  118. (date->string date "~B ~Y")
  119. version version))))))
  120. (install-file #$(file-append* documentation "/htmlxref.cnf")
  121. #$output)
  122. (for-each (lambda (texi)
  123. (install-file texi #$output))
  124. (append (find-files #$documentation "\\.(texi|scm)$")
  125. (find-files #$(translated-texi-manuals source)
  126. "\\.texi$")))
  127. ;; Create 'version.texi'.
  128. (for-each make-version-texi '#$languages)
  129. ;; Copy configuration templates that the manual includes.
  130. (for-each (lambda (template)
  131. (copy-file template
  132. (string-append
  133. #$output "/os-config-"
  134. (basename template ".tmpl")
  135. ".texi")))
  136. (find-files #$examples "\\.tmpl$"))
  137. (symlink #$(texinfo-manual-images source)
  138. (string-append #$output "/images")))))
  139. (computed-file "texinfo-manual-source" build))
  140. (define %web-site-url
  141. ;; URL of the web site home page.
  142. (or (getenv "GUIX_WEB_SITE_URL")
  143. "/software/guix/"))
  144. (define %makeinfo-html-options
  145. ;; Options passed to 'makeinfo --html'.
  146. '("--css-ref=https://www.gnu.org/software/gnulib/manual.css"
  147. "-c" "EXTRA_HEAD=<meta name=\"viewport\" \
  148. content=\"width=device-width, initial-scale=1\" />"))
  149. (define guile-lib/htmlprag-fixed
  150. ;; Guile-Lib with a hotfix for (htmlprag).
  151. (package
  152. (inherit guile-lib)
  153. (source (origin
  154. (inherit (package-source guile-lib))
  155. (modules '(( guix build utils)))
  156. (snippet
  157. '(begin
  158. ;; When parsing
  159. ;; "<body><blockquote><p>foo</p>\n</blockquote></body>",
  160. ;; 'html->shtml' would mistakenly close 'blockquote' right
  161. ;; before <p>. This patch removes 'p' from the
  162. ;; 'parent-constraints' alist to fix that.
  163. (substitute* "src/htmlprag.scm"
  164. (("^[[:blank:]]*\\(p[[:blank:]]+\\. \\(body td th\\)\\).*")
  165. ""))
  166. #t))))
  167. (arguments
  168. (substitute-keyword-arguments (package-arguments guile-lib)
  169. ((#:phases phases '%standard-phases)
  170. `(modify-phases ,phases
  171. (add-before 'check 'skip-known-failure
  172. (lambda _
  173. ;; XXX: The above change causes one test failure among
  174. ;; the htmlprag tests.
  175. (setenv "XFAIL_TESTS" "htmlprag.scm")
  176. #t))))))))
  177. (define* (syntax-highlighted-html input
  178. #:key
  179. (name "highlighted-syntax")
  180. (syntax-css-url
  181. "/static/base/css/code.css"))
  182. "Return a derivation called NAME that processes all the HTML files in INPUT
  183. to (1) add them a link to SYNTAX-CSS-URL, and (2) highlight the syntax of all
  184. its <pre class=\"lisp\"> blocks (as produced by 'makeinfo --html')."
  185. (define build
  186. (with-extensions (list guile-lib/htmlprag-fixed guile-syntax-highlight)
  187. (with-imported-modules '((guix build utils))
  188. #~(begin
  189. (use-modules (htmlprag)
  190. (syntax-highlight)
  191. (syntax-highlight scheme)
  192. (syntax-highlight lexers)
  193. (guix build utils)
  194. (ice-9 match)
  195. (ice-9 threads))
  196. (define (pair-open/close lst)
  197. ;; Pair 'open' and 'close' tags produced by 'highlights' and
  198. ;; produce nested 'paren' tags instead.
  199. (let loop ((lst lst)
  200. (level 0)
  201. (result '()))
  202. (match lst
  203. ((('open open) rest ...)
  204. (call-with-values
  205. (lambda ()
  206. (loop rest (+ 1 level) '()))
  207. (lambda (inner close rest)
  208. (loop rest level
  209. (cons `(paren ,level ,open ,inner ,close)
  210. result)))))
  211. ((('close str) rest ...)
  212. (if (> level 0)
  213. (values (reverse result) str rest)
  214. (begin
  215. (format (current-error-port)
  216. "warning: extra closing paren; context:~% ~y~%"
  217. (reverse result))
  218. (loop rest 0 (cons `(close ,str) result)))))
  219. ((item rest ...)
  220. (loop rest level (cons item result)))
  221. (()
  222. (when (> level 0)
  223. (format (current-error-port)
  224. "warning: missing ~a closing parens; context:~% ~y%"
  225. level (reverse result)))
  226. (values (reverse result) "" '())))))
  227. (define (highlights->sxml* highlights)
  228. ;; Like 'highlights->sxml', but handle nested 'paren tags. This
  229. ;; allows for paren matching highlights via appropriate CSS
  230. ;; "hover" properties.
  231. (define (tag->class tag)
  232. (string-append "syntax-" (symbol->string tag)))
  233. (map (match-lambda
  234. ((? string? str) str)
  235. (('paren level open (body ...) close)
  236. `(span (@ (class ,(string-append "syntax-paren"
  237. (number->string level))))
  238. ,open
  239. (span (@ (class "syntax-symbol"))
  240. ,@(highlights->sxml* body))
  241. ,close))
  242. ((tag text)
  243. `(span (@ (class ,(tag->class tag))) ,text)))
  244. highlights))
  245. (define entity->string
  246. (match-lambda
  247. ("rArr" "⇒")
  248. ("rarr" "→")
  249. ("hellip" "…")
  250. ("rsquo" "’")
  251. (e (pk 'unknown-entity e) (primitive-exit 2))))
  252. (define (concatenate-snippets pieces)
  253. ;; Concatenate PIECES, which contains strings and entities,
  254. ;; replacing entities with their corresponding string.
  255. (let loop ((pieces pieces)
  256. (strings '()))
  257. (match pieces
  258. (()
  259. (string-concatenate-reverse strings))
  260. (((? string? str) . rest)
  261. (loop rest (cons str strings)))
  262. ((('*ENTITY* "additional" entity) . rest)
  263. (loop rest (cons (entity->string entity) strings)))
  264. ((('span _ lst ...) . rest) ;for <span class="roman">
  265. (loop (append lst rest) strings))
  266. (something
  267. (pk 'unsupported-code-snippet something)
  268. (primitive-exit 1)))))
  269. (define (syntax-highlight sxml)
  270. ;; Recurse over SXML and syntax-highlight code snippets.
  271. (match sxml
  272. (('*TOP* decl body ...)
  273. `(*TOP* ,decl ,@(map syntax-highlight body)))
  274. (('head things ...)
  275. `(head ,@things
  276. (link (@ (rel "stylesheet")
  277. (type "text/css")
  278. (href #$syntax-css-url)))))
  279. (('pre ('@ ('class "lisp")) code-snippet ...)
  280. `(pre (@ (class "lisp"))
  281. ,@(highlights->sxml*
  282. (pair-open/close
  283. (highlight lex-scheme
  284. (concatenate-snippets code-snippet))))))
  285. ((tag ('@ attributes ...) body ...)
  286. `(,tag (@ ,@attributes) ,@(map syntax-highlight body)))
  287. ((tag body ...)
  288. `(,tag ,@(map syntax-highlight body)))
  289. ((? string? str)
  290. str)))
  291. (define (process-html file)
  292. ;; Parse FILE and perform syntax highlighting for its Scheme
  293. ;; snippets. Install the result to #$output.
  294. (format (current-error-port) "processing ~a...~%" file)
  295. (let* ((shtml (call-with-input-file file html->shtml))
  296. (highlighted (syntax-highlight shtml))
  297. (base (string-drop file (string-length #$input)))
  298. (target (string-append #$output base)))
  299. (mkdir-p (dirname target))
  300. (call-with-output-file target
  301. (lambda (port)
  302. (write-shtml-as-html highlighted port)))))
  303. (define (copy-as-is file)
  304. ;; Copy FILE as is to #$output.
  305. (let* ((base (string-drop file (string-length #$input)))
  306. (target (string-append #$output base)))
  307. (mkdir-p (dirname target))
  308. (catch 'system-error
  309. (lambda ()
  310. (if (eq? 'symlink (stat:type (lstat file)))
  311. (symlink (readlink file) target)
  312. (link file target)))
  313. (lambda args
  314. (let ((errno (system-error-errno args)))
  315. (pk 'error-link file target (strerror errno))
  316. (primitive-exit 3))))))
  317. ;; Install a UTF-8 locale so we can process UTF-8 files.
  318. (setenv "GUIX_LOCPATH"
  319. #+(file-append glibc-utf8-locales "/lib/locale"))
  320. (setlocale LC_ALL "en_US.utf8")
  321. (n-par-for-each (parallel-job-count)
  322. (lambda (file)
  323. (if (string-suffix? ".html" file)
  324. (process-html file)
  325. (copy-as-is file)))
  326. (find-files #$input))))))
  327. (computed-file name build))
  328. (define* (html-manual source #:key (languages %languages)
  329. (version "0.0")
  330. (manual %manual)
  331. (date 1)
  332. (options %makeinfo-html-options))
  333. "Return the HTML manuals built from SOURCE for all LANGUAGES, with the given
  334. makeinfo OPTIONS."
  335. (define manual-source
  336. (texinfo-manual-source source
  337. #:version version
  338. #:languages languages
  339. #:date date))
  340. (define images
  341. (texinfo-manual-images source))
  342. (define build
  343. (with-imported-modules '((guix build utils))
  344. #~(begin
  345. (use-modules (guix build utils)
  346. (ice-9 match))
  347. (define (normalize language)
  348. ;; Normalize LANGUAGE. For instance, "zh_CN" becomes "zh-cn".
  349. (string-map (match-lambda
  350. (#\_ #\-)
  351. (chr chr))
  352. (string-downcase language)))
  353. (define (language->texi-file-name language)
  354. (if (string=? language "en")
  355. (string-append #$manual-source "/"
  356. #$manual ".texi")
  357. (string-append #$manual-source "/"
  358. #$manual "." language ".texi")))
  359. ;; Install a UTF-8 locale so that 'makeinfo' is at ease.
  360. (setenv "GUIX_LOCPATH"
  361. #+(file-append glibc-utf8-locales "/lib/locale"))
  362. (setenv "LC_ALL" "en_US.utf8")
  363. (setvbuf (current-output-port) 'line)
  364. (setvbuf (current-error-port) 'line)
  365. ;; 'makeinfo' looks for "htmlxref.cnf" in the current directory, so
  366. ;; copy it right here.
  367. (copy-file (string-append #$manual-source "/htmlxref.cnf")
  368. "htmlxref.cnf")
  369. (for-each (lambda (language)
  370. (let* ((texi (language->texi-file-name language))
  371. (opts `("--html"
  372. "-c" ,(string-append "TOP_NODE_UP_URL=/manual/"
  373. language)
  374. #$@options
  375. ,texi)))
  376. (format #t "building HTML manual for language '~a'...~%"
  377. language)
  378. (mkdir-p (string-append #$output "/"
  379. (normalize language)))
  380. (setenv "LANGUAGE" language)
  381. (apply invoke #$(file-append texinfo "/bin/makeinfo")
  382. "-o" (string-append #$output "/"
  383. (normalize language)
  384. "/html_node")
  385. opts)
  386. (apply invoke #$(file-append texinfo "/bin/makeinfo")
  387. "--no-split"
  388. "-o"
  389. (string-append #$output "/"
  390. (normalize language)
  391. "/" #$manual
  392. (if (string=? language "en")
  393. ""
  394. (string-append "." language))
  395. ".html")
  396. opts)
  397. ;; Make sure images are available.
  398. (symlink #$images
  399. (string-append #$output "/" (normalize language)
  400. "/images"))
  401. (symlink #$images
  402. (string-append #$output "/" (normalize language)
  403. "/html_node/images"))))
  404. (filter (compose file-exists? language->texi-file-name)
  405. '#$languages)))))
  406. (let* ((name (string-append manual "-html-manual"))
  407. (manual (computed-file name build)))
  408. (syntax-highlighted-html manual
  409. #:name (string-append name "-highlighted"))))
  410. (define* (pdf-manual source #:key (languages %languages)
  411. (version "0.0")
  412. (manual %manual)
  413. (date 1)
  414. (options '()))
  415. "Return the HTML manuals built from SOURCE for all LANGUAGES, with the given
  416. makeinfo OPTIONS."
  417. (define manual-source
  418. (texinfo-manual-source source
  419. #:version version
  420. #:languages languages
  421. #:date date))
  422. ;; FIXME: This union works, except for the table of contents of non-English
  423. ;; manuals, which contains escape sequences like "^^ca^^fe" instead of
  424. ;; accented letters.
  425. ;;
  426. ;; (define texlive
  427. ;; (texlive-union (list texlive-tex-texinfo
  428. ;; texlive-generic-epsf
  429. ;; texlive-fonts-ec)))
  430. (define build
  431. (with-imported-modules '((guix build utils))
  432. #~(begin
  433. (use-modules (guix build utils)
  434. (srfi srfi-34)
  435. (ice-9 match))
  436. (define (normalize language) ;XXX: deduplicate
  437. ;; Normalize LANGUAGE. For instance, "zh_CN" becomes "zh-cn".
  438. (string-map (match-lambda
  439. (#\_ #\-)
  440. (chr chr))
  441. (string-downcase language)))
  442. ;; Install a UTF-8 locale so that 'makeinfo' is at ease.
  443. (setenv "GUIX_LOCPATH"
  444. #+(file-append glibc-utf8-locales "/lib/locale"))
  445. (setenv "LC_ALL" "en_US.utf8")
  446. (setenv "PATH"
  447. (string-append #+(file-append texlive "/bin") ":"
  448. #+(file-append texinfo "/bin") ":"
  449. ;; Below are command-line tools needed by
  450. ;; 'texi2dvi' and friends.
  451. #+(file-append sed "/bin") ":"
  452. #+(file-append grep "/bin") ":"
  453. #+(file-append coreutils "/bin") ":"
  454. #+(file-append gawk "/bin") ":"
  455. #+(file-append tar "/bin") ":"
  456. #+(file-append diffutils "/bin")))
  457. (setvbuf (current-output-port) 'line)
  458. (setvbuf (current-error-port) 'line)
  459. (setenv "HOME" (getcwd)) ;for kpathsea/mktextfm
  460. ;; 'SOURCE_DATE_EPOCH' is honored by pdftex.
  461. (setenv "SOURCE_DATE_EPOCH" "1")
  462. (for-each (lambda (language)
  463. (let ((opts `("--pdf"
  464. "-I" "."
  465. #$@options
  466. ,(if (string=? language "en")
  467. (string-append #$manual-source "/"
  468. #$manual ".texi")
  469. (string-append #$manual-source "/"
  470. #$manual "." language ".texi")))))
  471. (format #t "building PDF manual for language '~a'...~%"
  472. language)
  473. (mkdir-p (string-append #$output "/"
  474. (normalize language)))
  475. (setenv "LANGUAGE" language)
  476. ;; FIXME: Unfortunately building PDFs for non-Latin
  477. ;; alphabets doesn't work:
  478. ;; <https://lists.gnu.org/archive/html/help-texinfo/2012-01/msg00014.html>.
  479. (guard (c ((invoke-error? c)
  480. (format (current-error-port)
  481. "~%~%Failed to produce \
  482. PDF for language '~a'!~%~%"
  483. language)))
  484. (apply invoke #$(file-append texinfo "/bin/makeinfo")
  485. "--pdf" "-o"
  486. (string-append #$output "/"
  487. (normalize language)
  488. "/" #$manual
  489. (if (string=? language "en")
  490. ""
  491. (string-append "."
  492. language))
  493. ".pdf")
  494. opts))))
  495. '#$languages))))
  496. (computed-file (string-append manual "-pdf-manual") build))
  497. (define (guix-manual-text-domain source languages)
  498. "Return the PO files for LANGUAGES of the 'guix-manual' text domain taken
  499. from SOURCE."
  500. (define po-directory
  501. (file-append* source "/po/doc"))
  502. (define build
  503. (with-imported-modules '((guix build utils))
  504. #~(begin
  505. (use-modules (guix build utils))
  506. (mkdir-p #$output)
  507. (for-each (lambda (language)
  508. (define directory
  509. (string-append #$output "/" language
  510. "/LC_MESSAGES"))
  511. (mkdir-p directory)
  512. (invoke #+(file-append gnu-gettext "/bin/msgfmt")
  513. "-c" "-o"
  514. (string-append directory "/guix-manual.mo")
  515. (string-append #$po-directory "/guix-manual."
  516. language ".po")))
  517. '#$(delete "en" languages)))))
  518. (computed-file "guix-manual-po" build))
  519. (define* (html-manual-indexes source
  520. #:key (languages %languages)
  521. (version "0.0")
  522. (manual %manual)
  523. (title (if (string=? "guix" manual)
  524. "GNU Guix Reference Manual"
  525. "GNU Guix Cookbook"))
  526. (date 1))
  527. (define build
  528. (with-extensions (list guile-json-3)
  529. (with-imported-modules '((guix build utils))
  530. #~(begin
  531. (use-modules (guix build utils)
  532. (json)
  533. (ice-9 match)
  534. (ice-9 popen)
  535. (sxml simple)
  536. (srfi srfi-1)
  537. (srfi srfi-19))
  538. (define (normalize language) ;XXX: deduplicate
  539. ;; Normalize LANGUAGE. For instance, "zh_CN" becomes "zh-cn".
  540. (string-map (match-lambda
  541. (#\_ #\-)
  542. (chr chr))
  543. (string-downcase language)))
  544. (define-syntax-rule (with-language language exp ...)
  545. (let ((lang (getenv "LANGUAGE")))
  546. (dynamic-wind
  547. (lambda ()
  548. (setenv "LANGUAGE" language)
  549. (setlocale LC_MESSAGES))
  550. (lambda () exp ...)
  551. (lambda ()
  552. (if lang
  553. (setenv "LANGUAGE" lang)
  554. (unsetenv "LANGUAGE"))
  555. (setlocale LC_MESSAGES)))))
  556. ;; (put 'with-language 'scheme-indent-function 1)
  557. (define* (translate str language
  558. #:key (domain "guix-manual"))
  559. (define exp
  560. `(begin
  561. (bindtextdomain "guix-manual"
  562. #+(guix-manual-text-domain
  563. source
  564. languages))
  565. (bindtextdomain "iso_639-3" ;language names
  566. #+(file-append iso-codes
  567. "/share/locale"))
  568. (write (gettext ,str ,domain))))
  569. (with-language language
  570. ;; Since the 'gettext' function caches msgid translations,
  571. ;; regardless of $LANGUAGE, we have to spawn a new process each
  572. ;; time we want to translate to a different language. Bah!
  573. (let* ((pipe (open-pipe* OPEN_READ
  574. #+(file-append guile-2.2
  575. "/bin/guile")
  576. "-c" (object->string exp)))
  577. (str (read pipe)))
  578. (close-pipe pipe)
  579. str)))
  580. (define (seconds->string seconds language)
  581. (let* ((time (make-time time-utc 0 seconds))
  582. (date (time-utc->date time)))
  583. (with-language language (date->string date "~e ~B ~Y"))))
  584. (define (guix-url path)
  585. (string-append #$%web-site-url path))
  586. (define (sxml-index language title body)
  587. ;; FIXME: Avoid duplicating styling info from guix-artwork.git.
  588. `(html (@ (lang ,language))
  589. (head
  590. (title ,(string-append title " — GNU Guix"))
  591. (meta (@ (charset "UTF-8")))
  592. (meta (@ (name "viewport") (content "width=device-width, initial-scale=1.0")))
  593. ;; Menu prefetch.
  594. (link (@ (rel "prefetch") (href ,(guix-url "menu/index.html"))))
  595. ;; Base CSS.
  596. (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/elements.css"))))
  597. (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/common.css"))))
  598. (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/messages.css"))))
  599. (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/navbar.css"))))
  600. (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/breadcrumbs.css"))))
  601. (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/buttons.css"))))
  602. (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/footer.css"))))
  603. (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/page.css"))))
  604. (link (@ (rel "stylesheet") (href ,(guix-url "static/base/css/post.css")))))
  605. (body
  606. (header (@ (class "navbar"))
  607. (h1 (a (@ (class "branding")
  608. (href #$%web-site-url)))
  609. (span (@ (class "a11y-offset"))
  610. "Guix"))
  611. (nav (@ (class "menu"))))
  612. (nav (@ (class "breadcrumbs"))
  613. (a (@ (class "crumb")
  614. (href #$%web-site-url))
  615. "Home"))
  616. ,body
  617. (footer))))
  618. (define (language-index language)
  619. (define title
  620. (translate #$title language))
  621. (sxml-index
  622. language title
  623. `(main
  624. (article
  625. (@ (class "page centered-block limit-width"))
  626. (h2 ,title)
  627. (p (@ (class "post-metadata centered-text"))
  628. #$version " — "
  629. ,(seconds->string #$date language))
  630. (div
  631. (ul
  632. (li (a (@ (href "html_node"))
  633. "HTML, with one page per node"))
  634. (li (a (@ (href
  635. ,(string-append
  636. #$manual
  637. (if (string=? language
  638. "en")
  639. ""
  640. (string-append "."
  641. language))
  642. ".html")))
  643. "HTML, entirely on one page"))
  644. ,@(if (member language '("ru" "zh_CN"))
  645. '()
  646. `((li (a (@ (href ,(string-append
  647. #$manual
  648. (if (string=? language "en")
  649. ""
  650. (string-append "."
  651. language))
  652. ".pdf"))))
  653. "PDF")))))))))
  654. (define %iso639-languages
  655. (vector->list
  656. (assoc-ref (call-with-input-file
  657. #+(file-append iso-codes
  658. "/share/iso-codes/json/iso_639-3.json")
  659. json->scm)
  660. "639-3")))
  661. (define (language-code->name code)
  662. "Return the full name of a language from its ISO-639-3 code."
  663. (let ((code (match (string-index code #\_)
  664. (#f code)
  665. (index (string-take code index)))))
  666. (any (lambda (language)
  667. (and (string=? (or (assoc-ref language "alpha_2")
  668. (assoc-ref language "alpha_3"))
  669. code)
  670. (assoc-ref language "name")))
  671. %iso639-languages)))
  672. (define (top-level-index languages)
  673. (define title #$title)
  674. (sxml-index
  675. "en" title
  676. `(main
  677. (article
  678. (@ (class "page centered-block limit-width"))
  679. (h2 ,title)
  680. (div
  681. "This document is available in the following
  682. languages:\n"
  683. (ul
  684. ,@(map (lambda (language)
  685. `(li (a (@ (href ,(normalize language)))
  686. ,(translate
  687. (language-code->name language)
  688. language
  689. #:domain "iso_639-3"))))
  690. languages)))))))
  691. (define (write-html file sxml)
  692. (call-with-output-file file
  693. (lambda (port)
  694. (display "<!DOCTYPE html>\n" port)
  695. (sxml->xml sxml port))))
  696. (setenv "GUIX_LOCPATH"
  697. #+(file-append glibc-utf8-locales "/lib/locale"))
  698. (setenv "LC_ALL" "en_US.utf8")
  699. (setlocale LC_ALL "en_US.utf8")
  700. (for-each (lambda (language)
  701. (define directory
  702. (string-append #$output "/"
  703. (normalize language)))
  704. (mkdir-p directory)
  705. (write-html (string-append directory "/index.html")
  706. (language-index language)))
  707. '#$languages)
  708. (write-html (string-append #$output "/index.html")
  709. (top-level-index '#$languages))))))
  710. (computed-file "html-indexes" build))
  711. (define* (pdf+html-manual source
  712. #:key (languages %languages)
  713. (version "0.0")
  714. (date (time-second (current-time time-utc)))
  715. (manual %manual))
  716. "Return the union of the HTML and PDF manuals, as well as the indexes."
  717. (directory-union (string-append manual "-manual")
  718. (map (lambda (proc)
  719. (proc source
  720. #:date date
  721. #:languages languages
  722. #:version version
  723. #:manual manual))
  724. (list html-manual-indexes
  725. html-manual pdf-manual))
  726. #:copy? #t))
  727. (define (latest-commit+date directory)
  728. "Return two values: the last commit ID (a hex string) for DIRECTORY, and its
  729. commit date (an integer)."
  730. (let* ((repository (repository-open directory))
  731. (head (repository-head repository))
  732. (oid (reference-target head))
  733. (commit (commit-lookup repository oid)))
  734. ;; TODO: Use (git describe) when it's widely available.
  735. (values (oid->string oid) (commit-time commit))))
  736. (let* ((root (canonicalize-path
  737. (string-append (current-source-directory) "/..")))
  738. (commit date (latest-commit+date root)))
  739. (format (current-error-port)
  740. "building manual from work tree around commit ~a, ~a~%"
  741. commit
  742. (let* ((time (make-time time-utc 0 date))
  743. (date (time-utc->date time)))
  744. (date->string date "~e ~B ~Y")))
  745. (pdf+html-manual (local-file root "guix" #:recursive? #t
  746. #:select? (git-predicate root))
  747. #:version (or (getenv "GUIX_MANUAL_VERSION")
  748. (string-take commit 7))
  749. #:date date))