branch master updated: website: Add "latest" downloads.

[Mathieu Othacehe]

This is an automated email from the git hooks/post-receive script.

mothacehe pushed a commit to branch master
in repository guix-artwork.

The following commit(s) were added to refs/heads/master by this push:
     new 2e2f2ba  website: Add "latest" downloads.
2e2f2ba is described below

commit 2e2f2ba7e7f51dfa6054e8792109c249b2b33e28
Author: Mathieu Othacehe <m.othacehe@gmail.com>
AuthorDate: Mon Jun 15 17:13:25 2020 +0200

    website: Add "latest" downloads.
    
    * website/apps/download/templates/download-latest.scm: New file.
    * website/apps/download/builder.scm (download-latest-builder): New variable,
    (builder): add it.
    * website/apps/base/templates/components.scm (navbar): Add a dropdowm menu 
for
    "Download" with "Stable" and "Latests" items.
    * website/static/base/css/common.css (download-table-box): New class.
---
 website/apps/base/templates/components.scm         |  12 +-
 website/apps/download/builder.scm                  |   6 +-
 .../apps/download/templates/download-latest.scm    | 161 +++++++++++++++++++++
 website/static/base/css/common.css                 |   5 +
 4 files changed, 182 insertions(+), 2 deletions(-)

diff --git a/website/apps/base/templates/components.scm 
b/website/apps/base/templates/components.scm
index a10fb00..3252dc7 100644
--- a/website/apps/base/templates/components.scm
+++ b/website/apps/base/templates/components.scm
@@ -290,7 +290,17 @@
      (h2 (@ (class "a11y-offset")) "Website menu:")
      (ul
       ,(menu-item #:label "Overview" #:active-item active-item #:url 
(guix-url))
-      ,(menu-item #:label "Download" #:active-item active-item #:url (guix-url 
"download/"))
+
+      ,(menu-dropdown #:label "Download"
+                      #:active-item active-item
+                      #:items
+                      (list
+                       (menu-item #:label "Stable"
+                                  #:active-item active-item
+                                  #:url (guix-url "download/"))
+                       (menu-item #:label "Latest"
+                                  #:active-item active-item
+                                  #:url (guix-url "download/latest/"))))
       ,(menu-item #:label "Packages" #:active-item active-item #:url (guix-url 
"packages/"))
       ,(menu-item #:label "Blog" #:active-item active-item #:url (guix-url 
"blog/"))
 
diff --git a/website/apps/download/builder.scm 
b/website/apps/download/builder.scm
index dddd0b6..cc983c5 100644
--- a/website/apps/download/builder.scm
+++ b/website/apps/download/builder.scm
@@ -4,6 +4,7 @@
 
 (define-module (apps download builder)
   #:use-module (apps download templates download)
+  #:use-module (apps download templates download-latest)
   #:use-module (apps download data)
   #:use-module (haunt html)
   #:use-module (haunt page)
@@ -30,13 +31,16 @@
    RETURN (list of <page>)
      A list of page objects that represent the web resources of the
      application. See Haunt <page> objects for more information."
-  (list (download-builder)))
+  (list (download-builder)
+        (download-latest-builder)))
 
 
 
 ;;;
 ;;; Helper builders.
 ;;;
+(define (download-latest-builder)
+  (make-page "download/latest/index.html" (download-latest-t) sxml->html))
 
 (define (download-builder)
   "Return a Haunt page representing the Download page of the website."
diff --git a/website/apps/download/templates/download-latest.scm 
b/website/apps/download/templates/download-latest.scm
new file mode 100644
index 0000000..f23d3d1
--- /dev/null
+++ b/website/apps/download/templates/download-latest.scm
@@ -0,0 +1,161 @@
+;;; GNU Guix web site
+;;; Initially written by sirgazil who waives all
+;;; copyright interest on this file.
+;;;
+;;; This file is part of the GNU Guix web site.
+;;;
+;;; The GNU Guix web site is free software; you can redistribute it and/or 
modify it
+;;; under the terms of the GNU Affero General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; The GNU Guix web site is distributed in the hope that it will be useful, 
but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU Affero General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Affero General Public License
+;;; along with the GNU Guix web site.  If not, see 
<http://www.gnu.org/licenses/>.
+
+(define-module (apps download templates download-latest)
+  #:use-module (apps base templates theme)
+  #:use-module (apps base types)
+  #:use-module (apps base utils)
+  #:use-module (apps download templates components)
+  #:use-module (guix ci)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (ice-9 match)
+  #:export (download-latest-t))
+
+(define ci-url "https://ci.guix.gnu.org";)
+
+(define-record-type <image>
+  (make-image description logo job type)
+  image?
+  (description image-description)   ;string
+  (logo        image-logo)          ;string
+  (job         image-job)           ;string
+  (type        image-type))         ;string
+
+(define images
+  (list (make-image
+         "GNU Guix System ISO-9660 image for x86_64"
+         (guix-url "static/base/img/GuixSD-package.png")
+         "iso9660-image.x86_64-linux"
+         "ISO-9660")))
+
+(define (build-detail-url url build)
+  "Return the detail page for BUILD hosted on CI server at URL."
+  (format #f "~a/build/~a/details" url (build-id build)))
+
+(define (build-product-download-url url build-product)
+  "Return a download URL for BUILD-PRODUCT hosted on CI server at URL."
+  (string-append url "/download/" (number->string
+                                   (build-product-id build-product))))
+(define* (products-latest-urls job type
+                               #:optional (limit 15)
+                               #:key url)
+  "Fetch the latest LIMIT jobs from URL matching the given JOB. Then, for the
+first job with a build output of the given TYPE, return '(DETAIL-URL
+. DOWNLOAD-URL), where DETAIL-URL is the URL describing the matching build in
+the CI, and DOWNLOAD-URL is the URL to download the build output. If no
+matching jobs are found, return an empty list."
+  ;; See build-status enumeration in (cuirass database).
+  (define build-status-success 0)
+
+  (define (find-product-by-type build-products type)
+    (find (lambda (build-product)
+            (string=? (build-product-type build-product) type))
+          build-products))
+
+  (define (latest-build-products)
+    (let ((builds
+           (latest-builds url limit
+                          #:job job
+                          #:status build-status-success)))
+      (filter-map
+       (lambda (build)
+         (let ((products (build-products build)))
+           (match products
+             (() #f)
+             (x (let ((product
+                       (find-product-by-type products type)))
+                  (and product
+                       (cons build product)))))))
+       builds)))
+
+  (match (latest-build-products)
+    (((build . product) . rest)
+     (cons
+      (build-detail-url url build)
+      (build-product-download-url url product)))
+    (_ '())))
+
+(define (image-table-row image)
+  "Return as an HTML table row, the representation of IMAGE."
+  (let* ((description (image-description image))
+         (job (image-job image))
+         (type (image-type image))
+         (logo (image-logo image))
+         (urls (products-latest-urls job type #:url ci-url)))
+    `(tr
+      (td
+       (table
+        (@ (class "download-table-box"))
+        (tbody
+         (tr
+          (td
+           (@ (class "download-table-box"))
+           (img (@ (src ,logo) (alt ""))))
+          (td
+           (@ (class "download-table-box"))
+           (h3 ,description))))))
+      ,(if (null? urls)
+           '(td "No available image")
+           (match urls
+             ((detail-url . download-url)
+              `(td
+                (a (@ (href ,download-url)) "Download")
+                " "
+                (a (@ (href ,detail-url)) "(details)"))))))))
+
+(define (download-latest-t)
+  "Return the Download latest page in SHTML."
+  (theme
+   #:title '("Download latest")
+   #:description
+   "Download latest GNU Guix System images built by the Cuirass continuous
+integration system."
+   #:keywords
+   '("GNU" "Linux" "Unix" "Free software" "Libre software"
+     "Operating system" "GNU Hurd" "GNU Guix package manager"
+     "Installer" "Source code" "Package manager")
+   #:active-menu-item "Download"
+   #:css (list
+          (guix-url "static/base/css/page.css")
+          (guix-url "static/base/css/download.css"))
+   #:crumbs (list (crumb "Download" (guix-url "download/"))
+                  (crumb "Latest" "./"))
+   #:content
+   `(main
+     (section
+      (@ (class "page"))
+      (h2 "Download latest images")
+      (p
+       (@ (class "centered-block limit-width"))
+       "Download latest GNU Guix System images built by the "
+       (a (@ (href ,(manual-url "Continuous-Integration.html"))) "Cuirass")
+       " continuous integration system at "
+       (a (@ (href ,ci-url)) "ci.guix.gnu.org")
+       ". These images are " (b "development snapshots")
+       ", you might prefer to use stable images that can be found "
+       (a (@ (href ,(guix-url "download/"))) "here."))
+      (div
+       (@ (class "centered-block limit-width table-box"))
+       (table
+        (thread
+         (tr (th "image")
+             (th "download")))
+        (tbody
+         ,(map image-table-row images))))))))
diff --git a/website/static/base/css/common.css 
b/website/static/base/css/common.css
index 373558e..ee7a4e7 100644
--- a/website/static/base/css/common.css
+++ b/website/static/base/css/common.css
@@ -146,6 +146,11 @@
     overflow-x: auto;
 }
 
+.download-table-box {
+    border: none;
+    border-collapse: collapse;
+}
+
 .top-shadow-bg {
     background-image: url("../img/top-shadow-bg.png");
     background-repeat: repeat-x;