unofficial mirror of guix-devel@gnu.org 
 help / color / mirror / code / Atom feed
From: Mathieu Othacehe <othacehe@gnu.org>
To: guix-devel@gnu.org
Subject: Latest download from website
Date: Mon, 15 Jun 2020 17:20:13 +0200	[thread overview]
Message-ID: <878sgowe36.fsf@gnu.org> (raw)

[-- Attachment #1: Type: text/plain, Size: 385 bytes --]


Hello,

Here's a wip patch for the website. It adds a new "download/latest"
page allowing to download the latest Guix System images from Cuirass.

I've merged all the required mechanisms in Guix and Cuirass, now most of
the remaining work is "cosmetic" (and that's not my cup of tea).

Anyway, the patch and a screenshot are attached, please tell me what you
think.

Thanks,

Mathieu

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-wip-website-Add-latest-downloads.patch --]
[-- Type: text/x-diff, Size: 9362 bytes --]

From 1ef4c571934118deaae93f7f6eccc23ed8c32f9a Mon Sep 17 00:00:00 2001
From: Mathieu Othacehe <m.othacehe@gmail.com>
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 <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..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 <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")
+       ".")
+      (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


[-- Attachment #3: latest.png --]
[-- Type: image/png, Size: 96450 bytes --]

             reply	other threads:[~2020-06-15 15:20 UTC|newest]

Thread overview: 6+ messages / expand[flat|nested]  mbox.gz  Atom feed  top
2020-06-15 15:20 Mathieu Othacehe [this message]
2020-06-16 10:04 ` Latest download from website Ludovic Courtès
2020-06-18  7:24   ` Mathieu Othacehe
2020-06-19 20:45     ` Ludovic Courtès
2020-06-25 10:10       ` Mathieu Othacehe
2020-06-28 20:19         ` Ludovic Courtès

Reply instructions:

You may reply publicly to this message via plain-text email
using any one of the following methods:

* Save the following mbox file, import it into your mail client,
  and reply-to-all from there: mbox

  Avoid top-posting and favor interleaved quoting:
  https://en.wikipedia.org/wiki/Posting_style#Interleaved_style

  List information: https://guix.gnu.org/

* Reply using the --to, --cc, and --in-reply-to
  switches of git-send-email(1):

  git send-email \
    --in-reply-to=878sgowe36.fsf@gnu.org \
    --to=othacehe@gnu.org \
    --cc=guix-devel@gnu.org \
    /path/to/YOUR_REPLY

  https://kernel.org/pub/software/scm/git/docs/git-send-email.html

* If your mail client supports setting the In-Reply-To header
  via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line before the message body.
Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/guix.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).