1 files changed, 224 insertions, 0 deletions
diff --git a/apps/base/utils.scm b/apps/base/utils.scm
new file mode 100644
index 0000000..31e18ea
--- /dev/null
+++ b/apps/base/utils.scm
@@ -0,0 +1,224 @@
+;;; 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 <page> 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))))))