diff options
| author | Andreas Widen <andreas@harmonicflow.org> | 2023-11-25 17:21:37 +0100 |
|---|---|---|
| committer | Andreas Widen <andreas@harmonicflow.org> | 2023-11-25 17:21:37 +0100 |
| commit | 1b2b7c3eb939724696894f31ff27db97b0cac84c (patch) | |
| tree | efb7b7746a628efb7bb99b2e44c9c2fbfd75b656 /apps | |
| download | hf-web-1b2b7c3eb939724696894f31ff27db97b0cac84c.tar.xz hf-web-1b2b7c3eb939724696894f31ff27db97b0cac84c.zip | |
Initial commit.
Signed-off-by: Andreas Widen <andreas@harmonicflow.org>
Diffstat (limited to 'apps')
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)) |