From 1ef4c571934118deaae93f7f6eccc23ed8c32f9a Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Mon, 15 Jun 2020 17:13:25 +0200 Subject: [PATCH] wip: website: Add "latest" downloads. --- website/apps/base/templates/components.scm | 12 +- website/apps/download/builder.scm | 6 +- .../download/templates/download-latest.scm | 159 ++++++++++++++++++ website/static/base/css/common.css | 5 + 4 files changed, 180 insertions(+), 2 deletions(-) create mode 100644 website/apps/download/templates/download-latest.scm 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 ) A list of page objects that represent the web resources of the application. See Haunt 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..c14db8e --- /dev/null +++ b/website/apps/download/templates/download-latest.scm @@ -0,0 +1,159 @@ +;;; 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 . + +(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 + (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") + ".") + (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; -- 2.26.2