summaryrefslogtreecommitdiffstats
path: root/apps
diff options
context:
space:
mode:
authorAndreas Widen <andreas@harmonicflow.org>2023-11-25 17:21:37 +0100
committerAndreas Widen <andreas@harmonicflow.org>2023-11-25 17:21:37 +0100
commit1b2b7c3eb939724696894f31ff27db97b0cac84c (patch)
treeefb7b7746a628efb7bb99b2e44c9c2fbfd75b656 /apps
downloadhf-web-1b2b7c3eb939724696894f31ff27db97b0cac84c.tar.xz
hf-web-1b2b7c3eb939724696894f31ff27db97b0cac84c.zip
Initial commit.
Signed-off-by: Andreas Widen <andreas@harmonicflow.org>
Diffstat (limited to 'apps')
-rw-r--r--apps/aux/lists.scm67
-rw-r--r--apps/aux/numbers.scm31
-rw-r--r--apps/aux/strings.scm12
-rw-r--r--apps/aux/sxml.scm23
-rw-r--r--apps/aux/system.scm32
-rw-r--r--apps/aux/web.scm61
-rw-r--r--apps/base/builder.scm95
-rw-r--r--apps/base/templates/about.scm57
-rw-r--r--apps/base/templates/components.scm486
-rw-r--r--apps/base/templates/contact.scm72
-rw-r--r--apps/base/templates/hfge-about.scm52
-rw-r--r--apps/base/templates/hfge-download.scm36
-rw-r--r--apps/base/templates/hfge-git.scm37
-rw-r--r--apps/base/templates/home.scm121
-rw-r--r--apps/base/templates/menu.scm20
-rw-r--r--apps/base/templates/theme.scm143
-rw-r--r--apps/base/types.scm124
-rw-r--r--apps/base/utils.scm224
-rw-r--r--apps/blog/builder.scm154
-rw-r--r--apps/blog/templates/components.scm78
-rw-r--r--apps/blog/templates/feed.scm55
-rw-r--r--apps/blog/templates/post-list.scm56
-rw-r--r--apps/blog/templates/post.scm69
-rw-r--r--apps/blog/templates/tag.scm61
-rw-r--r--apps/blog/utils.scm143
-rw-r--r--apps/i18n.scm110
-rw-r--r--apps/media/builder.scm69
-rw-r--r--apps/media/data.scm59
-rw-r--r--apps/media/templates/components.scm48
-rw-r--r--apps/media/templates/screenshot.scm43
-rw-r--r--apps/media/templates/screenshots-overview.scm28
-rw-r--r--apps/media/types.scm60
32 files changed, 2726 insertions, 0 deletions
diff --git a/apps/aux/lists.scm b/apps/aux/lists.scm
new file mode 100644
index 0000000..634d1e4
--- /dev/null
+++ b/apps/aux/lists.scm
@@ -0,0 +1,67 @@
+;;; Harmonic Flow web site
+
+(define-module (apps aux lists)
+ #:use-module (apps aux numbers)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-27)
+ #:export (list-group
+ list-slice
+ rest
+ separate
+ take-random))
+
+
+(define (list-group los limit)
+ (map (lambda (index)
+ (list-slice los index (+ index limit)))
+ ;; TODO: Use a skip-count procedure instead of iota.
+ (iota (ceiling (/ (length los) limit)) 0 limit)))
+
+
+(define* (list-slice los index-a #:optional (index-b #false))
+ (let ((start index-a)
+ (end (if (or (not index-b) (> index-b (length los)))
+ (- (length los) 1)
+ (- index-b 1))))
+ (map (lambda (index)
+ (list-ref los index))
+ (range index-a end))))
+
+
+(define (rest los)
+ (cond ((<= (length los) 1) (list))
+ (else (list-tail los 1))))
+
+
+(define (separate los separator)
+ "Return a list with the elements of LOS separated by SEPARATOR.
+
+ LOS (list)
+ A list of s-expressions.
+
+ SEPARATOR (s-expression)
+ Any s-expression that will be added between the elements of the
+ given list.
+
+ RETURN VALUE (list)
+ A list of s-expressions."
+ (cond ((or (null? los) (= (length los) 1)) los)
+ (else
+ (cons (first los)
+ (cons separator (separate (rest los) separator))))))
+
+(define (take-random list n)
+ "Return a list containing N different elements from LIST, if
+possible, chosen randomly and evenly distributed. If LIST has less
+than N elements, the result is a permutation of LIST."
+ (let loop ((list list)
+ (n n)
+ (len (length list)))
+ (if (<= (min n len) 0)
+ '()
+ (let ((r (random-integer len)))
+ (cons (list-ref list r)
+ (loop (append (take list r)
+ (drop list (1+ r)))
+ (- len 1)
+ (- n 1)))))))
diff --git a/apps/aux/numbers.scm b/apps/aux/numbers.scm
new file mode 100644
index 0000000..6c83dcb
--- /dev/null
+++ b/apps/aux/numbers.scm
@@ -0,0 +1,31 @@
+;;; Harmonic Flow web site
+
+(define-module (apps aux numbers)
+ #:use-module (srfi srfi-1)
+ #:export (minus-one
+ plus-one
+ range))
+
+
+(define (minus-one n)
+ "Return N-1."
+ (- n 1))
+
+
+(define (plus-one n)
+ "Return N+1."
+ (+ n 1))
+
+
+(define (range a b)
+ "Return the list of integers in the range [A, B].
+
+ A (integer)
+
+ B (integer)
+
+ RETURN VALUE (list of integers)
+ For example, for the range [-2, 3], return
+ (list -2 -1 0 1 2 3)."
+ (cond ((zero? (- a b)) (cons a (list)))
+ (else (cons a (range (plus-one a) b)))))
diff --git a/apps/aux/strings.scm b/apps/aux/strings.scm
new file mode 100644
index 0000000..7004721
--- /dev/null
+++ b/apps/aux/strings.scm
@@ -0,0 +1,12 @@
+;;; Harmonic Flow web site
+
+(define-module (apps aux strings)
+ #:export (string-summarize))
+
+
+(define (string-summarize string n)
+ "Return an extract of N words from the given STRING."
+ (let ((words (string-split string #\space)))
+ (if (<= (length words) n)
+ string
+ (string-join (list-head words n) " "))))
diff --git a/apps/aux/sxml.scm b/apps/aux/sxml.scm
new file mode 100644
index 0000000..531cdee
--- /dev/null
+++ b/apps/aux/sxml.scm
@@ -0,0 +1,23 @@
+;;; Harmonic Flow web site
+
+(define-module (apps aux sxml)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:export (sxml->string*))
+
+
+(define (sxml->string* tree)
+ "Flatten tree by dismissing tags and attributes, and return the resulting
+string."
+ (define (sxml->strings tree)
+ (match tree
+ (((? symbol?) ('@ _ ...) body ...)
+ (append-map sxml->strings `(" " ,@body " ")))
+ (((? symbol?) body ...)
+ (append-map sxml->strings `(" " ,@body " ")))
+ ((? string?)
+ (list tree))
+ ((lst ...)
+ (sxml->strings `(div ,@lst)))))
+
+ (string-concatenate (sxml->strings tree)))
diff --git a/apps/aux/system.scm b/apps/aux/system.scm
new file mode 100644
index 0000000..ee9a5a3
--- /dev/null
+++ b/apps/aux/system.scm
@@ -0,0 +1,32 @@
+;;; Harmonic Flow web site
+
+(define-module (apps aux system)
+ #:export (path-join))
+
+
+;;;
+;;; Procedures.
+;;;
+
+(define (path-join . parts)
+ "Return a system path composed of the given PARTS.
+
+ PARTS (strings)
+ A succession of strings representing parts of a file system path.
+
+ To indicate an absolute path, use an empty string as the first
+ part. For example:
+
+ (path-join '' 'docs' 'manual')
+ => '/docs/manual'
+
+ To end the path with a slash, use an empty string as the last
+ part. For example:
+
+ (path-join '' 'docs' 'manual' '')
+ => '/docs/manual/'
+
+ RETURN VALUE (string)
+ A string representing a file system path."
+ (cond ((equal? parts '("")) "/") ; Root directory
+ (else (string-join parts file-name-separator-string))))
diff --git a/apps/aux/web.scm b/apps/aux/web.scm
new file mode 100644
index 0000000..fec6b4c
--- /dev/null
+++ b/apps/aux/web.scm
@@ -0,0 +1,61 @@
+;;; Harmonic Flow web site
+
+(define-module (apps aux web)
+ #:use-module (srfi srfi-1)
+ #:export (slugify
+ url-path-join))
+
+
+;;;
+;;; Variables.
+;;;
+
+(define char-set:slug
+ (char-set-union char-set:letter+digit (char-set #\-)))
+
+
+
+;;;
+;;; Procedures.
+;;;
+
+(define (slugify text)
+ "Return TEXT as a slug.
+
+ Reserved characters for Internationalized Resource Identifiers
+ (IRIs) and common reserved characters for file names are removed
+ using the SLUG_FORBIDDEN constant as reference.
+
+ TEXT (string)
+ Some text. For example: Biology, Human anatomy.
+
+ RETURN VALUE (string)
+ A slug-like string. For example: biology, human-anatomy."
+ (string-join
+ (map (lambda (s) (string-filter char-set:slug s))
+ (string-split (string-downcase text) char-set:whitespace))
+ "-"))
+
+
+(define (url-path-join . parts)
+ "Return a URL path composed of the given PARTS.
+
+ PARTS (strings)
+ A succession of strings that represent parts of a URL path.
+
+ To indicate an absolute path, use an empty string as the first
+ part. For example:
+
+ (url-path-join '' 'docs' 'manual')
+ => '/docs/manual'
+
+ To end the path with a slash, use an empty string as the last
+ part. For example:
+
+ (url-path-join '' 'docs' 'manual' '')
+ => '/docs/manual/'
+
+ RETURN VALUE (string)
+ A string representing a URL path."
+ (cond ((equal? parts '("")) "/") ; Root directory
+ (else (string-join parts "/"))))
diff --git a/apps/base/builder.scm b/apps/base/builder.scm
new file mode 100644
index 0000000..4e1d194
--- /dev/null
+++ b/apps/base/builder.scm
@@ -0,0 +1,95 @@
+;;; Harmonic Flow web site
+
+(define-module (apps base builder)
+ #:use-module (apps base templates about)
+ #:use-module (apps base templates contact)
+ #:use-module (apps base templates hfge-about)
+ #:use-module (apps base templates hfge-download)
+ #:use-module (apps base templates hfge-git)
+ #:use-module (apps base templates home)
+ #:use-module (apps base templates menu)
+ #:use-module (apps base types)
+ #:use-module (apps blog utils)
+ #:use-module (apps media data)
+ #:use-module (haunt html)
+ #:use-module (haunt artifact)
+ #:use-module (haunt post)
+ #:use-module (haunt utils)
+ #:use-module (srfi srfi-1)
+ #:export (builder))
+
+
+;;;
+;;; Application builder.
+;;;
+
+(define (builder site posts)
+ "Return the list of web resources that compose the app.
+
+ This procedure is a Haunt builder procedure.
+
+ SITE (<site>)
+ A site object that defines all the properties of the website. See
+ Haunt <site> objects for more information.
+
+ POSTS (list of <post>)
+ A list of post objects that represent articles from the blog. See
+ Haunt <post> objects for more information.
+
+ RETURN (list of <page>)
+ A list of page objects that represent the web resources of the
+ application. See Haunt <page> objects for more information."
+ (flatten
+ (list (menu-builder)
+ (home-builder site posts)
+ (about-builder)
+ (contact-builder)
+ (hfge-about-builder)
+ (hfge-download-builder)
+ (hfge-git-builder))))
+
+
+
+;;;
+;;; Helper builders.
+;;;
+
+
+(define (about-builder)
+ "Return a Haunt page representing the About page of the website."
+ (serialized-artifact "about/index.html" (about-t) sxml->html))
+
+
+(define (contact-builder)
+ "Return a Haunt page representing the Contact page of the website."
+ (serialized-artifact "contact/index.html" (contact-t) sxml->html))
+
+
+(define (hfge-about-builder)
+ "Return a Haunt page representing the HFGE about page of the website."
+ (serialized-artifact "hfge-about/index.html" (hfge-about-t) sxml->html))
+
+
+(define (hfge-download-builder)
+ "Return a Haunt page representing the HFGE download page of the website."
+ (serialized-artifact "hfge-download/index.html" (hfge-download-t) sxml->html))
+
+
+(define (hfge-git-builder)
+ "Return a Haunt page representing the HFGE git page of the website."
+ (serialized-artifact "hfge-git/index.html" (hfge-git-t) sxml->html))
+
+
+(define (home-builder site posts)
+ "Return a Haunt page representing the Home page of the website."
+ (let ((context
+ (list
+ (cons "screenshots" screenshots)
+ (cons "posts" (posts/latest posts 3))
+ )))
+ (serialized-artifact "index.html" (home-t context) sxml->html)))
+
+
+(define (menu-builder)
+ "Return a Haunt page representing the website menu."
+ (serialized-artifact "menu/index.html" (menu-t) sxml->html))
diff --git a/apps/base/templates/about.scm b/apps/base/templates/about.scm
new file mode 100644
index 0000000..bb7e91d
--- /dev/null
+++ b/apps/base/templates/about.scm
@@ -0,0 +1,57 @@
+;;; Harmonic Flow web site
+
+(define-module (apps base templates about)
+ #:use-module (apps base templates components)
+ #:use-module (apps base templates theme)
+ #:use-module (apps base types)
+ #:use-module (apps base utils)
+ #:use-module (apps i18n)
+ #:export (about-t))
+
+
+(define (about-t)
+ "Return the About page in SHTML."
+ (theme
+ #:title (C_ "webpage title" '("About the Site |"))
+ #:description
+ (G_ "This website is dedicated to free software primarily in the area of graphics engines but also free software in general.")
+ #:keywords
+ (string-split ;TRANSLATORS: |-separated list of webpage keywords
+ (G_ "About|Harmonic Flow") #\|)
+ #:active-menu-item (C_ "website menu" "About Site")
+ #:css (list
+ (hfweb-url "static/base/css/page.css"))
+ #:crumbs (list (crumb (C_ "website menu" "About Site") "./"))
+ #:content
+ `(main
+ (section
+ (@ (class "page centered-block limit-width"))
+ ,(G_ `(h2 "About the Site"))
+
+ ,(G_
+ `(p
+ "This website is dedicated to free software primarily in the area of
+ graphics engines but also free software in general."
+ ))
+
+ ,(G_
+ `(p
+ "The "
+ ,(G_ `(a (@ (href ,(hfweb-url "blog/"))) " Harmonic Flow Blog"))
+ " will cover any topics that is of interest (mostly related to free
+ software in some way)."
+ ))
+
+ ,(G_
+ `(p
+ "Checkout "
+ ,(G_ `(a (@ (href ,(hfweb-url "hfge-about/"))) " HFGE 3D graphics engine"))
+ " for more information about a brand new cross platform 3D graphics
+ engine currently in development."
+ ))
+
+ ,(G_
+ `(p
+ "Please use the "
+ ,(G_ `(a (@ (href ,(hfweb-url "contact/"))) " contact page"))
+ " for contact information."))))))
diff --git a/apps/base/templates/components.scm b/apps/base/templates/components.scm
new file mode 100644
index 0000000..8d7d521
--- /dev/null
+++ b/apps/base/templates/components.scm
@@ -0,0 +1,486 @@
+;;; Harmonic Flow web site
+
+(define-module (apps base templates components)
+ #:use-module (apps aux lists)
+ #:use-module (apps aux strings)
+ #:use-module (apps aux sxml)
+ #:use-module (apps aux web)
+ #:use-module (apps base types)
+ #:use-module (apps base utils)
+ #:use-module (apps i18n)
+ #:use-module (srfi srfi-1)
+ #:use-module (ice-9 match)
+ #:export (breadcrumbs
+ button-big
+ button-little
+ contact-preview
+ contact->shtml
+ horizontal-line
+ horizontal-separator
+ horizontal-skip
+ link-more
+ link-subtle
+ link-yellow
+ manual-href
+ manual-devel-href
+ manual-link-yellow
+ navbar
+ page-indicator
+ page-selector))
+
+
+;;;
+;;; Components.
+;;;
+
+(define (breadcrumbs crumbs)
+ "Return an SHTML nav element representing the breadcrumbs.
+
+ CRUMBS (list)
+ A non-empty list of <crumb> objects as defined in
+ (apps base types)."
+ `(nav
+ (@ (class "breadcrumbs"))
+ ,(G_ `(h2 (@ (class "a11y-offset")) "Your location:"))
+
+ ,(G_ `(a (@ (class "crumb") (href ,(hfweb-url))) "Home")) (span " → ")
+ ,@(separate (crumbs->shtml crumbs) '(span " → "))))
+
+
+(define (crumbs->shtml crumbs)
+ "Return the list of CRUMBS as list of SHTML a elements.
+
+ CRUMBS (list)
+ A non-empty list of <crumb> objects as defined in
+ (apps base types)."
+ (cond ((= (length crumbs) 1)
+ (cons
+ `(a
+ (@ (class "crumb crumb-active")
+ (href ,(crumb-url (first crumbs))))
+ ,(crumb-label (first crumbs)))
+ '()))
+ (else
+ (cons
+ `(a
+ (@ (class "crumb")
+ (href ,(crumb-url (first crumbs))))
+ ,(crumb-label (first crumbs)))
+ (crumbs->shtml (rest crumbs))))))
+
+
+(define* (button-big #:key (label "Button") (url "#") (light #false))
+ "Return an SHTML a element that looks like a big button.
+
+ LABEL (string)
+ The text for the button. For example: 'Download!'.
+
+ URL (string)
+ A URL to use for the href attribute of the a element. If not
+ specified, the value defaults to #.
+
+ LIGHT (boolean)
+ True if the button is going to be used on a dark background; false
+ otherwise (this is the default)."
+ `(a
+ (@ (class ,(string-append "button-big" (if light " button-light" "")))
+ (href ,url))
+ ,label))
+
+
+(define* (button-little #:key (label "Button") (url "#") (active #false))
+ "Return an SHTML a element that looks like a little button.
+
+ LABEL (string)
+ The text for the button. For example: 'Next'.
+
+ URL (string)
+ A URL to use for the href attribute of the a element. If not
+ specified, the value defaults to #.
+
+ ACTIVE (boolean)
+ True if the button should be highlighted as active (on)."
+ `(a
+ (@ (class ,(string-append "button-little"
+ (if active " button-little-active" "")))
+ (href ,url))
+ ,label))
+
+
+(define (contact-preview contact)
+ "Return an SHTML preview of the given contact object.
+
+ CONTACT (<contact>)
+ A contact object as defined in (apps base types)."
+ `(a
+ (@ (class "item-preview")
+ (href ,(contact-url contact)))
+ (h3 ,(contact-name contact))
+ (p
+ ,(string-summarize
+ (sxml->string*
+ (match (contact-description contact)
+ ((and multilingual (((? string?) (? string?)) ...))
+ (let ((code %current-lang))
+ (match (assoc code multilingual)
+ ((code blurb) blurb)
+ (else (assoc "en" multilingual)))))
+ (blurb
+ blurb)))
+ 30)
+ "…")))
+
+
+(define (language-tag lang)
+ `(span (@ (class "button-little button-little-active")
+ (style "text-align: center; width: 20px; vertical-align: middle"))
+ ,lang))
+
+(define (contact->shtml contact)
+ "Return an SHTML representation of the given contact object.
+
+ CONTACT (<contact>)
+ A contact object as defined in (apps base types)."
+ `(div
+ (@ (class "contact-medium"))
+ (a (@ (href ,(contact-url contact))) (b ,(contact-name contact)))
+ ,(if (string=? (contact-log contact) "")
+ ""
+ `(small
+ " (" ,(G_ `(a (@ (href ,(contact-log contact))) "archive")) ") "))
+
+ ;; The description can be a list of language/blurb pairs.
+ ,(match (contact-description contact)
+ ((((? string? languages) blurbs) ...)
+ `(div (@ (id "help-hfweb-mailing-list-description"))
+ ,@(map (lambda (language blurb)
+ `(div (@ (style "display: flex; align-items: center; margin: 0 10px 10px 0"))
+ ,(language-tag language)
+ (div (@ (lang ,language) (style "flex: 1")) ,blurb)))
+ languages
+ blurbs)))
+ (blurb
+ blurb))))
+
+
+(define* (horizontal-separator #:key (light #false))
+ "Return an SHTML img element that works as a separator.
+
+ LIGHT (boolean)
+ True if the separator is going to be used on a dark background;
+ false otherwise (this is the default)."
+ `(img
+ (@ (class "h-separator")
+ ,(if light
+ `(src ,(hfweb-url "static/base/img/h-separator.png"))
+ `(src ,(hfweb-url "static/base/img/h-separator-dark.png")))
+ (alt ""))))
+
+(define (horizontal-skip)
+ "Return SHTML for a small horizontal space."
+ `(span (@ (class "hskip"))))
+
+(define (horizontal-line)
+ "Return SHTML for a visible separator to be used in a dropdown menu
+like a menu item."
+ `(img (@ (class "hline")
+ (src ,(hfweb-url "static/base/img/h-separator.png"))
+ (alt ""))))
+
+
+(define* (link-more #:key (label "More") (url "#") (light #false))
+ "Return an SHTML a element that looks like a 'more →' link.
+
+ LABEL (string)
+ The text for the link. For example: 'Read the manual'.
+
+ URL (string)
+ A URL to use for the href attribute of the a element. If not
+ specified, the value defaults to #.
+
+ LIGHT (boolean)
+ True if the link is going to be used on a dark background; false
+ otherwise (this is the default)."
+ `(a
+ (@ (class ,(string-append "link-more" (if light " link-more-light" "")))
+ (href ,url))
+ ,label))
+
+
+(define* (link-subtle #:key (label "link") (url "#"))
+ "Return an SHTML a element that does not stand too much on white backgrounds.
+
+ LABEL (string)
+ The text for the link. For example: 'Additional notes'.
+
+ URL (string)
+ The URL of the link. If not specified, the value defaults to #."
+ `(a (@ (class "link-subtle") (href ,url)) ,label))
+
+
+(define* (link-yellow #:key (label "link") (url "#"))
+ "Return a yellow SHTML a element to use on dark backgrounds.
+
+ LABEL (string)
+ The text for the link. For example: 'read the manual'.
+
+ URL (string)
+ The URL of the link. If not specified, the value defaults to #."
+ `(a (@ (class "link-yellow") (href ,url)) ,label))
+
+
+
+
+(define (manual-href label manual-lang _1 subpath _2)
+ "Return an HTML a element with its href attribute pointing to the
+manual. It can be marked for translation as:
+
+ (G_ (manual-href \"some-text\" (G_ \"en\") (G_ \"Some-section.html\")))
+
+ LABEL (string)
+ The content of the a element.
+
+ MANUAL-LANG (string)
+ The 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)
+ The same as in the manual-url procedure."
+ ;; The _ arguments are placeholders for args added by G_, cf. i18n-howto.txt.
+ `(a (@ (href ,(manual-url subpath #:language manual-lang))) ,label))
+
+(define (manual-devel-href label manual-lang _1 subpath _2)
+ "Similar to 'manual-href', but link to the development manual."
+ ;; The _ arguments are placeholders for args added by G_, cf. i18n-howto.txt.
+ `(a (@ (href ,(manual-devel-url subpath #:language manual-lang))) ,label))
+
+(define* (manual-link-yellow label manual-lang _1 #:optional (subpath "") _2)
+ "Return a link-yellow component pointing to the manual. It can be
+used like this:
+
+ (manual-link-yellow \"some-text\" (G_ \"en\") \"Package-Management.html\")
+
+ LABEL (string)
+ The label of the link-yellow.
+
+ MANUAL-LANG (string)
+ The 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)
+ The same as in the manual-url procedure."
+ ;; The _ arguments are placeholders for args added by G_, cf. i18n-howto.txt.
+ (link-yellow
+ #:label label
+ #:url (manual-url subpath #:language manual-lang)))
+
+
+
+
+(define* (menu-dropdown #:key (label "Item") (active-item "") (url "#") (items '()))
+ "Return an SHTML li element representing a dropdown for the navbar.
+
+ LABEL (string)
+ The text for the dropdown. For example: 'About'.
+
+ ACTIVE-ITEM (string)
+ A string representing the label of the current active item in the
+ navigation bar. If the values of LABEL and ACTIVE-ITEM are the
+ same, the dropdown is highlighted.
+
+ URL (string)
+ The URL of the web resource referenced by the dropdown. Any
+ value used for an HTML a element is valid. If not specified, the
+ value defaults to #.
+
+ ITEMS (list of menu items)
+ A list of menu items as returned by the menu-item procedure in this
+ same module. If not provided, the value defaults to an empty list."
+ (let ((label-hash (number->string (string-hash label))))
+ `(li
+ (@ (class ,(if (string=? (string-downcase label)
+ (string-downcase active-item))
+ "menu-item menu-item-active dropdown dropdown-btn"
+ "menu-item dropdown dropdown-btn")))
+ ,@(let ((id (string-append "visible-dropdown-" label-hash)))
+ `(;; show dropdown when button is checked:
+ (style ,(string-append "#" id ":checked ~ #submenu-" label-hash "
+{
+ min-width: 150px;
+ width: max-content;
+
+ /* reset to initial values: */
+ height: auto;
+ overflow: visible;
+}"))
+ ;; show uncheck version of button iff button is checked
+ (style ,(string-append "#" id ":checked \
+~ label[for=all-dropdowns-hidden]
+{
+ display: inline;
+}"))
+ (style "label[for=all-dropdowns-hidden]
+{
+ display: none;
+}")
+ ;; show check version of button iff button is unchecked
+ (style ,(string-append "#" id ":checked ~ label[for=" id "]
+{
+ display: none;
+}"))
+ (input (@ (class "menu-hidden-input")
+ (type "radio")
+ (name "dropdown")
+ (id ,id)))
+ (label
+ (@ (for ,id))
+ ,label)
+ (label
+ (@ (for "all-dropdowns-hidden"))
+ ,label)))
+ (div
+ (@ (class "submenu")
+ (id ,(string-append "submenu-" label-hash)))
+ (div (@ (class "submenu-triangle"))
+ " ")
+ (ul ,@items)))))
+
+
+(define* (menu-item #:key (label "Item") (active-item "") (url "#"))
+ "Return an SHTML li element representing an item for the navbar.
+
+ LABEL (string)
+ The text for the item. For example: 'About'.
+
+ ACTIVE-ITEM (string)
+ A string representing the label of the current active item in the
+ navigation bar. If the values of LABEL and ACTIVE-ITEM are the
+ same, the menu item is highlighted.
+
+ URL (string)
+ The URL of the web resource referenced by the menu item. Any
+ value used for an HTML a element is valid. If not specified, the
+ value defaults to #."
+ `(li
+ (a
+ (@ (class
+ ,(if (string=? (string-downcase label) (string-downcase active-item))
+ "menu-item menu-item-active"
+ "menu-item"))
+ (href ,url))
+ ,label)))
+
+
+(define* (navbar #:key (active-item "About"))
+ "Return an SHTML header element with the given ACTIVE ITEM highlighted."
+ `(header
+ (@ (class "navbar"))
+
+ ;; Branding.
+ (h1
+ (a
+ (@ (class "branding") (href ,(hfweb-url)))
+ ,(C_ "website menu" `(span (@ (class "a11y-offset")) "Harmonic Flow"))))
+
+ ;; Menu.
+ (nav (@ (class "menu"))
+ ,(G_ `(h2 (@ (class "a11y-offset")) "website menu:"))
+ (input (@ (class "menu-hidden-input")
+ (type "radio")
+ (name "dropdown")
+ (id "all-dropdowns-hidden")))
+ (ul
+ ,(C_ "website menu" (menu-item #:label "Overview" #:active-item active-item #:url (hfweb-url)))
+
+ ,(menu-dropdown #:label (C_ "website menu" "HFGE")
+ #:active-item active-item
+ #:items
+ (list
+ (C_ "website menu"
+ (menu-item #:label "About"
+ #:active-item active-item
+ #:url (hfweb-url "hfge-about/")))
+ (C_ "website menu"
+ (menu-item #:label "Download"
+ #:active-item active-item
+ #:url (hfweb-url "hfge-download/")))
+ (C_ "website menu"
+ (menu-item #:label "Git"
+ #:active-item active-item
+ #:url (hfweb-url "hfge-git/")))))
+
+ ,(menu-dropdown #:label (C_ "website menu" "Media")
+ #:active-item active-item
+ #:items
+ (list
+ (C_ "website menu"
+ (menu-item #:label "Screenshots"
+ #:active-item active-item
+ #:url (hfweb-url "screenshots/")))))
+
+ ,(C_ "website menu" (menu-item #:label "Blog" #:active-item active-item #:url (hfweb-url "blog/")))
+
+ ,(menu-dropdown #:label (C_ "website menu" "About") #:active-item active-item
+ #:items
+ (list
+ (C_ "website menu" (menu-item #:label "About Site" #:active-item active-item #:url (hfweb-url "about/")))
+ (horizontal-line)
+ (C_ "website menu" (menu-item #:label "Contact" #:active-item active-item #:url (hfweb-url "contact/")))))
+ ,(horizontal-skip)))
+
+
+ ;; Menu button.
+ (a
+ (@ (class "menu-btn")
+ (href ,(hfweb-url "menu/"))) "")))
+
+(define (page-indicator page-number total-pages)
+ "Return an SHTML span element in the form 'page X of Y' if there is
+ more than one page. Otherwise, return an empty string.
+
+ PAGE-NUMBER (number)
+ The number of the page that the user is seeing.
+
+ TOTAL-PAGES (number)
+ The total number of pages that should be displayed."
+ (if (> total-pages 1)
+ (G_ `(span
+ (@ (class "page-number-indicator"))
+ " (Page " ,(number->string page-number)
+ " of " ,(number->string total-pages) ")"))
+ ""))
+
+
+(define (page-selector pages active-page base-url)
+ "Return an SHTML nav element representing a page selection widget.
+
+ PAGES (number)
+ The total number of pages that should be displayed.
+
+ ACTIVE-PAGE (number)
+ The number of the page that should be displayed as active.
+
+ BASE-URL (string)
+ Absolute URL path to prepend to page numbers. For example:
+ '/en/blog'. This would result in URLs like: '/en/blog/page/N',
+ where N is the number of the page."
+ `(nav
+ (@ (class "page-selector"))
+ (h3
+ (@ (class "a11y-offset"))
+ ,(G_ (string-append "Page " (number->string active-page) " of "
+ (number->string pages) ". Go to another page: ")))
+ ,(if (> pages 1)
+ (map
+ (lambda (page-number)
+ (list
+ (button-little
+ #:label page-number
+ #:url (url-path-join base-url "page"
+ (number->string page-number) "")
+ #:active (= page-number active-page))
+ " ")) ; NOTE: Force space for readability in non-CSS browsers.
+ (iota pages 1))
+ "")))
diff --git a/apps/base/templates/contact.scm b/apps/base/templates/contact.scm
new file mode 100644
index 0000000..88ab2a8
--- /dev/null
+++ b/apps/base/templates/contact.scm
@@ -0,0 +1,72 @@
+;;; Harmonic Flow web site
+
+(define-module (apps base templates contact)
+ #:use-module (apps base templates components)
+ #:use-module (apps base templates theme)
+ #:use-module (apps base types)
+ #:use-module (apps base utils)
+ #:use-module (apps i18n)
+ #:export (contact-t))
+
+
+(define (contact-t)
+ "Return the Contact page in SHTML."
+ (theme
+ #:title (C_ "webpage title" '("Contact |"))
+ #:description
+ (G_ "A list of channels to communicate with Harmonic Flow directly about anything you want.")
+ #:keywords
+ (string-split ;TRANSLATORS: |-separated list of webpage keywords
+ (G_ "Contact|Harmonic Flow") #\|)
+ #:active-menu-item (C_ "website menu" "Contact")
+ #:css (list
+ (hfweb-url "static/base/css/page.css"))
+ #:crumbs (list (crumb (C_ "website menu" "Contact") "./"))
+ #:content
+ `(main
+ (section
+ (@ (class "page centered-block limit-width"))
+ ,(G_ `(h2 "Contact"))
+
+ ,(G_
+ `(p
+ "Contact info email / xmpp: andreas at harmonicflow dot o r g"))
+
+ ,(G_
+ `(p
+ "Please download & import the following "
+ ,(G_ `(a (@ (href ,(hfweb-url "static/gnupg-pubkeys/andreas-pubkey.asc"))) " GPG key"))
+ " if you want to send me encrypted email:"
+ ))
+
+ ,(G_
+ `(pre
+ "gpg --import /path/to/andreas-pubkey.asc"))
+ ,(G_
+ `(p
+ ".. or by using the following command:"
+ ))
+
+ ,(G_
+ `(pre
+ "gpg --recv-keys 0x14121B58362B5F22"))
+
+ ,(G_
+ `(p
+ "The public key fingerprint should be:"))
+
+ ,(G_
+ `(pre
+ "9ECF C528 9712 3654 F76B 63FD 1412 1B58 362B 5F22"))
+
+ ,(G_
+ `(p
+ "For more information about encryption and GnuPG, see: "
+ ,(G_ `(a (@ (href "https://www.gnupg.org"))
+ "GnuPG website."))
+ ))
+
+ ,(G_
+ `(p
+ "The above public key is also used for signing releases."))
+ ))))
diff --git a/apps/base/templates/hfge-about.scm b/apps/base/templates/hfge-about.scm
new file mode 100644
index 0000000..ab0b795
--- /dev/null
+++ b/apps/base/templates/hfge-about.scm
@@ -0,0 +1,52 @@
+;;; Harmonic Flow web site
+
+(define-module (apps base templates hfge-about)
+ #:use-module (apps base templates components)
+ #:use-module (apps base templates theme)
+ #:use-module (apps base types)
+ #:use-module (apps base utils)
+ #:use-module (apps i18n)
+ #:export (hfge-about-t))
+
+
+(define (hfge-about-t)
+ "Return the About HFGE page in SHTML."
+ (theme
+ #:title (C_ "webpage title" '("About HFGE |"))
+ #:description
+ (G_ "HFGE is a cross platform 3D game engine written in C++ and distributed under the zlib license.")
+ #:keywords
+ (string-split ;TRANSLATORS: |-separated list of webpage keywords
+ (G_ "HFGE|Harmonic Flow|Graphics Engine|Game Engine|3D game engine|cross platform|Free Software|C++|Libre software|Graphics Programming|Vulkan|Download") #\|)
+ #:active-menu-item (C_ "website menu" "About")
+ #:css (list
+ (hfweb-url "static/base/css/page.css"))
+ #:crumbs (list (crumb (C_ "website menu" "About HFGE") "./"))
+ #:content
+ `(main
+ (section
+ (@ (class "page centered-block limit-width"))
+ ,(G_ `(h2 "About HFGE"))
+
+ ,(G_
+ `(p
+ "HFGE is a new cross platform 3D engine currently in development. HFGE
+ is written in C++ and will initially support Windows and GNU/Linux
+ platforms. HFGE will use a modern renderer in the form of Vulkan.
+ "))
+
+ ,(G_
+ `(p
+ "HFGE is free / libre software and will be distributed under the zlib
+ license. This license allows you to use HFGE freely in any software.
+ "))
+
+ ,(G_
+ `(p
+ "More information, "
+ ,(G_ `(a (@ (href ,(hfweb-url "hfge-download/"))) " downloads"))
+ " and"
+ ,(G_ `(a (@ (href ,(hfweb-url "hfge-git/"))) " git repoistory"))
+ " will be available once it's ready for public release."
+ ))
+ ))))
diff --git a/apps/base/templates/hfge-download.scm b/apps/base/templates/hfge-download.scm
new file mode 100644
index 0000000..0e91657
--- /dev/null
+++ b/apps/base/templates/hfge-download.scm
@@ -0,0 +1,36 @@
+;;; Harmonic Flow web site
+
+(define-module (apps base templates hfge-download)
+ #:use-module (apps base templates components)
+ #:use-module (apps base templates theme)
+ #:use-module (apps base types)
+ #:use-module (apps base utils)
+ #:use-module (apps i18n)
+ #:export (hfge-download-t))
+
+
+(define (hfge-download-t)
+ "Return the Download HFGE page in SHTML."
+ (theme
+ #:title (C_ "webpage title" '("Download HFGE |"))
+ #:description
+ (G_ "Download the latest version of HFGE. Source code is available.")
+ #:keywords
+ (string-split ;TRANSLATORS: |-separated list of webpage keywords
+ (G_ "Download|HFGE|Source Code") #\|)
+ #:active-menu-item (C_ "website menu" "Download")
+ #:css (list
+ (hfweb-url "static/base/css/page.css"))
+ #:crumbs (list (crumb (C_ "website menu" "Download HFGE") "./"))
+ #:content
+ `(main
+ (section
+ (@ (class "page centered-block limit-width"))
+ ,(G_ `(h2 "Download HFGE"))
+
+ ,(G_
+ `(p
+ "HFGE is a new cross platform 3D engine currently in development. Once
+ HFGE is released you'll be able to download HFGE from here :)
+ "))
+ )))) \ No newline at end of file
diff --git a/apps/base/templates/hfge-git.scm b/apps/base/templates/hfge-git.scm
new file mode 100644
index 0000000..7cc9266
--- /dev/null
+++ b/apps/base/templates/hfge-git.scm
@@ -0,0 +1,37 @@
+;;; Harmonic Flow web site
+
+(define-module (apps base templates hfge-git)
+ #:use-module (apps base templates components)
+ #:use-module (apps base templates theme)
+ #:use-module (apps base types)
+ #:use-module (apps base utils)
+ #:use-module (apps i18n)
+ #:export (hfge-git-t))
+
+
+(define (hfge-git-t)
+ "Return the HFGE git page in SHTML."
+ (theme
+ #:title (C_ "webpage title" '("HFGE git repository |"))
+ #:description
+ (G_ "Get the latest development updates through HFGE git repository.")
+ #:keywords
+ (string-split ;TRANSLATORS: |-separated list of webpage keywords
+ (G_ "Git|Repository|HFGE") #\|)
+ #:active-menu-item (C_ "website menu" "Git")
+ #:css (list
+ (hfweb-url "static/base/css/page.css"))
+ #:crumbs (list (crumb (C_ "website menu" "HFGE Git repository") "./"))
+ #:content
+ `(main
+ (section
+ (@ (class "page centered-block limit-width"))
+ ,(G_ `(h2 "HFGE Git repository"))
+
+ ,(G_
+ `(p
+ "HFGE is a new cross platform 3D engine currently in development. Once
+ HFGE is released you'll be able to get access to the latest
+ development updates through public Git repository from here :)
+ "))
+ )))) \ No newline at end of file
diff --git a/apps/base/templates/home.scm b/apps/base/templates/home.scm
new file mode 100644
index 0000000..464cb0f
--- /dev/null
+++ b/apps/base/templates/home.scm
@@ -0,0 +1,121 @@
+;;; Harmonic Flow web site
+
+(define-module (apps base templates home)
+ #:use-module (apps base templates components)
+ #:use-module (apps base templates theme)
+ #:use-module (apps base types)
+ #:use-module (apps base utils)
+ #:use-module (apps blog templates components)
+ #:use-module (apps media templates components)
+ #:use-module (apps media types)
+ #:use-module (apps i18n)
+ #:export (home-t))
+
+
+(define (home-t context)
+ "Return the Home page in SHTML using the data in CONTEXT."
+ (theme
+ #:title (C_ "webpage title"
+ '("HFGE 3D engine, coding and free software |"))
+ #:description
+ (G_ "This website is dedicated to free software primarily in the area of graphics engines but also free software in general.")
+ #:keywords
+ (string-split ;TRANSLATORS: |-separated list of webpage keywords
+ (G_ "Harmonic Flow|HFGE|Free Software|C++|Libre software|Engine|Game Engine|Graphics|3D|2D|Programming|Vulkan") #\|)
+ #:active-menu-item (C_ "website menu" "Overview")
+ #:css (list
+ (hfweb-url "static/base/css/item-preview.css")
+ (hfweb-url "static/base/css/index.css"))
+ #:content
+ `(main
+ ;; Featured content.
+ (section
+ (@ (class "featured-content"))
+ ,(G_ `(h2 (@ (class "a11y-offset")) "Summary"))
+ (ul
+ ;; Libre:
+ ,(G_
+ `(li
+ ,(G_ `(b "Libre."))
+ ,(G_ (link-yellow
+ #:label " HFGE"
+ #:url (hfweb-url "hfge-about/")))
+ " will be distributed under the zlib license. This license allows you
+ to use HFGE freely in any software (it respects your freedom). "
+ ))
+ ;; Vulkan:
+ ,(G_
+ `(li
+ ,(G_ `(b "Vulkan."))
+ ,(G_ (link-yellow
+ #:label " HFGE"
+ #:url (hfweb-url "hfge-about/")))
+ " comes with a modern, low level, low overhead, cross platform
+ renderer in the form of Vulkan (additional renderers can be added as
+ plugins if needed)."
+ ))
+ ;; Cross platform:
+ ,(G_
+ `(li
+ ,(G_ `(b "Cross platform."))
+ ,(G_ (link-yellow
+ #:label " HFGE"
+ #:url (hfweb-url "hfge-about/")))
+ " will initially support Windows and GNU/Linux. More platforms such
+ as Android will be added later on."
+ ))
+ ;; Tools:
+ ,(G_
+ `(li
+ ,(G_ `(b "Tools."))
+ ,(G_ (link-yellow
+ #:label " HFGE"
+ #:url (hfweb-url "hfge-about/")))
+ " comes with a few useful tools for generating bitmap fonts, texture
+ atlases, resource archives and a hash checksum tool."
+ ))
+ )
+
+ (div
+ (@ (class "action-box centered-text"))
+ ,(button-big
+ #:label (C_ "button" "MORE INFO")
+ #:url (hfweb-url "hfge-about/")
+ #:light #true)
+ " " ; A space for readability in non-CSS browsers.
+ ,(button-big
+ #:label (C_ "button" "DOWNLOAD")
+ #:url (hfweb-url "hfge-download/")
+ #:light #true)))
+
+ ;; Screenshots:
+ (section
+ (@ (class "discovery-box"))
+ ,(G_ `(h2 "Screenshots"))
+
+ ,(G_
+ `(p
+ (@ (class "limit-width centered-block"))
+ "A few early development screenshots of "
+ ,(G_ (link-yellow #:label "HFGE"
+ #:url (hfweb-url "hfge-about/")))
+ " in action."))
+
+ ,(screenshots-box (context-datum context "screenshots"))
+
+ ;;,(horizontal-separator #:light #true)
+ )
+
+ ;; Latest Blog posts:
+ (section
+ (@ (class "centered-text"))
+ ,(G_ `(h2 "Blog"))
+
+ ,@(map post-preview (context-datum context "posts"))
+
+ (div
+ (@ (class "action-box centered-text"))
+ ,(button-big
+ #:label (C_ "button" "ALL POSTS")
+ #:url (hfweb-url "blog/"))))
+ )))
diff --git a/apps/base/templates/menu.scm b/apps/base/templates/menu.scm
new file mode 100644
index 0000000..734ec50
--- /dev/null
+++ b/apps/base/templates/menu.scm
@@ -0,0 +1,20 @@
+;;; Harmonic Flow web site
+
+(define-module (apps base templates menu)
+ #:use-module (apps base templates components)
+ #:use-module (apps base templates theme)
+ #:use-module (apps base utils)
+ #:use-module (apps i18n)
+ #:export (menu-t))
+
+
+(define (menu-t)
+ "Return the Menu page in SHTML."
+ (theme
+ #:title (C_ "webpage title" '("Menu"))
+ #:description (G_ "Website menu.")
+ #:keywords
+ (string-split ;TRANSLATORS: |-separated list of webpage keywords
+ (G_ "Harmonic Flow|HFGE|Free Software|C++|Libre software|Graphics Programming|Vulkan") #\|)
+ #:active-menu-item (C_ "website menu" "Menu")
+ #:css (list (hfweb-url "static/base/css/menu.css"))))
diff --git a/apps/base/templates/theme.scm b/apps/base/templates/theme.scm
new file mode 100644
index 0000000..a944077
--- /dev/null
+++ b/apps/base/templates/theme.scm
@@ -0,0 +1,143 @@
+;;; Harmonic Flow web site
+
+(define-module (apps base templates theme)
+ #:use-module (apps base templates components)
+ #:use-module (apps base utils)
+ #:use-module (apps i18n)
+ #:export (theme))
+
+
+(define* (theme #:key
+ (lang-tag %current-ietf-tag)
+ (title '())
+ (description "")
+ (keywords '())
+ (index? #true)
+ (active-menu-item (C_ "website menu" "About"))
+ (css '())
+ (scripts '())
+ (crumbs '())
+ (content '(div "")))
+ "Return an SHTML document using the website's theme.
+
+ LANG-TAG (string)
+ IETF language tag. This is used to specify the language of the
+ document. For example: en, en-CA. If not provided, the value
+ defaults to the currently built language, i.e. the
+ %current-ietf-tag from (apps i18n).
+
+ TITLE (list)
+ A list of strings to form the value of the title element of the
+ document. The elements of the list are joined together with em
+ dashes as separators between them. For example, a list with two
+ strings like 'Hello', and 'Blog' will result in a title like
+ 'Hello — Blog — Guix'.
+
+ DESCRIPTION (string)
+ The description of the document. This is the value used for the
+ description meta element.
+
+ KEYWORDS (list)
+ A list of keyword strings that will be used as the value for
+ the keywords meta element of the document.
+
+ INDEX? (boolean)
+ Indicate whether the page should be indexed by Internet robots,
+ such as search engine robots. If not provided, it defaults to
+ true.
+
+ ACTIVE-MENU-ITEM (string)
+ The label of the menu item in the navigation bar that should be
+ highlighted to indicate the current section of the website that
+ is being browsed. If not provided, the value defaults to 'About'.
+
+ CSS (list)
+ A list of strings that represent absolute URL paths to additional
+ style sheets. For example: '/static/app/css/style.css'. If not
+ provided, the value defaults to an empty list.
+
+ SCRIPTS (list)
+ A list of strings that represent absolute URL paths to additional
+ script files. For example: '/static/app/js/builds.js'. If not
+ provided, the value defaults to an empty list.
+
+ CRUMBS (list)
+ A list of <crumb> objects as defined in (apps base types). This
+ objects are used to form the breadcrumbs of the website.
+
+ CONTENT (SHTML)
+ A main element with the content of the page. For example:
+ '(main (h2 'Hello World!') (p 'Once upon a time...'))."
+ `((doctype "html")
+
+ (html
+ (@ (lang ,lang-tag))
+
+ (head
+ ,(if (null? title)
+ `(title ,(C_ "webpage title" "Harmonic Flow"))
+ `(title ,(string-join (append title
+ (C_ "webpage title" '("Harmonic Flow"))))))
+ (meta (@ (charset "UTF-8")))
+ (meta (@ (name "keywords") (content ,(string-join keywords ", "))))
+ (meta (@ (name "description") (content ,description)))
+ (meta (@ (name "viewport") (content "width=device-width, initial-scale=1.0")))
+ ;; Info for Internet robots.
+ ,(if index?
+ ""
+ '(meta (@ (name "robots") (content "noindex"))))
+ ;; Menu prefetch.
+ (link (@ (rel "prefetch") (href ,(hfweb-url "menu/index.html"))))
+ ;; Base CSS.
+ (link (@ (rel "stylesheet") (href ,(hfweb-url "static/base/css/elements.css"))))
+ (link (@ (rel "stylesheet") (href ,(hfweb-url "static/base/css/common.css"))))
+ (link (@ (rel "stylesheet") (href ,(hfweb-url "static/base/css/messages.css"))))
+ (link (@ (rel "stylesheet") (href ,(hfweb-url "static/base/css/navbar.css"))))
+ (link (@ (rel "stylesheet") (href ,(hfweb-url "static/base/css/breadcrumbs.css"))))
+ (link (@ (rel "stylesheet") (href ,(hfweb-url "static/base/css/buttons.css"))))
+ (link (@ (rel "stylesheet") (href ,(hfweb-url "static/base/css/footer.css"))))
+ (link (@ (rel "stylesheet") (href ,(hfweb-url "static/base/highlight/styles/stackoverflow-light.min.css"))))
+ ;; Additional CSS.
+ ,@(map (lambda (style-sheet)
+ `(link (@ (rel "stylesheet") (href ,style-sheet))))
+ css)
+ ;; Feeds.
+ (link (@ (type "application/atom+xml") (rel "alternate")
+ (title ,(C_ "webpage title" "Harmonic Flow — Activity Feed"))
+ (href ,(hfweb-url "feeds/blog.atom"))))
+ (link (@ (rel "icon") (type "image/png")
+ (href ,(hfweb-url "static/base/img/icon.png"))))
+ (link (@ (rel "icon") (type "image/svg+xml") (sizes "any")
+ (href ,(hfweb-url "static/base/img/icon.svg"))))
+ ;; Scripts:
+ (script (@ (src ,(hfweb-url"static/base/highlight/highlight.min.js"))))
+ (script (("hljs.highlightAll();")))
+ ;; Additional scripts.
+ ,@(map (lambda (script)
+ `(script (@ (src ,script)) ""))
+ scripts))
+
+ (body
+ ,(navbar #:active-item active-menu-item)
+
+ ,(if (null? crumbs) "" (breadcrumbs crumbs))
+
+ ,content
+ ,(G_
+ `(footer
+ "Powered by "
+ ,(G_ `(a
+ (@ (class "link-yellow")
+ (href ,(gnu-url "software/guile/")))
+ "GNU Guile"))
+ ". Website "
+ ,(G_ `(a
+ (@ (class "link-yellow")
+ (href "https://git.harmonicflow.org/cgi-bin/cgit.cgi/hf-web.git/"))
+ " Source code"))
+ " is licensed the "
+ ,(G_ `(a
+ (@ (class "link-yellow")
+ (href ,(gnu-url "licenses/agpl-3.0.html")))
+ "GNU AGPL"))
+ "."))))))
diff --git a/apps/base/types.scm b/apps/base/types.scm
new file mode 100644
index 0000000..91e9729
--- /dev/null
+++ b/apps/base/types.scm
@@ -0,0 +1,124 @@
+;;; Harmonic Flow web site
+
+(define-module (apps base types)
+ #:use-module (srfi srfi-9)
+ #:export (contact
+ contact?
+ contact-description
+ contact-log
+ contact-name
+ contact-url
+ context-datum
+ crumb
+ crumb?
+ crumb-label
+ crumb-url))
+
+
+;;;
+;;; Data types.
+;;;
+
+;;; Contact (record type)
+;;; ---------------------
+;;;
+;;; A contact object represents a contact medium such as a mailing
+;;; list, IRC channel, email address, etc.
+;;;
+;;; Objects of this type can be created with the "contact"
+;;; procedure as well (see Helper procedures below).
+;;;
+;;; Fields:
+;;;
+;;; name (string)
+;;; The name of the contact medium. For example:
+;;; "Development mailing list".
+;;;
+;;; description (SXML)
+;;; A short description. For example:
+;;; '(p "Discussion about the development of Guix.").
+;;;
+;;; url (string)
+;;; A URL to the main page of the contact medium.
+;;;
+;;; log (string)
+;;; A URL to the archive or log of previous public communications
+;;; help on the contact medium (empty string if there is no log).
+;;;
+(define-record-type <contact>
+ (make-contact name description url log)
+ contact?
+ (name contact-name)
+ (description contact-description)
+ (url contact-url)
+ (log contact-log))
+
+;;; Helper procedures.
+
+(define* (contact #:key (name "") (description "") (url "") (log ""))
+ "Return a <contact> object with the given attributes."
+ (make-contact name description url log))
+
+
+
+;;; Context (association list)
+;;; --------------------------
+;;;
+;;; A context object is a collection of data to be rendered in the
+;;; template of a web resource.
+;;;
+;;; A context can have any number of custom keys depending on the
+;;; requirements of a given template.
+;;;
+;;; The following is an example of a context object to be used with an
+;;; SHTML template:
+;;;
+(define some-context
+ (list
+ (cons "LANGUAGE" "es")
+ (cons "CHARSET" "UTF-8")
+ (cons "AUTHOR" "Jane Roe")
+ (cons "FRIENDS" (list "John Doe" "Nyoro N." "Jack the Lad"))))
+
+;;; Helper procedures.
+
+(define (context-datum context key)
+ "Return the value of KEY in the given CONTEXT.
+
+ CONTEXT (Context)
+ See more information about the Context type in (apps base types).
+
+ KEY (atom)
+ Any atomic value allowed for association list keys."
+ (assoc-ref context key))
+
+
+
+;;; Crumb (record type)
+;;; -------------------
+;;;
+;;; A crumb object represents one of the parts of a breadcrumbs
+;;; component of a website.
+;;;
+;;; Objects of this type can be created with the "crumb" procedure as
+;;; well (see Helper procedures below).
+;;;
+;;; Fields:
+;;;
+;;; label (string)
+;;; A human readable name for the crumb. For example: "Blog".
+;;;
+;;; url (string)
+;;; The URL to the web resource related to the crumb.
+;;;
+(define-record-type <crumb>
+ (make-crumb label url)
+ crumb?
+ (label crumb-label)
+ (url crumb-url))
+
+;;; Helper procedures.
+
+(define (crumb label url)
+ "Return a <crumb> object with the given attributes."
+ (make-crumb label url))
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))))))
diff --git a/apps/blog/builder.scm b/apps/blog/builder.scm
new file mode 100644
index 0000000..969d056
--- /dev/null
+++ b/apps/blog/builder.scm
@@ -0,0 +1,154 @@
+;;; Harmonic Flow web site
+
+(define-module (apps blog builder)
+ #:use-module (apps aux system)
+ #:use-module (apps aux web)
+ #:use-module (apps base utils)
+ #:use-module (apps blog templates feed)
+ #:use-module (apps blog templates post-list)
+ #:use-module (apps blog templates post)
+ #:use-module (apps blog templates tag)
+ #:use-module (apps blog utils)
+ #:use-module (haunt html)
+ #:use-module (haunt artifact)
+ #:use-module (haunt post)
+ #:use-module (haunt site)
+ #:use-module (haunt utils)
+ #:use-module (sxml simple)
+ #:export (builder))
+
+
+;;;
+;;; Application builder.
+;;;
+
+(define (builder site posts)
+ "Return the list of web resources that compose the app.
+
+ This procedure is a Haunt builder procedure.
+
+ SITE (<site>)
+ A site object that defines all the properties of the website. See
+ Haunt <site> objects for more information.
+
+ POSTS (list of <post>)
+ A list of post objects that represent articles from the blog. See
+ Haunt <post> objects for more information.
+
+ RETURN (list of <page>)
+ A list of page objects that represent the web resources of the
+ application. See Haunt <page> objects for more information."
+ (flatten
+ (list
+ (blog-feed-builder site posts)
+ (post-list-builder posts)
+ (posts-builder posts)
+ (tag-feed-builder site posts)
+ (tags-builder posts))))
+
+
+
+;;;
+;;; Helper builders.
+;;;
+
+(define (sxml->xml* sxml port) ;from (haunt builder atom)
+ "Write SXML to PORT, preceded by an <?xml> tag."
+ (set-port-encoding! port "UTF-8")
+ (display "<?xml version=\"1.0\" encoding=\"utf-8\"?>" port)
+ (sxml->xml sxml port))
+
+(define (blog-feed-builder site posts)
+ "Return a Haunt page representing the atom feed of the blog."
+ (let* ((domain (site-domain site))
+ (sorted-posts (posts/reverse-chronological posts))
+ (max-posts 10) ; Number of posts to add to the feed.
+ (context
+ (list
+ (cons "domain" domain)
+ (cons "title" "Harmonic Flow Blog")
+ (cons "id" (url-path-join domain "feeds" "blog.atom"))
+ (cons "alternate" (url-path-join domain "blog" ""))
+ (cons "posts"
+ (if (> (length sorted-posts) max-posts)
+ (list-head sorted-posts max-posts)
+ sorted-posts)))))
+ (serialized-artifact (path-join "feeds" "blog.atom")
+ (atom-feed-t context)
+ sxml->xml*)))
+
+
+(define (post-list-builder posts)
+ "Return a list of Haunt pages representing paginated POSTS."
+ (let ((context
+ (list
+ (cons "tags" (post-groups->tag-list
+ (posts/group-by-tag posts))))))
+ (paginate #:dataset (posts/reverse-chronological posts)
+ #:base-path "blog"
+ #:template post-list-t
+ #:context context
+ #:writer sxml->html)))
+
+
+(define (posts-builder posts)
+ "Return a list of Haunt pages representing blog posts."
+ (map
+ (lambda (post)
+ (let ((context (list (cons "post" post))))
+ (serialized-artifact (path-join (post-url-path post) "index.html")
+ (post-t context)
+ sxml->html)))
+ posts))
+
+
+(define (tag-feed-builder site posts)
+ "Return a Haunt page representing the atom feed of a blog topic."
+ (let ((post-groups (posts/group-by-tag posts)))
+ (map
+ (lambda (tagged-posts)
+ (let* ((domain (site-domain site))
+ (tag-name (car tagged-posts))
+ (tag-slug (slugify tag-name))
+ (file-name (string-append tag-slug ".atom"))
+ (context
+ (list
+ (cons "domain" domain)
+ (cons "title"
+ (string-append "Harmonic Flow Blog — " tag-name))
+ (cons "id" (url-path-join domain
+ "feeds"
+ "blog"
+ file-name))
+ (cons "alternate" (url-path-join domain
+ "blog"
+ "tags"
+ tag-slug
+ ""))
+ (cons "posts"
+ (posts/reverse-chronological (cdr tagged-posts))))))
+ (serialized-artifact (path-join "feeds" "blog" file-name)
+ (atom-feed-t context)
+ sxml->xml)))
+ post-groups)))
+
+
+(define (tags-builder posts)
+ "Return a list of lists of Haunt pages representing POSTS grouped by
+ tag.
+
+ Each list of pages corresponds to the paginated blog posts of one
+ tag."
+ (let ((post-groups (posts/group-by-tag posts)))
+ (map
+ (lambda (tagged-posts)
+ (let ((context
+ (list
+ (cons "tag" (car tagged-posts))
+ (cons "tags" (post-groups->tag-list post-groups)))))
+ (paginate #:dataset (posts/reverse-chronological (cdr tagged-posts))
+ #:base-path (tag-system-path (car tagged-posts))
+ #:template tag-t
+ #:context context
+ #:writer sxml->html)))
+ post-groups)))
diff --git a/apps/blog/templates/components.scm b/apps/blog/templates/components.scm
new file mode 100644
index 0000000..6c49f94
--- /dev/null
+++ b/apps/blog/templates/components.scm
@@ -0,0 +1,78 @@
+;;; Harmonic Flow web site
+
+(define-module (apps blog templates components)
+ #:use-module (apps aux strings)
+ #:use-module (apps aux sxml)
+ #:use-module (apps aux web)
+ #:use-module (apps base utils)
+ #:use-module (apps blog utils)
+ #:use-module (apps i18n)
+ #:use-module (haunt post)
+ #:use-module (srfi srfi-19)
+ #:export (post-preview
+ sidebar))
+
+
+;;;
+;;; Components.
+;;;
+
+(define (post-preview post)
+ "Return an SHTML representation of the given post object.
+
+ POST (<post>)
+ A post object (see Haunt's manual for more information)."
+ `(a
+ (@ (class "item-preview")
+ (href ,(hfweb-url (post-url-path post))))
+ (h3
+ (@ (lang "en"))
+ ,(post-ref post 'title))
+ (p
+ (@ (class "item-date"))
+ ,(date->string (post-date post) (C_ "SRFI-19 date->string format"
+ "~B ~e, ~Y")))
+ (p
+ (@ (class "item-summary") (lang "en"))
+ ,(string-summarize (sxml->string* (post-sxml post)) 30)
+ ,(C_ "blog post summary ellipsis" "…"))))
+
+
+(define* (sidebar tags #:optional (current-tag #false))
+ "Return an SHTML section element representing the sidebar of the blog.
+
+ TAGS (association list)
+ An association list of tags mapped to blog posts as returned by
+ Haunt's 'posts/group-by-tag' procedure in (haunt post) module."
+ `(section
+ (@ (class "side-bar"))
+ (h3 (@ (class "a11y-offset")) (G_ "Blog menu: "))
+
+ (h4
+ (@ (class "bar-title bar-title-top"))
+ ,(if current-tag
+ (G_ "Get topic updates")
+ (G_ "Get blog updates")))
+ (ul
+ (@ (class "bar-list"))
+ (li (@ (class "bar-item"))
+ (a (@ (class "bar-link feed-link")
+ ,(if current-tag
+ `(href ,(hfweb-url
+ (url-path-join "feeds" "blog"
+ (string-append
+ (slugify current-tag)
+ ".atom"))))
+ `(href ,(hfweb-url (url-path-join "feeds" "blog.atom")))))
+ ,(C_ "button" "Atom feed"))))
+
+ (h4 (@ (class "bar-title")) (G_ "Posts by topic"))
+ (ul
+ (@ (class "bar-list"))
+ ,@(map
+ (lambda (tag)
+ `(li (@ (class "bar-item"))
+ (a (@ (class "bar-link")
+ (href ,(hfweb-url (url-path-join (tag-url-path tag) ""))))
+ ,tag)))
+ (sort tags tag-first?)))))
diff --git a/apps/blog/templates/feed.scm b/apps/blog/templates/feed.scm
new file mode 100644
index 0000000..bfa1cc4
--- /dev/null
+++ b/apps/blog/templates/feed.scm
@@ -0,0 +1,55 @@
+;;; Harmonic Flow web site
+
+(define-module (apps blog templates feed)
+ #:use-module (apps aux strings)
+ #:use-module (apps aux sxml)
+ #:use-module (apps aux web)
+ #:use-module (apps base templates theme)
+ #:use-module (apps base types)
+ #:use-module (apps base utils)
+ #:use-module (apps blog utils)
+ #:use-module (apps i18n)
+ #:use-module (haunt html)
+ #:use-module (haunt post)
+ #:use-module (srfi srfi-19)
+ #:export (atom-feed-t))
+
+
+(define (atom-feed-t context)
+ "Return an SXML representation of a Blog's topic atom feed."
+ (let ((domain (context-datum context "domain"))
+ (title (context-datum context "title"))
+ (id (context-datum context "id"))
+ (alternate (context-datum context "alternate"))
+ (posts (context-datum context "posts")))
+ `(feed
+ ;; Feed info.
+ (@ (xmlns "http://www.w3.org/2005/Atom"))
+ (id ,id)
+ (title ,title)
+ (author (name (C_ "feed author name" "Harmonic Flow Blog")) (uri ,domain))
+ (icon ,(hfweb-url "static/base/img/icon.png"))
+ (updated ,(date->string (current-date) "~4"))
+ (link (@ (rel "alternate") (href ,alternate)))
+
+ ;; Feed entries.
+ ,@(map
+ (lambda (post)
+ `(entry
+ (id ,(url-path-join domain (post-url-path post) ""))
+ (title ,(post-ref post 'title))
+ (author (name ,(post-ref post 'author)))
+ (published ,(date->string (post-date post) "~4"))
+ (updated ,(date->string (post-date post) "~4"))
+ ;(rights (@ (type "text")) ,(post-copyright post))
+ (link (@ (rel "alternate")
+ (href ,(url-path-join domain
+ (post-url-path post)
+ ""))))
+ ,@(map
+ (lambda (tag)
+ `(category (@ (term ,tag))))
+ (post-ref post 'tags))
+ (summary ,(string-summarize (sxml->string* (post-sxml post)) 100) "…")
+ (content (@ (type "html")) ,(sxml->html-string (post-sxml post)))))
+ posts))))
diff --git a/apps/blog/templates/post-list.scm b/apps/blog/templates/post-list.scm
new file mode 100644
index 0000000..c63b01a
--- /dev/null
+++ b/apps/blog/templates/post-list.scm
@@ -0,0 +1,56 @@
+;;; Harmonic Flow web site
+
+(define-module (apps blog templates post-list)
+ #:use-module (apps aux web)
+ #:use-module (apps base templates components)
+ #:use-module (apps base templates theme)
+ #:use-module (apps base types)
+ #:use-module (apps base utils)
+ #:use-module ((apps blog templates components) #:prefix blog:)
+ #:use-module (apps i18n)
+ #:export (post-list-t))
+
+
+(define (post-list-t context)
+ "Return a list of blog posts in SHTML with the data in CONTEXT."
+ (let ((page-number
+ (number->string (context-datum context "page-number")))
+ (total-pages
+ (number->string (context-datum context "total-pages"))))
+ (theme
+ #:title (list (G_ (string-append "Page " page-number ""))
+ (C_ "webpage title" "Blog |"))
+ #:description
+ (G_ "Blog posts about programming and free software.")
+ #:keywords
+ (string-split ;TRANSLATORS: |-separated list of webpage keywords
+ (G_ "Harmonic Flow Blog|HFGE|Free Software|C++|Libre software|Graphics Programming|Vulkan") #\|)
+ #:index? #false
+ #:active-menu-item (C_ "website menu" "Blog")
+ #:css
+ (list (hfweb-url "static/base/css/page.css")
+ (hfweb-url "static/base/css/item-preview.css")
+ (hfweb-url "static/base/css/sidebar.css"))
+ #:crumbs
+ (list (crumb (C_ "website menu" "Blog") (hfweb-url "blog/"))
+ (crumb (G_ (string-append "Page " page-number ""))
+ (hfweb-url (url-path-join "blog"
+ "page"
+ page-number
+ ""))))
+ #:content
+ `(main
+ (section
+ (@ (class "page centered-text"))
+ (h2 (G_ "Blog")
+ ,(page-indicator (string->number page-number)
+ (string->number total-pages)))
+
+ (div
+ (@ (class "sheet"))
+ ,@(map blog:post-preview (context-datum context "items"))
+ ,(page-selector (string->number total-pages)
+ (string->number page-number)
+ (hfweb-url "blog")))
+
+ ,(blog:sidebar (context-datum context "tags")))))))
diff --git a/apps/blog/templates/post.scm b/apps/blog/templates/post.scm
new file mode 100644
index 0000000..8a4880d
--- /dev/null
+++ b/apps/blog/templates/post.scm
@@ -0,0 +1,69 @@
+;;; Harmonic Flow web site
+
+(define-module (apps blog templates post)
+ #:use-module (apps base templates components)
+ #:use-module (apps base templates theme)
+ #:use-module (apps base types)
+ #:use-module (apps base utils)
+ #:use-module (apps blog utils)
+ #:use-module ((apps blog templates components) #:prefix blog:)
+ #:use-module (apps i18n)
+ #:use-module (haunt post)
+ #:use-module (srfi srfi-19)
+ #:export (post-t))
+
+
+(define (post-t context)
+ "Return a page in SHTML for the post in the given CONTEXT."
+ (let* ((post (context-datum context "post"))
+ (tags (post-ref post 'tags)))
+ (theme
+ #:title (list (post-ref post 'title)
+ (C_ "webpage title" "|"))
+ #:description
+ (G_ (string-append "Blog post about "
+ (post-ref post 'title)
+ " on Harmonic Flow Blog."))
+ #:keywords tags
+ #:active-menu-item (C_ "website menu" "Blog")
+ #:css
+ (list (hfweb-url "static/base/css/page.css")
+ (hfweb-url "static/blog/css/post.css"))
+ #:crumbs
+ (list (crumb (C_ "website menu" "Blog") (hfweb-url "blog/"))
+ (crumb (post-ref post 'title)
+ (hfweb-url (post-url-path post))))
+ #:content
+ `(main
+ (article
+ (@ (class "page centered-block limit-width") (lang "en"))
+ (h2 ,(post-ref post 'title))
+ (p
+ (@ (class "post-metadata centered-text") (lang ,%current-ietf-tag))
+ ,(post-ref post 'author) " — "
+ ,(date->string (post-date post) (C_ "SRFI-19 date->string format"
+ "~B ~e, ~Y")))
+
+ ,(change-image-to-video
+ (syntax-highlight (post-sxml post)))
+
+ (div
+ (@ (class "tag-list") (lang ,%current-ietf-tag))
+ ,(G_ `(p "Related topics:"))
+
+ ,@(map
+ (lambda (tag)
+ (list
+ (button-little
+ #:label tag
+ #:url (hfweb-url (tag-url-path tag)))
+ " ")) ; NOTE: Force space for readability in non-CSS browsers.
+ (sort tags tag-first?)))
+
+ (div
+ (@ (class "license") (lang ,%current-ietf-tag))
+ ,(G_ `(p "Unless otherwise stated, blog posts on this site are
+ copyrighted by their respective authors and published under the terms of the "
+ ,(G_
+ `(a (@ (href "https://creativecommons.org/licenses/by-sa/4.0/"))
+ "CC-BY-SA 4.0 license."))))))))))
diff --git a/apps/blog/templates/tag.scm b/apps/blog/templates/tag.scm
new file mode 100644
index 0000000..865f27a
--- /dev/null
+++ b/apps/blog/templates/tag.scm
@@ -0,0 +1,61 @@
+;;; Harmonic Flow web site
+
+(define-module (apps blog templates tag)
+ #:use-module (apps aux web)
+ #:use-module (apps base templates components)
+ #:use-module (apps base templates theme)
+ #:use-module (apps base types)
+ #:use-module (apps base utils)
+ #:use-module ((apps blog templates components) #:prefix blog:)
+ #:use-module (apps blog utils)
+ #:use-module (apps i18n)
+ #:export (tag-t))
+
+
+(define (tag-t context)
+ "Return a list of blog posts in SHTML with the data in CONTEXT."
+ (let ((tag (context-datum context "tag"))
+ (page-number
+ (number->string (context-datum context "page-number")))
+ (total-pages
+ (number->string (context-datum context "total-pages"))))
+ (theme
+ #:title (list (G_ (string-append "Page " page-number ""))
+ tag (C_ "webpage title" "Blog"))
+ #:description
+ (G_ (string-append "Blog posts about "
+ tag
+ " on Harmonic Flow Blog."))
+ #:keywords
+ (string-split ;TRANSLATORS: |-separated list of webpage keywords
+ (G_ "Harmonic Flow Blog|HFGE|Free Software|C++|Libre software|Graphics Programming|Vulkan") #\|)
+ #:index? #false
+ #:active-menu-item (C_ "website menu" "Blog")
+ #:css
+ (list (hfweb-url "static/base/css/page.css")
+ (hfweb-url "static/base/css/item-preview.css")
+ (hfweb-url "static/base/css/sidebar.css"))
+ #:crumbs
+ (list (crumb (C_ "website menu" "Blog") (hfweb-url "blog/"))
+ (crumb tag (hfweb-url (tag-url-path tag)))
+ (crumb (G_ (string-append "Page " page-number ""))
+ (hfweb-url (url-path-join (tag-url-path tag)
+ "page"
+ page-number
+ ""))))
+ #:content
+ `(main
+ (section
+ (@ (class "page centered-text"))
+ (h2 ,(G_ "Blog — ") ,tag
+ ,(page-indicator (string->number page-number)
+ (string->number total-pages)))
+
+ (div
+ (@ (class "sheet"))
+ ,@(map blog:post-preview (context-datum context "items"))
+ ,(page-selector (string->number total-pages)
+ (string->number page-number)
+ (hfweb-url "blog")))
+
+ ,(blog:sidebar (context-datum context "tags") tag))))))
diff --git a/apps/blog/utils.scm b/apps/blog/utils.scm
new file mode 100644
index 0000000..6a3c4b2
--- /dev/null
+++ b/apps/blog/utils.scm
@@ -0,0 +1,143 @@
+;;; Harmonic Flow web site
+
+(define-module (apps blog utils)
+ #:use-module (apps aux lists)
+ #:use-module (apps aux web)
+ #:use-module (apps i18n)
+ #:use-module (haunt post)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-19)
+ #:use-module (syntax-highlight)
+ #:use-module (syntax-highlight scheme)
+ #:use-module (syntax-highlight lexers)
+ #:export (post-groups->tag-list
+ post-url-path
+ posts/latest
+ syntax-highlight
+ change-image-to-video
+ tag-first?
+ tag-system-path
+ tag-url-path))
+
+
+(define (post-groups->tag-list groups)
+ "Return a list of Haunt tags from the list of grouped posts.
+
+ GROUPS (association list)
+ An association list of tags mapped to posts, as returned by the
+ posts/group-by-tag procedure from (haunt post) module."
+ (cond ((null? groups) '())
+ (else
+ (cons (car (first groups))
+ (post-groups->tag-list (rest groups))))))
+
+
+(define (post-url-path post)
+ "Return a URL path for the POST in the form blog/YYYY/POST-SLUG.
+
+ POST (<post>)
+ A post object as defined in (haunt post) module."
+ ;; Note: End the path with a slash so 'localized-root-path' down the road
+ ;; prepends the language tag.
+ (url-path-join "blog"
+ (date->string (post-date post) "~Y")
+ (post-slug post)
+ ""))
+
+
+(define (posts/latest posts n)
+ "Return the latest N posts from the given list of posts."
+ (let ((latest-posts (posts/reverse-chronological posts)))
+ (cond
+ ((null? posts) '())
+ ((<= (length posts) n) latest-posts)
+ (else (list-head latest-posts n)))))
+
+
+(define (tag-first? tag-a tag-b)
+ "Return true if TAG-A goes first than TAG-B alphabetically.
+
+ This predicate is used for sorting tags.
+
+ TAG-A, TAG-B (string)
+ A tag as used by Haunt posts. For example: 'User interface'."
+ (string<? (string-downcase tag-a) (string-downcase tag-b)))
+
+
+(define (tag-system-path tag)
+ "Return a system path for the TAG in the form blog/tags/TAG-SLUG.
+
+ The path is relative to the website directory.
+
+ TAG (string)
+ A tag as used by Haunt posts. For example: 'Scheme API'."
+ (string-append "blog/tags/" (slugify tag)))
+
+
+(define (tag-url-path tag)
+ "Return a URL path for the TAG in the form blog/tags/TAG-SLUG.
+
+ TAG (string)
+ A tag as used by Haunt posts. For example: 'Scheme API'."
+ ;; Note: End the path with a slash so 'localized-root-path' down the road
+ ;; prepends the language tag.
+ (url-path-join "blog" "tags" (slugify tag) ""))
+
+
+
+;;;
+;;; Syntax highlighting.
+;;;
+
+(define %default-special-prefixes
+ '("define" "syntax"))
+
+(define lex-scheme/guix
+ ;; Specialized lexer for the Scheme we use in Guix.
+ ;; TODO: Add #~, #$, etc.
+ (make-scheme-lexer (cons* "with-imported-modules"
+ "gexp" "ungexp"
+ "ungexp-native" "ungexp-splicing"
+ "ungexp-native-splicing"
+ "mlet" "mlet*"
+ "match"
+ %default-special-symbols)
+ %default-special-prefixes))
+
+(define (syntax-highlight sxml)
+ "Recurse over SXML and syntax-highlight code snippets."
+ (match sxml
+ ;; sceheme:
+ ;;(('code ('@ ('class "language-scheme")) code-snippet)
+ ;; `(code ,(highlights->sxml
+ ;; (highlight lex-scheme/guix code-snippet))))
+ ((tag ('@ attributes ...) body ...)
+ `(,tag (@ ,@attributes) ,@(map syntax-highlight body)))
+ ((tag body ...)
+ `(,tag ,@(map syntax-highlight body)))
+ ((? string? str)
+ str)))
+
+(define (change-image-to-video sxml)
+ "Replace <img> tags in SXML that refer to WebM videos with proper <video>
+tags. This hack allows one to refer to a video from a Markdown document."
+ (match sxml
+ (('img ('@ attributes ...) body ...)
+ (let ((src (match (assoc 'src attributes)
+ ((_ url) url)))
+ (alt (match (assoc 'alt attributes)
+ ((_ text) text))))
+ (if (string-suffix? ".webm" src)
+ `(video (@ (src ,src)
+ (poster ,(string-append src ".poster.png"))
+ (controls "controls"))
+ (p ,(G_ `(a (@ (href ,src) (class "link-subtle"))
+ "Download video."))))
+ sxml)))
+ ((tag ('@ attributes ...) body ...)
+ `(,tag (@ ,@attributes) ,@(map change-image-to-video body)))
+ ((tag body ...)
+ `(,tag ,@(map change-image-to-video body)))
+ ((? string? str)
+ str)))
diff --git a/apps/i18n.scm b/apps/i18n.scm
new file mode 100644
index 0000000..86bf350
--- /dev/null
+++ b/apps/i18n.scm
@@ -0,0 +1,110 @@
+;;; Harmonic Flow web site
+
+(define-module (apps i18n)
+ #:use-module (haunt asset)
+ #:use-module (haunt artifact)
+ #:use-module (haunt utils)
+ #:use-module ((guix i18n) #:select (%package-text-domain))
+ #:use-module (ice-9 match)
+ #:use-module (sexp-xgettext)
+ #:use-module (srfi srfi-1)
+ #:export (G_
+ N_
+ C_
+ NC_
+ %current-ietf-tag
+ %current-lang
+ %current-lingua
+ builder->localized-builder
+ builders->localized-builders
+ ietf-tags-file-contents
+ localized-root-path))
+
+(define %gettext-domain
+ "guix-website")
+
+(bindtextdomain %gettext-domain (getcwd))
+(bind-textdomain-codeset %gettext-domain "UTF-8")
+(textdomain %gettext-domain)
+(bindtextdomain %package-text-domain (getcwd))
+(bind-textdomain-codeset %package-text-domain "UTF-8")
+
+;; NOTE: The sgettext macros have no hygiene because they use
+;; datum->syntax and do not preserve the semantics of anything looking
+;; like an sgettext macro. This is an exceptional use case; do not
+;; try this at home.
+
+(define-syntax G_
+ sgettext)
+
+(set-simple-keywords! '(G_))
+
+(define-syntax N_ ;like ngettext
+ sngettext)
+
+(define-syntax C_ ;like pgettext
+ spgettext)
+
+(define-syntax NC_ ;like npgettext
+ snpgettext)
+
+(set-complex-keywords! '(N_ C_ NC_))
+
+(define %current-lingua
+ ;; strip the character encoding:
+ (car (string-split (setlocale LC_ALL) #\.)))
+
+(define-syntax ietf-tags-file-contents
+ (identifier-syntax
+ (force (delay (call-with-input-file
+ "po/ietf-tags.scm"
+ (lambda (port) (read port)))))))
+
+
+(define %current-ietf-tag
+ (or (assoc-ref ietf-tags-file-contents %current-lingua)
+ "en"))
+
+(define %current-lang
+ (car (string-split %current-ietf-tag #\-)))
+
+(define* (localized-root-path url #:key (lingua %current-ietf-tag))
+ "Given a URL as used in a href attribute, return the URL prefix
+'builder->localized-builder' would use for the URL when called with
+LINGUA."
+ (if (or (string-suffix? ".html" url)
+ (string-suffix? "/" url))
+ (string-append lingua "/")
+ ""))
+
+(define (first-value arg)
+ "For some reason the builder returned by static-directory returns
+multiple values. This procedure is used to retain only the first
+return value. TODO: This should not be necessary."
+ arg)
+
+(define (builder->localized-builder builder)
+ "Return a Haunt builder procedure generated from an existing BUILDER
+with translations for the current system locale coming from
+sexp-xgettext."
+ (compose
+ (lambda (pages-and-assets)
+ (map (match-lambda
+ ((? artifact? artifact) ;Haunt >= 0.2.5
+ (let ((new-name (string-append
+ (localized-root-path (artifact-file-name artifact))
+ (artifact-file-name artifact))))
+ (make-artifact new-name
+ (artifact-writer artifact)))))
+ pages-and-assets))
+ (lambda (site posts)
+ (first-value (builder site posts)))))
+
+(define (builders->localized-builders builders)
+ "Return a list of new Haunt builder procedures generated from
+BUILDERS and localized via sexp-xgettext for the current system
+locale."
+ (flatten
+ (map-in-order
+ builder->localized-builder
+ builders)))
diff --git a/apps/media/builder.scm b/apps/media/builder.scm
new file mode 100644
index 0000000..a1a74a1
--- /dev/null
+++ b/apps/media/builder.scm
@@ -0,0 +1,69 @@
+;;; Harmonic Flow web site
+
+(define-module (apps media builder)
+ #:use-module (apps aux system)
+ #:use-module (apps base utils)
+ #:use-module (apps media data)
+ #:use-module (apps media templates screenshot)
+ #:use-module (apps media templates screenshots-overview)
+ #:use-module (apps media types)
+ #:use-module (haunt artifact)
+ #:use-module (haunt html)
+ #:use-module (haunt utils)
+ #:use-module (apps aux web)
+ #:use-module (srfi srfi-19)
+ #:export (builder))
+
+
+;;;
+;;; Application builder.
+;;;
+
+(define (builder site posts)
+ "Return the list of web resources that compose the app.
+
+ This procedure is a Haunt builder procedure.
+
+ SITE (<site>)
+ A site object that defines all the properties of the website. See
+ Haunt <site> objects for more information.
+
+ POSTS (list of <post>)
+ A list of post objects that represent articles from the blog. See
+ Haunt <post> objects for more information.
+
+ RETURN (list of <artifact> and <page>)
+ A list of objects that represent the web resources of the
+ application. See Haunt <artifact> and <page> objects for more
+ information."
+ (flatten
+ (list (screenshots-overview-builder)
+ (screenshots-builder)
+ )))
+
+
+;;;
+;;; Helper builders.
+;;;
+
+
+(define (screenshots-builder)
+ "Return a list of Haunt pages representing screenshot pages."
+ (map
+ (lambda (shot)
+ (let ((context
+ (list (cons "screenshot" shot)
+ (cons "screenshots" screenshots))))
+ (serialized-artifact (path-join "screenshots"
+ (screenshot-slug shot)
+ "index.html")
+ (screenshot-t context)
+ sxml->html)))
+ screenshots))
+
+
+(define (screenshots-overview-builder)
+ "Return a Haunt page representing the screenshots overview page."
+ (serialized-artifact "screenshots/index.html"
+ (screenshots-overview-t screenshots)
+ sxml->html)) \ No newline at end of file
diff --git a/apps/media/data.scm b/apps/media/data.scm
new file mode 100644
index 0000000..9f54a43
--- /dev/null
+++ b/apps/media/data.scm
@@ -0,0 +1,59 @@
+;;; Harmonic Flow web site
+
+(define-module (apps media data)
+ #:use-module (apps base utils)
+ #:use-module (apps i18n)
+ #:use-module (apps media types)
+ #:use-module (srfi srfi-19)
+ #:export (screenshots))
+
+
+;;;
+;;; Data.
+;;;
+
+
+(define screenshots
+ (list
+ (screenshot
+ #:title (C_ "screenshot title" "HFGE example: Basic 2D")
+ #:slug "hfge-screenshot-basic2d"
+ #:image (hfweb-url "static/media/img/hfge_screenshot_big_1.png")
+ #:preview (hfweb-url "static/media/img/hfge_screenshot_min_1.png")
+ #:caption (G_ "HFGE example: Basic 2D"))
+
+ (screenshot
+ #:title (C_ "screenshot title" "HFGE example: Basic 3D (minimal convex hull in green)")
+ #:slug "hfge-screenshot-basic3d"
+ #:image (hfweb-url "static/media/img/hfge_screenshot_big_2.png")
+ #:preview (hfweb-url "static/media/img/hfge_screenshot_min_2.png")
+ #:caption (G_ "HFGE example: Basic 3D (minimal convex hull in green)"))
+
+ (screenshot
+ #:title (C_ "screenshot title" "HFGE example: glTF skinning")
+ #:slug "hfweb-screenshot-gltf-skinning"
+ #:image (hfweb-url "static/media/img/hfge_screenshot_big_3.png")
+ #:preview (hfweb-url "static/media/img/hfge_screenshot_min_3.png")
+ #:caption (G_ "HFGE example: glTF skinning"))
+
+ (screenshot
+ #:title (C_ "screenshot title" "HFGE example: Deferred rendering")
+ #:slug "hfge-screenshot-deferred-rendering"
+ #:image (hfweb-url "static/media/img/hfge_screenshot_big_4.png")
+ #:preview (hfweb-url "static/media/img/hfge_screenshot_min_4.png")
+ #:caption (G_ "HFGE example: Deferred rendering"))
+
+ (screenshot
+ #:title (C_ "screenshot title" "HFGE example: Collision 3D")
+ #:slug "hfge-screenshot-collision3d"
+ #:image (hfweb-url "static/media/img/hfge_screenshot_big_5.png")
+ #:preview (hfweb-url "static/media/img/hfge_screenshot_min_5.png")
+ #:caption (G_ "HFGE example: Collision 3D"))
+
+ (screenshot
+ #:title (C_ "screenshot title" "HFGE example: Collision 2D")
+ #:slug "hfge-screenshot-collision2d"
+ #:image (hfweb-url "static/media/img/hfge_screenshot_big_6.png")
+ #:preview (hfweb-url "static/media/img/hfge_screenshot_min_6.png")
+ #:caption (G_ "HFGE example: Collision 2D"))
+ )) \ No newline at end of file
diff --git a/apps/media/templates/components.scm b/apps/media/templates/components.scm
new file mode 100644
index 0000000..880d69f
--- /dev/null
+++ b/apps/media/templates/components.scm
@@ -0,0 +1,48 @@
+;;; Harmonic Flow web site
+
+(define-module (apps media templates components)
+ #:use-module (apps aux lists)
+ #:use-module (apps aux web)
+ #:use-module (apps base templates components)
+ #:use-module (apps base utils)
+ #:use-module (apps i18n)
+ #:use-module (apps media types)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-19)
+ #:export (screenshot->shtml
+ screenshots-box))
+
+
+;;;
+;;; Components.
+;;;
+
+
+(define (screenshot->shtml shot)
+ "Return an SHTML representation of the given screenshot object.
+
+ SHOT (<screenshot>)
+ A screenshot object as defined in (apps media types)."
+ `(div
+ (@ (class "screenshot-preview"))
+ (a
+ (@ (href ,(hfweb-url (url-path-join "screenshots"
+ (screenshot-slug shot) ""))))
+ (img
+ (@ (class "responsive-image")
+ (src ,(screenshot-preview shot))
+ (alt "")))
+ (span (@ (class "screenshot-inset-shadow")) ""))
+ (p ,(screenshot-caption shot) (span (@ (class "hidden")) "."))))
+
+
+(define* (screenshots-box screenshots #:optional (n 6) #:key shadow)
+ "Return SHTML for a box displaying up to N many SCREENSHOTS randomly
+chosen at build time. If SHADOW is true, a shadow is displayed at the
+top."
+ `(div
+ (@ (class ,(string-join `("screenshots-box"
+ ,@(if shadow
+ '("top-shadow-bg")
+ '())))))
+ ,@(map screenshot->shtml (take-random screenshots n)))) \ No newline at end of file
diff --git a/apps/media/templates/screenshot.scm b/apps/media/templates/screenshot.scm
new file mode 100644
index 0000000..5a32016
--- /dev/null
+++ b/apps/media/templates/screenshot.scm
@@ -0,0 +1,43 @@
+;;; Harmonic Flow web site
+
+(define-module (apps media templates screenshot)
+ #:use-module (apps base templates theme)
+ #:use-module (apps base types)
+ #:use-module (apps base utils)
+ #:use-module (apps media templates components)
+ #:use-module (apps media types)
+ #:use-module (apps i18n)
+ #:export (screenshot-t))
+
+
+(define (screenshot-t context)
+ "Return an SHTML page for the screenshot in the CONTEXT."
+ (let ((shot (context-datum context "screenshot"))
+ (shots (context-datum context "screenshots")))
+ (theme
+ #:title (list (screenshot-title shot) (C_ "webpage title" "screenshot |"))
+ #:description (screenshot-caption shot)
+ #:keywords
+ (string-split ;TRANSLATORS: |-separated list of webpage keywords
+ (G_ "Harmonic Flow|HFGE|Screenshot") #\|)
+ #:active-menu-item (C_ "website menu" "Screenshots")
+ #:css (list (hfweb-url "static/base/css/index.css")
+ (hfweb-url "static/media/css/screenshots.css"))
+ #:crumbs (list (crumb (C_ "website menu" "Screenshots") (hfweb-url "screenshots/"))
+ (crumb (screenshot-title shot) "./"))
+ #:content
+ `(main
+ (section
+ (@ (class "light-text centered-text noise-bg"))
+ (h2
+ (@ (class "a11y-offset"))
+ ,(screenshot-title shot))
+
+ (div
+ (@ (class "screenshot-viewer"))
+ (img
+ (@ (class "responsive-image centered-block")
+ (src ,(screenshot-image shot))
+ (alt ,(screenshot-caption shot)))))
+
+ ,(screenshots-box shots #:shadow #t))))))
diff --git a/apps/media/templates/screenshots-overview.scm b/apps/media/templates/screenshots-overview.scm
new file mode 100644
index 0000000..fee601b
--- /dev/null
+++ b/apps/media/templates/screenshots-overview.scm
@@ -0,0 +1,28 @@
+;;; Harmonic Flow web site
+
+(define-module (apps media templates screenshots-overview)
+ #:use-module (apps base templates theme)
+ #:use-module (apps base types)
+ #:use-module (apps base utils)
+ #:use-module (apps i18n)
+ #:use-module (apps media templates components)
+ #:export (screenshots-overview-t))
+
+
+(define (screenshots-overview-t screenshots)
+ "Return an SHTML page for all SCREENSHOTS."
+ (theme
+ #:title (C_ "webpage title" '("Overview of all available screenshots |"))
+ #:description (G_ "Overview of all available screenshots.")
+ #:keywords
+ (string-split ;TRANSLATORS: |-separated list of webpage keywords
+ (G_ "Harmonic Flow|HFGE|Screenshots|Overview") #\|)
+ #:active-menu-item (C_ "website menu" "Screenshots")
+ #:css (list (hfweb-url "static/base/css/index.css"))
+ #:crumbs (list (crumb (C_ "website menu" "Screenshots") "./"))
+ #:content
+ `(main
+ (section
+ (@ (class "light-text centered-text noise-bg"))
+
+ ,(screenshots-box screenshots (length screenshots) #:shadow #t)))))
diff --git a/apps/media/types.scm b/apps/media/types.scm
new file mode 100644
index 0000000..072684e
--- /dev/null
+++ b/apps/media/types.scm
@@ -0,0 +1,60 @@
+;;; Harmonic Flow web site
+
+(define-module (apps media types)
+ #:use-module (srfi srfi-9)
+ #:export (screenshot
+ screenshot?
+ screenshot-caption
+ screenshot-image
+ screenshot-preview
+ screenshot-slug
+ screenshot-title
+ ))
+
+
+;;;
+;;; Data types.
+;;;
+
+
+;;; Screenshot (record type)
+;;; ------------------------
+;;;
+;;; A screenshot object represents an image of a software view seen
+;;; on a screen.
+;;;
+;;; Objects of this type can be created with the "screenshot"
+;;; procedure (see Helper procedures below).
+;;;
+;;; Fields:
+;;;
+;;; title (string)
+;;; A title for the screenshot.
+;;;
+;;; slug (string)
+;;; Slug-like URL name for the screenshot. For example:
+;;; gnome-3-desktop.
+;;;
+;;; image (string)
+;;; A URL to the full size image of the screenshot.
+;;;
+;;; preview (string)
+;;; A URL to a small size image of the screenshot.
+;;;
+;;; caption (string)
+;;; A short text describing the screenshot.
+;;;
+(define-record-type <screenshot>
+ (make-screenshot title slug image preview caption)
+ screenshot?
+ (title screenshot-title)
+ (slug screenshot-slug)
+ (image screenshot-image)
+ (preview screenshot-preview)
+ (caption screenshot-caption))
+
+;;; Helper procedures.
+
+(define* (screenshot #:key title slug image preview caption)
+ "Return a <screenshot> object with the given attributes."
+ (make-screenshot title slug image preview caption))