;;; Harmonic Flow web site (define-module (apps base utils) #:use-module (apps aux lists) #:use-module (apps aux system) #:use-module (apps base types) #:use-module (apps i18n) #:use-module (haunt artifact) #:use-module (ice-9 i18n) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:export (gnu-url hfweb-url locale-display-name manual-url manual-devel-url manual-url-with-language number* paginate packages-url)) ;;; ;;; Harmonic Flow variables. ;;; (define* (gnu-url #:optional (path "")) "Append PATH to GNU.org URL. PATH (string) An optional relative URL path to a resource. For example: 'software/guile/'. RETURN VALUE (string) A URL. For example: https://gnu.org/software/guile/." (string-append "https://gnu.org/" path)) (define hfweb-root-url-path ;; Path to hfge site: (let ((path (match (getenv "HFGE_WEB_SITE_LOCAL") ;; If we are trying out the website locally, use "/" as the root. ("yes" "/") (else (or (getenv "HFGE_WEB_SITE_ROOT_PATH") "/"))))) (make-parameter path ;; When setting hfweb-root-url-path, make it end in a slash. (lambda (path) (if (string-suffix? "/" path) path (string-append path "/")))))) (define (locale-display-name) "Return the display name of the current locale." ;; TRANSLATORS: The locale’s display name; please include a country ;; code like in English (US) *only* if there are multiple ;; translations for the same language. (let ((str '(G_ "English"))) ;;; XXX: If we ever add a separate English (UK) translation, then ;;; change the display name to English (US), but maybe do not ;;; change str, because it would break translated PO files. (gettext (cadr str)))) ;;; ;;; URL linking. ;;; (define* (hfweb-url #:optional (subpath "") #:key (localize #t)) "Append SUBPATH to Harmonic Flow root URL path (see hfweb-root-url-path). SUBPATH (string) An optional relative URL path to a resource in the Harmonic Flwo path. For example: 'indeed/something-XYZ/'. LOCALIZE (boolean) Whether to prepend the result of 'localized-root-path' to the URL path. RETURN VALUE (string) A URL path. For example: /indeed/something/-XYZ/." (string-append (hfweb-root-url-path) (if localize (localized-root-path subpath) "") subpath)) (define* (manual-url #:optional (subpath "") #:key (language "en")) "Append SUBPATH to the Harmonic Flow manual URL path. SUBPATH (string) An optional relative URL path to a section of the manual. For example: 'SomeFile.html'. RETURN VALUE (string) A URL path. For example: /indeed/SomeFile.html." (string-append (hfweb-url (string-append (string-append "manual/" language "/html_node/") subpath) #:localize #f))) (define* (manual-devel-url #:optional (subpath "") #:key (language "en")) "Similar to 'manual-url', but link to the development manual." (string-append (hfweb-url (string-append (string-append "manual/devel/" language "/html_node/") subpath) #:localize #f))) (define* (manual-url-with-language _ language #:optional (subpath "")) "Shorthand for manual-url without keywords for prettier output PO files when marked for translation. It can be marked for translation as: (G_ (manual-url-with-language (G_ \"en\") (G_ \"Some-section.html\"))) LANGUAGE (string) Normalized language for the Guix manual as produced by 'doc/build.scm' in the Guix source tree, i.e. \"en\" for the English manual. SUBPATH (string) Like manual-url. RETURN VALUE (string) A URL path. For example: /software/guix/manual/en/html_node/System-installation.html." ;; The _ argument is a placeholder for an arg added by G_, cf. i18n-howto.txt. (manual-url subpath #:language language)) ;;; ;;; Helper procedures. ;;; (define (number* number) "Return NUMBER correctly formatting according to English conventions." (number->locale-string number 0 (or (false-if-exception (make-locale LC_ALL "en_US.utf8")) (make-locale LC_ALL "en_US.UTF-8")))) (define* (paginate #:key dataset (limit 30) base-path template (context '()) writer) "Distribute the objects of the DATASET in pages. DATASET (list) A list with any kind of object. LIMIT (integer) The maximum number of objects that should appear in a page. The limit is optional. If not provided, it defaults to 30. BASE-PATH (string) A system path relative to the website directory where all the pages will be written to. For example: 'blog' or 'blog/tags'. In the latter example, pages would be written to files in a path like 'blog/tags/page/PAGE_NUMBER/index.html'. TEMPLATE (procedure) A procedure that accepts a context and returns an SXML tree. CONTEXT (context) A context object as defined in (apps base types). The context holds additional data to insert into the TEMPLATE. The context is optional, and will always be extended to include the following data that can be used in the TEMPLATE: items (list) The list of items to insert into the page. total-pages (integer) The number of pages generated to distribute all items. page-number (integer) The number of the page. WRITER A procedure that writes the page into a given format. See Haunt's 'sxml->html' writer in the (haunt html) module, for example. RETURN VALUE (list) A list of objects as defined in (haunt page) module." (let* ((grouped-data (list-group dataset limit)) (total-pages (cons "total-pages" (length grouped-data)))) ;; Read the following like (cons Page ListOfPages): (cons ;; Page ;; This is the cover of the pages. For example, the resource ;; located in a path such as /blog/, which is identical to the ;; resource available in /blog/page/1/. (let* ((page-number (cons "page-number" 1)) (path (path-join base-path "index.html")) (items (match grouped-data (() (cons "items" '())) ((head _ ...) (cons "items" head)))) (new-context (append context (list items page-number total-pages)))) (serialized-artifact path (template new-context) writer)) ;; ListOfPages ;; This is a list of pages that are the actual ordered pages ;; located in paths such as /blog/page/NUMBER/. (map (lambda (index) (let* ((page-number (cons "page-number" (+ index 1))) (path (path-join base-path "page" (number->string (+ index 1)) "index.html")) (items (cons "items" (list-ref grouped-data index))) (new-context (append context (list items page-number total-pages)))) (serialized-artifact path (template new-context) writer))) (iota (length grouped-data))))))