From 29723b3c711db2316e1fb66d252de769494b4a98 Mon Sep 17 00:00:00 2001 From: Luis Felipe Date: Mon, 21 Nov 2022 11:06:03 -0500 Subject: [PATCH] website: Remove packages app. There is a new package browser at https://packages.guix.gnu.org/. It is not necessary to generate a static package catalog anymore. * website/apps/packages: Remove it. * website/tests/apps/packages: Likewise. * website/haunt.scm (site): Remove packages builder. * website/tests/all.scm: Don't import packages tests. --- website/apps/packages/builder.scm | 308 ------------------ website/apps/packages/data.scm | 63 ---- .../apps/packages/templates/components.scm | 275 ---------------- .../packages/templates/detailed-index.scm | 66 ---- .../templates/detailed-package-list.scm | 67 ---- website/apps/packages/templates/index.scm | 64 ---- .../apps/packages/templates/package-list.scm | 65 ---- website/apps/packages/templates/package.scm | 87 ----- website/apps/packages/types.scm | 109 ------- website/apps/packages/utils.scm | 282 ---------------- website/haunt.scm | 2 - website/tests/all.scm | 3 +- website/tests/apps/packages/utils.scm | 107 ------ 13 files changed, 1 insertion(+), 1497 deletions(-) delete mode 100644 website/apps/packages/builder.scm delete mode 100644 website/apps/packages/data.scm delete mode 100644 website/apps/packages/templates/components.scm delete mode 100644 website/apps/packages/templates/detailed-index.scm delete mode 100644 website/apps/packages/templates/detailed-package-list.scm delete mode 100644 website/apps/packages/templates/index.scm delete mode 100644 website/apps/packages/templates/package-list.scm delete mode 100644 website/apps/packages/templates/package.scm delete mode 100644 website/apps/packages/types.scm delete mode 100644 website/apps/packages/utils.scm delete mode 100644 website/tests/apps/packages/utils.scm diff --git a/website/apps/packages/builder.scm b/website/apps/packages/builder.scm deleted file mode 100644 index b08ba2e..0000000 --- a/website/apps/packages/builder.scm +++ /dev/null @@ -1,308 +0,0 @@ -;;; GNU Guix web site -;;; Copyright © 2017 Ludovic Courtès -;;; Copyright © 2019 Ricardo Wurmus -;;; Copyright © 2019 Nicolò Balzarotti -;;; Copyright © 2020, 2021 Simon Tournier -;;; -;;; 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 packages builder) - #:use-module (apps aux lists) - #:use-module (apps aux system) - #:use-module (apps base utils) - #:use-module (apps packages data) - #:use-module (apps packages templates detailed-index) - #:use-module (apps packages templates index) - #:use-module (apps packages templates detailed-package-list) - #:use-module (apps packages templates package) - #:use-module (apps packages templates package-list) - #:use-module (apps packages types) - #:use-module (apps packages utils) - #:use-module (haunt html) - #:use-module (haunt page) - #:use-module (haunt utils) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) - #:use-module (guix packages) - #:use-module (guix download) - #:use-module (guix git-download) - #:use-module (guix svn-download) - #:use-module (guix hg-download) - #:use-module (guix utils) ;location - #:use-module ((guix build download) #:select (maybe-expand-mirrors)) - #:use-module ((guix base64) #:select (base64-encode)) - #:use-module ((guix describe) #:select (current-profile)) - #:use-module ((guix config) #:select (%guix-version)) - #:use-module (guix gexp) - #:use-module (json) - #:use-module (ice-9 match) - #:use-module ((web uri) #:select (string->uri uri->string)) - #:export (builder)) - -;;; Required by 'origin->json' for 'computed-origin-method' corner cases -(define gexp-references (@@ (guix gexp) gexp-references)) - -;;; -;;; Application builder. -;;; - -(define (builder site posts) - "Return the list of web resources that compose the app. - - This procedure is a Haunt builder procedure. - - SITE () - A site object that defines all the properties of the website. See - Haunt objects for more information. - - POSTS (list of ) - A list of post objects that represent articles from the blog. See - Haunt objects for more information. - - RETURN (list of ) - A list of page objects that represent the web resources of the - application. See Haunt objects for more information." - (flatten - (list - (index-builder) - (sources-json-builder) - (packages-json-builder) - (packages-builder) - (package-list-builder)))) - - - -;;; -;;; Helper builders. -;;; - -(define %max-packages-on-index - ;; Maximum number of packages shown on /packages. - 30) - -(define (origin->json origin) - "Return a JSON representation (an alist) of ORIGIN." - (define method - (origin-method origin)) - - (define uri - (origin-uri origin)) - - (define (resolve urls) - (map uri->string - (append-map (cut maybe-expand-mirrors <> %mirrors) - (map string->uri urls)))) - - (if (eq? method (@@ (guix packages) computed-origin-method)) - ;; Packages in gnu/packages/gnuzilla.scm and gnu/packages/linux.scm - ;; represent their 'uri' as 'promise'. - (match uri - ((? promise? promise) - (match (force promise) - ((? gexp? g) - (append-map origin->json - (filter-map (match-lambda - ((? gexp-input? thing) - (match (gexp-input-thing thing) - ((? origin? o) o) - (_ #f))) - (_ #f)) - (gexp-references g)))) - (_ `((type . #nil)))))) - ;;Regular packages represent 'uri' as string. - `(((type . ,(cond ((or (eq? url-fetch method) - (eq? url-fetch/tarbomb method) - (eq? url-fetch/zipbomb method)) 'url) - ((eq? git-fetch method) 'git) - ((or (eq? svn-fetch method) - (eq? svn-multi-fetch method)) 'svn) - ((eq? hg-fetch method) 'hg) - (else #nil))) - ,@(cond ((or (eq? url-fetch method) - (eq? url-fetch/tarbomb method) - (eq? url-fetch/zipbomb method)) - `(("urls" . ,(list->vector - (resolve - (match uri - ((? string? url) (list url)) - ((urls ...) urls))))))) - ((eq? git-fetch method) - `(("git_url" . ,(git-reference-url uri)))) - ((eq? svn-fetch method) - `(("svn_url" . ,(svn-reference-url uri)))) - ((eq? svn-multi-fetch method) - `(("svn_url" . ,(svn-multi-reference-url uri)))) - ((eq? hg-fetch method) - `(("hg_url" . ,(hg-reference-url uri)))) - (else '())) - ,@(if (or (eq? url-fetch method) - (eq? url-fetch/tarbomb method) - (eq? url-fetch/zipbomb method)) - (let* ((content-hash (origin-hash origin)) - (hash-value (content-hash-value content-hash)) - (hash-algorithm (content-hash-algorithm content-hash)) - (algorithm-string (symbol->string hash-algorithm))) - `(("integrity" . ,(string-append algorithm-string "-" - (base64-encode hash-value))))) - '()) - ,@(if (eq? method git-fetch) - `(("git_ref" . ,(git-reference-commit uri))) - '()) - ,@(if (eq? method svn-fetch) - `(("svn_revision" . ,(svn-reference-revision uri))) - '()) - ,@(if (eq? method svn-multi-fetch) - `(("svn_revision" . ,(svn-multi-reference-revision uri))) - '()) - ,@(if (eq? method hg-fetch) - `(("hg_changeset" . ,(hg-reference-changeset uri))) - '()))))) - -(define (packages-json-builder) - "Return a JSON page listing all packages." - (define (package->json package) - (define cpe-name - (assoc-ref (package-properties package) 'cpe-name)) - (define cpe-version - (assoc-ref (package-properties package) 'cpe-version)) - - `(("name" . ,(package-name package)) - ("version" . ,(package-version package)) - ,@(if cpe-name `(("cpe_name" . ,cpe-name)) '()) - ,@(if cpe-version `(("cpe_version" . ,cpe-version)) '()) - ,@(if (origin? (package-source package)) - `(("source" . ,(list->vector - (origin->json (package-source package))))) - '()) - ("synopsis" . ,(package-synopsis package)) - ,@(if (package-home-page package) - `(("homepage" . ,(package-home-page package))) - '()) - ,@(match (package-location package) - ((? location? location) - `(("location" - . ,(string-append (location-file location) ":" - (number->string - (+ 1 (location-line location))))))) - (#f - '())))) - - (make-page "packages.json" - (list->vector (map package->json (all-packages))) - scm->json)) - -(define (sources-json-builder) - "Return a JSON page listing all the sources." - ;; The Software Heritage format is described here: - ;; https://forge.softwareheritage.org/source/swh-loader-core/browse/master/swh/loader/package/nixguix/tests/data/https_nix-community.github.io/nixpkgs-swh_sources.json - ;; And the loader is implemented here: - ;; https://forge.softwareheritage.org/source/swh-loader-core/browse/master/swh/loader/package/nixguix/ - (define (package->json package) - `(,@(if (origin? (package-source package)) - (origin->json (package-source package)) - `(((type . "no-origin") - ("name" . ,(package-name package))))))) - - (make-page "sources.json" - `(("sources" . ,(list->vector (append-map package->json (all-packages)))) - ("version" . "1") - ("revision" . - ,(match (current-profile) - (#f %guix-version) ;for lack of a better ID - (profile - (let ((channel (find guix-channel? (profile-channels profile)))) - (channel-commit channel)))))) - scm->json)) - -(define (index-builder) - "Return a Haunt page listing some random packages." - (define (sample n from) - (map (lambda (id) (list-ref from id)) - (list-tabulate n (lambda _ (random (length from)))))) - (let ((context (list (cons "packages" - (sample %max-packages-on-index - (all-packages))) - (cons "total" - (length (all-packages)))))) - (make-page "packages/index.html" (index-t context) sxml->html))) - - -(define (detailed-index-builder) - "Return a Haunt page listing some random packages." - ;; TODO: Pass ~30 random Guix packages. - (let ((context (list (cons "packages" - (take-at-most (all-packages) - %max-packages-on-index))))) - (make-page "packages/index.html" - (detailed-index-t context (length (all-packages))) - sxml->html))) - - -(define (detailed-package-list-builder) - "Return a list of grouped Haunt pages listing Guix packages. - - Each group is a list of page objects corresponding to paginated - packages starting with a specific letter." - (let ((package-groups (packages/group-by-letter (all-packages)))) - (map - (lambda (package-group) - (let* ((letter (car package-group)) - (context - (list - (cons "letter" letter)))) - (paginate #:dataset (cdr package-group) - #:limit 100 - #:base-path (path-join "packages" letter) - #:template detailed-package-list-t - #:context context - #:writer sxml->html))) - package-groups))) - - -(define (packages-builder) - "Return a list of Haunt pages for each Guix package." - (map - (lambda (package) - (let ((context (list (cons "package" package)))) - (make-page - (path-join (package-url-path package) "index.html") - (package-t context) - sxml->html))) - (all-packages))) - - -(define (package-list-builder) - "Return a list of grouped Haunt pages listing Guix packages. - - Each group is a list of page objects corresponding to paginated - packages starting with a specific letter." - (let ((package-groups (packages/group-by-letter (all-packages)))) - (map - (lambda (package-group) - (let* ((letter (car package-group)) - (context - (list - (cons "letter" letter)))) - (paginate #:dataset (cdr package-group) - #:limit 100 - #:base-path (path-join "packages" letter) - #:template package-list-t - #:context context - #:writer sxml->html))) - package-groups))) diff --git a/website/apps/packages/data.scm b/website/apps/packages/data.scm deleted file mode 100644 index c80d979..0000000 --- a/website/apps/packages/data.scm +++ /dev/null @@ -1,63 +0,0 @@ -;;; GNU Guix web site -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2021 Ludovic Courtès -;;; Copyright © 2015 Mathieu Lirzin -;;; Copyright © 2013 Alex Sassmannshausen -;;; Copyright © 2017 Eric Bavier -;;; 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 packages data) - #:use-module (gnu packages) - #:use-module (guix packages) - #:export (all-packages - alphabet)) - - -(define alphabet - (list "0-9" "A" "B" "C" "D" "E" "F" "G" "H" "I" "J" "K" "L" "M" - "N" "O" "P" "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z")) - - -(define %package-list - (delay - ;; Note: Dismiss packages found in $GUIX_PACKAGE_PATH. - (let ((packages - (sort (parameterize ((%package-module-path (last-pair - (%package-module-path)))) - (fold-packages (lambda (package lst) - (if (or (package-superseded package) - (package-replacement package)) - lst - (cons package lst))) - '())) - (lambda (p1 p2) - (stringshtml - letter-selector - license->shtml - lint-issue->shtml - location->shtml - package-preview - patches->shtml - sidebar - supported-systems->shtml)) - - -;;; -;;; Components. -;;; - -(define (detailed-package-preview package) - "Return an SHTML div element representing the given PACKAGE object. - - PACKAGE () - A package object as defined in the GNU Guix API reference." - `(div - (@ (class "package-preview")) - (h3 - (@ (class "package-name")) - ,(package-name package) " " ,(package-version package) " " - ,(if (package-issues? package) '(span (@ (class "red-tag")) "") " ") - (span - (@ (class "package-synopsis")) - " — " - ,(package-synopsis-shtml package))) - - (div - (@ (class "package-description")) - - ;; 'gnu-package?' might fetch stuff from the network. Assume #f if that - ;; doesn't work. - ,(if (false-if-exception (gnu-package? package)) - `(p (i ,(G_ "This is a GNU package. "))) - "") - - ,(package-description-shtml package)) - - (ul - (@ (class "package-info")) - ,(G_ `(li ,(G_ `(b "License:")) " " - ,(license->shtml (package-license package)) - ".")) - - ,(G_ `(li ,(G_ `(b "Website:")) " " - ,(link-subtle #:label (package-home-page package) - #:url (package-home-page package)) ".")) - - ,(G_ `(li ,(G_ `(b "Package source:")) " " - ,(location->shtml (package-location package)) - ".")) - - ,(G_ `(li ,(G_ `(b "Patches:")) " " - ,(patches->shtml (package-patches package)) - ".")) - - ,(G_ `(li ,(G_ `(b "Lint issues:")) " " - ,(if (null? (package-lint-issues package)) - (G_ "No") - (link-subtle #:label (G_ "Yes") - #:url (guix-url "packages/issues/"))) - ".")) - - ,(G_ `(li ,(G_ `(b "Builds:")) " " - ,(supported-systems->shtml package) ".")) - "\n"))) - - -(define (issue-count->shtml count) - "Return an SHTML representation of COUNT in the form 'X issue(s)'. - - COUNT (natural) - A natural number. - - RETURN (shtml) - A span element if the count is 0. A mark element otherwise." - `(,(if (> count 0) 'mark 'span) - ,(number->string count) - ,(N_ " issue" " issues" count))) - - -(define* (letter-selector #:optional (active-letter "")) - "Return an SHTML section element representing a widget to list - packages by initial. - - ACTIVE-LETTER (string) - The letter that should be displayed as active." - `(section - (@ (class "letter-selector")) - ,(G_ `(h3 (@ (class "a11y-offset")) "Packages menu: ")) - - ,(G_ `(h4 (@ (class "selector-title selector-title-top")) - "Browse alphabetically")) - (div - (@ (class "selector-box-padded")) - ,@(map - (lambda (letter) - (list - (button-little - #:label letter - #:url (guix-url (url-path-join "packages" letter "")) - #:active (string=? letter active-letter)) - " ")) ; NOTE: Force space for readability in non-CSS browsers. - alphabet)))) - - -(define (license->shtml license) - "Return an SHTML representation of the LICENSE. - - LICENSE (itemization) - One of two types of object: - — A object as defined in the (apps packages types) - module. - — A list of objects. - - RETURN (shtml) - One or more links to the licenses." - (cond ((license? license) - (link-subtle #:label (license-name license) - #:url (license-uri license))) - (else - (separate - (map (lambda (l) ; a license object. - (link-subtle #:label (license-name l) - #:url (license-uri l))) - license) - ", ")))) - - -(define (lint-issue->shtml issue) - "Return an SHTML div element representing the given ISSUE object. - - ISSUE () - A lint issue object as defined in the (apps packages types) module." - `(div - (@ (class "lint-issue")) - (p (@ (class "lint-issue-type")) ,(lint-issue-type issue) ":") - (pre ,(lint-issue-description issue)))) - - -(define (location->shtml loc) - "Return an SHTML a element representing the given location LOC. - - LOC () - A location object as defined in the GNU Guix API reference." - (let ((ilink (location->ilink loc))) - (link-subtle #:label (ilink-name ilink) - #:url (ilink-url ilink)))) - - -(define (package-preview package) - "Return an SHTML a element representing the given PACKAGE object. - - PACKAGE () - A package object as defined in the GNU Guix API reference." - `(a - (@ (class "item-preview") - (href ,(guix-url (url-path-join (package-url-path package) "")))) - (h3 ,(package-name package) " " ,(package-version package)) - (p - (@ (class "item-summary")) - ,(string-summarize - (stexi->plain-text - (texi-fragment->stexi (P_ (package-description package)))) - 30) - "…"))) - - -(define (patches->shtml patches) - "Return an SHTML representation of PATCHES. - - PATCHES (list) - A list of objects as defined in (apps packages types) - module. - - RETURN (shtml) - If the list of patches is empty, return the string 'None'. - Otherwise, return a list of links to patches." - (if (null? patches) - (C_ "patches" "None") - (separate - (map (lambda (patch) - (link-subtle #:label (ilink-name patch) - #:url (ilink-url patch))) - patches) - ", "))) - - -(define* (sidebar #:optional (active-letter "")) - "Return an SHTML section element representing the sidebar of the - package list. - - ACTIVE-LETTER (string) - The letter in which the current packages are listed." - `(section - (@ (class "side-bar")) - ,(G_ `(h3 (@ (class "a11y-offset")) "Packages menu: ")) - - ,(G_ `(h4 (@ (class "bar-title bar-title-top")) "Browse alphabetically")) - (div - (@ (class "bar-box-padded")) - ,@(map - (lambda (letter) - (list - (button-little - #:label letter - #:url (guix-url (url-path-join "packages" letter "")) - #:active (string=? letter active-letter)) - " ")) ; NOTE: Force space for readability in non-CSS browsers. - alphabet)) - - ;; FIXME: This is currently too costly to produce so we just disable it. - - ;; ,(G_ `(h4 (@ (class "bar-title")) "Packages Issues")) - ;; (ul - ;; (@ (class "bar-list")) - ;; (li (@ (class "bar-item")) - ;; ,(G_ `(a (@ (class "bar-link") - ;; (href ,(guix-url "packages/issues/lint/"))) "Lint"))) - ;; (li (@ (class "bar-item")) - ;; ,(G_ `(a (@ (class "bar-link") - ;; (href ,(guix-url "packages/issues/reproducibility/"))) - ;; "Reproducibility")))) - )) - - -(define (supported-systems->shtml package) - "Return a list of SHTML a links to SYSTEMS builds. - - SYSTEMS () - A package object as defined in Guix API. - - RETURN (shtml) - If the list of supported systems of the package is empty, return - the string 'None'. Otherwise, return a list of links to systems - builds in hydra." - (let ((build-url "https://ci.guix.gnu.org/job/gnu/master/") - (package-id (string-append (package-name package) - "-" - (package-version package))) - (systems (filter (cut supported-package? package <>) - %cuirass-supported-systems))) - (if (null? systems) - (C_ "systems" "None") - ;; TODO: There's currently no way to refer to a job like - ;; 'coreutils-8.32' in the Cuirass web UI. Add such a link once it's - ;; become available. - (separate systems ", ")))) diff --git a/website/apps/packages/templates/detailed-index.scm b/website/apps/packages/templates/detailed-index.scm deleted file mode 100644 index 698aac5..0000000 --- a/website/apps/packages/templates/detailed-index.scm +++ /dev/null @@ -1,66 +0,0 @@ -;;; GNU Guix web site -;;; Initially written by sirgazil who waives all -;;; copyright interest on this file. - -(define-module (apps packages templates detailed-index) - #: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 i18n) - #:use-module (apps packages templates components) - #:use-module (srfi srfi-19) - #:export (detailed-index-t)) - - -(define* (detailed-index-t context #:optional total) - "Return SHTML index page for the package app. TOTAL is the total number of -packages to advertise." - (let ((packages (context-datum context "packages"))) - (theme - #:title (C_ "webpage title" (list "Packages")) - #:description - (G_ "List of packages available through GNU Guix.") - #:keywords - (string-split ;TRANSLATORS: |-separated list of webpage keywords - (G_ "GNU|Linux|Unix|Free software|Libre software|Operating \ -system|GNU Hurd|GNU Guix package manager|GNU Guile|Guile \ -Scheme|Transactional upgrades|Functional package \ -management|Reproducibility") #\|) - #:active-menu-item (C_ "website menu" "Packages") - #:css - (list (guix-url "static/base/css/page.css") - (guix-url "static/base/css/item-preview.css") - (guix-url "static/packages/css/letter-selector.css") - (guix-url "static/packages/css/package-list.css")) - #:crumbs - (list (crumb (C_ "website menu" "Packages") (guix-url "packages/"))) - #:content - `(main - (section - (@ (class "page centered-text")) - ,(G_ `(h2 "Packages")) - - ,(G_ - `(p - (@ (class "limit-width centered-block")) - "GNU Guix provides " ,(number* (or total (length packages))) - " packages transparently " - ,(G_ - `(a (@ (href "https://www.gnu.org/software/guix/manual/en/html_node/Substitutes.html")) - "available as pre-built binaries")) - ". These pages provide a complete list of the packages. Our " - ,(G_ - `(a (@ (href "https://ci.guix.gnu.org/jobset/master")) - "continuous integration system")) - " shows their current build status " - "(updated " ,(date->string (current-date) - (C_ "SRFI-19 date->string format" - "~B ~e, ~Y")) ").")) - - (div - (@ (class "sheet sheet-padded justify-left")) - ,(letter-selector) - ,@(map detailed-package-preview packages) - ,(letter-selector))))))) diff --git a/website/apps/packages/templates/detailed-package-list.scm b/website/apps/packages/templates/detailed-package-list.scm deleted file mode 100644 index 1332c98..0000000 --- a/website/apps/packages/templates/detailed-package-list.scm +++ /dev/null @@ -1,67 +0,0 @@ -;;; GNU Guix web site -;;; Initially written by sirgazil who waives all -;;; copyright interest on this file. - -(define-module (apps packages templates detailed-package-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 i18n) - #:use-module (apps packages templates components) - #:export (detailed-package-list-t)) - - -(define (detailed-package-list-t context) - "Return an SHTML page listing the packages in the CONTEXT." - (let ((letter (context-datum context "letter")) - (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 "")) - letter (C_ "webpage title" "Packages")) - #:description - (G_ "List of packages available through GNU Guix.") - #:keywords - (string-split ;TRANSLATORS: |-separated list of webpage keywords - (G_ "GNU|Linux|Unix|Free software|Libre software|Operating \ -system|GNU Hurd|GNU Guix package manager|GNU Guile|Guile \ -Scheme|Transactional upgrades|Functional package \ -management|Reproducibility") #\|) - #:active-menu-item (C_ "website menu" "Packages") - #:css - (list (guix-url "static/base/css/page.css") - (guix-url "static/base/css/item-preview.css") - (guix-url "static/packages/css/letter-selector.css") - (guix-url "static/packages/css/package-list.css")) - #:scripts - (list (guix-url "static/packages/js/build-status.js")) - #:crumbs - (list (crumb (C_ "website menu" "Packages") (guix-url "packages/")) - (crumb letter (guix-url (url-path-join "packages" - letter - ""))) - (crumb (G_ (string-append "Page " page-number "")) - (guix-url (url-path-join "packages" - "page" - page-number - "")))) - #:content - `(main - (section - (@ (class "page centered-text")) - (h2 (G_ "Packages — ") ,letter - ,(page-indicator (string->number page-number) - (string->number total-pages))) - - (div - (@ (class "sheet sheet-padded justify-left")) - ,(letter-selector letter) - ,@(map detailed-package-preview (context-datum context "items")) - ,(letter-selector letter) - ,(page-selector (string->number total-pages) - (string->number page-number) - (guix-url (url-path-join "packages" letter))))))))) diff --git a/website/apps/packages/templates/index.scm b/website/apps/packages/templates/index.scm deleted file mode 100644 index feec755..0000000 --- a/website/apps/packages/templates/index.scm +++ /dev/null @@ -1,64 +0,0 @@ -;;; GNU Guix web site -;;; Initially written by sirgazil who waives all -;;; copyright interest on this file. - -(define-module (apps packages templates index) - #: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 i18n) - #:use-module (apps packages templates components) - #:use-module (srfi srfi-19) - #:export (index-t)) - - -(define (index-t context) - "Return an SHTML representation of the index page." - (let ((packages (context-datum context "packages")) - (total (context-datum context "total"))) - (theme - #:title (C_ "webpage title" (list "Packages")) - #:description - (G_ "List of packages available through GNU Guix.") - #:keywords - (string-split ;TRANSLATORS: |-separated list of webpage keywords - (G_ "GNU|Linux|Unix|Free software|Libre software|Operating \ -system|GNU Hurd|GNU Guix package manager|GNU Guile|Guile \ -Scheme|Transactional upgrades|Functional package \ -management|Reproducibility") #\|) - #:active-menu-item (C_ "website menu" "Packages") - #:css - (list (guix-url "static/base/css/page.css") - (guix-url "static/base/css/item-preview.css") - (guix-url "static/packages/css/letter-selector.css")) - #:crumbs - (list (crumb (C_ "website menu" "Packages") (guix-url "packages/"))) - #:content - `(main - (section - (@ (class "page centered-text")) - ,(G_ `(h2 "Packages")) - - ,(G_ - `(p - (@ (class "limit-width centered-block")) - "GNU Guix provides " ,(number* total) " packages transparently " - ,(G_ - `(a (@ (href "https://www.gnu.org/software/guix/manual/en/html_node/Substitutes.html")) - "available as pre-built binaries")) - ". These pages provide a complete list of the packages. Our " - ,(G_ - `(a (@ (href "https://ci.guix.gnu.org/jobset/master")) - "continuous integration system")) - " shows their current build status " - "(updated " ,(date->string (current-date) - (C_ "SRFI-19 date->string format" - "~B ~e, ~Y")) ").")) - - (div - (@ (class "sheet")) - ,(letter-selector) - ,@(map package-preview packages) - ,(letter-selector))))))) diff --git a/website/apps/packages/templates/package-list.scm b/website/apps/packages/templates/package-list.scm deleted file mode 100644 index eca8a5e..0000000 --- a/website/apps/packages/templates/package-list.scm +++ /dev/null @@ -1,65 +0,0 @@ -;;; GNU Guix web site -;;; Initially written by sirgazil who waives all -;;; copyright interest on this file. - -(define-module (apps packages templates package-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 i18n) - #:use-module (apps packages templates components) - #:export (package-list-t)) - - -(define (package-list-t context) - "Return a list of packages in SHTML with the data in CONTEXT." - (let ((letter (context-datum context "letter")) - (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 "")) - letter (C_ "webpage title" "Packages")) - #:description - "List of packages available through GNU Guix." - #:keywords - (string-split ;TRANSLATORS: |-separated list of webpage keywords - (G_ "GNU|Linux|Unix|Free software|Libre software|Operating \ -system|GNU Hurd|GNU Guix package manager|GNU Guile|Guile \ -Scheme|Transactional upgrades|Functional package \ -management|Reproducibility") #\|) - #:index? #false - #:active-menu-item (C_ "website menu" "Packages") - #:css - (list (guix-url "static/base/css/page.css") - (guix-url "static/base/css/item-preview.css") - (guix-url "static/packages/css/letter-selector.css")) - #:crumbs - (list (crumb (C_ "website menu" "Packages") (guix-url "packages/")) - (crumb letter (guix-url (url-path-join "packages" - letter - ""))) - (crumb (G_ (string-append "Page " page-number "")) - (guix-url (url-path-join "packages" - "page" - page-number - "")))) - #:content - `(main - (section - (@ (class "page centered-text")) - (h2 (G_ "Packages — ") ,letter - ,(page-indicator (string->number page-number) - (string->number total-pages))) - - (div - (@ (class "sheet")) - ,(letter-selector letter) - ,@(map package-preview (context-datum context "items")) - ,(letter-selector letter) - ,(page-selector (string->number total-pages) - (string->number page-number) - (guix-url (url-path-join "packages" letter))))))))) diff --git a/website/apps/packages/templates/package.scm b/website/apps/packages/templates/package.scm deleted file mode 100644 index aa3dcf0..0000000 --- a/website/apps/packages/templates/package.scm +++ /dev/null @@ -1,87 +0,0 @@ -;;; GNU Guix web site -;;; Initially written by sirgazil who waives all -;;; copyright interest on this file. - -(define-module (apps packages templates package) - #: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 i18n) - #:use-module (apps packages templates components) - #:use-module (apps packages types) - #:use-module (apps packages utils) - #:use-module (guix gnu-maintenance) - #:use-module (guix packages) - #:export (package-t)) - - -(define (package-t context) - "Return an SHTML representation of a package page." - (let* ((package (context-datum context "package")) - (package-id (string-append (package-name package) - " " - (package-version package))) - (lint-issues (package-lint-issues package))) - (theme - #:title (C_ "webpage title" (list package-id "Packages")) - #:description (package-synopsis-shtml package) - #:keywords - (string-split ;TRANSLATORS: |-separated list of webpage keywords - (G_ "GNU|Linux|Unix|Free software|Libre software|Operating \ -system|GNU Hurd|GNU Guix package manager|GNU Guile|Guile \ -Scheme|Transactional upgrades|Functional package \ -management|Reproducibility") #\|) - #:active-menu-item (C_ "website menu" "Packages") - #:css - (list (guix-url "static/base/css/page.css") - (guix-url "static/packages/css/package.css")) - #:crumbs - (list (crumb (C_ "website menu" "Packages") (guix-url "packages/")) - (crumb package-id - (guix-url (package-url-path package)))) - #:content - `(main - (article - (@ (class "page centered-block limit-width")) - (h2 ,package-id " " - (span - (@ (class "synopsis")) - ,(package-synopsis-shtml package))) - - ;; 'gnu-package?' might fetch stuff from the network. Assume #f if - ;; that doesn't work. - (p ,(if (false-if-exception (gnu-package? package)) - (G_ '(it "This is a GNU package. ")) - "") - ,(package-description-shtml package)) - - (ul - (@ (class "package-info")) - ,(G_ `(li ,(G_ `(b "Website: ")) - (a (@ (href ,(package-home-page package))) - ,(package-home-page package)))) - ,(G_ `(li ,(G_ `(b "License: ")) - ,(license->shtml (package-license package)))) - ,(G_ `(li ,(G_ `(b "Package source: ")) - ,(location->shtml (package-location package)))) - ,(G_ `(li ,(G_ `(b "Patches: ")) - ,(patches->shtml (package-patches package)))) - ,(G_ `(li ,(G_ `(b "Builds: ")) - ,(supported-systems->shtml package)))) - - ;; Lint issues. - ,(if (null? lint-issues) - "" - (G_ `(,(G_ `(h3 "Lint issues")) - ,(G_ - `(p - "" - ,(issue-count->shtml - (length lint-issues)) - ". " - "See " ,(G_ `(a (@ (href "#")) "package definition")) - " in Guix source code.")) - - ,@(map lint-issue->shtml lint-issues))))))))) diff --git a/website/apps/packages/types.scm b/website/apps/packages/types.scm deleted file mode 100644 index 2b777bf..0000000 --- a/website/apps/packages/types.scm +++ /dev/null @@ -1,109 +0,0 @@ -;;; GNU Guix web site -;;; Initially written by sirgazil who waives all -;;; copyright interest on this file. - -(define-module (apps packages types) - #:use-module (srfi srfi-9) - #:export (ilink - ilink? - ilink-name - ilink-url - lint-issue - lint-issue? - lint-issue-type - lint-issue-description)) - - -;;; -;;; Data types. -;;; - -;;; License (record type) -;;; --------------------- -;;; -;;; A license object represents a copyright license or public domain -;;; dedication. -;;; -;;; Objects of this type can be created with the "license" procedure -;;; as well (see Helper procedures below). -;;; -;;; Fields: -;;; -;;; name (string) -;;; The human readable name of the license. For example: "GPL 2+", -;;; "CC-BY-SA 3.0", etc. -;;; -;;; uri (string) -;;; The URL to the definition of the license on the web. -;;; -;;; comment (string) -;;; A comment about the license? -;;; -(define-record-type - (make-license name uri comment) - license? - (name license-name) - (uri license-uri) - (comment license-comment)) - -;;; Helper procedures. - -(define* (license #:key name uri (comment "")) - "Return a object with the given attributes." - (make-license name uri comment)) - - - -;;; ILink (record type) -;;; ------------------- -;;; -;;; A link to a web resource. -;;; -;;; Fields: -;;; -;;; name (string) -;;; A descriptive name for the link. For example: -;;; "i686 build", "graphics.scm", etc. -;;; -;;; url (string) -;;; The URL to the web resource. -;;; -(define-record-type - (ilink name url) - ilink? - (name ilink-name) - (url ilink-url)) - - - -;;; Lint Issue (record type) -;;; ------------------------ -;;; -;;; A lint issue object represents an issue reported by any of the lint -;;; checkers available for GNU Guix (see `guix lint --list-checkers`). -;;; -;;; Objects of this type can be created with the "lint-issue" procedure -;;; as well (see Helper procedures below). -;;; -;;; Fields: -;;; -;;; type (string) -;;; The name of the checker the issue belongs to. For example: -;;; "home-page", "license", "source", etc. -;;; -;;; See `guix lint --list-checkers` for all the names of the checkers. -;;; -;;; description (string) -;;; The details of the issue. -;;; -(define-record-type - (make-lint-issue type description) - lint-issue? - (type lint-issue-type) - (description lint-issue-description)) - -;;; Helper procedures. - -(define (lint-issue type description) - "Return a object with the given attributes." - (make-lint-issue type description)) diff --git a/website/apps/packages/utils.scm b/website/apps/packages/utils.scm deleted file mode 100644 index 50e56b0..0000000 --- a/website/apps/packages/utils.scm +++ /dev/null @@ -1,282 +0,0 @@ -;;; GNU Guix web site -;;; Copyright © 2017, 2022 Ludovic Courtès -;;; Copyright © 2017 Eric Bavier -;;; Copyright © 2020 Ricardo Wurmus -;;; -;;; 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 packages utils) - #:use-module (apps aux web) - #:use-module (apps base utils) - #:use-module (apps i18n) - #:use-module (apps packages data) - #:use-module (apps packages types) - #:use-module (guix packages) - #:use-module ((guix i18n) #:select (P_)) - #:use-module (guix utils) - #:use-module (guix build utils) - #:use-module (guix build download) - #:use-module (guix download) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) - #:use-module (sxml transform) - #:use-module (texinfo) - #:use-module (texinfo html) - #:use-module (ice-9 match) - #:use-module (ice-9 rdelim) - #:use-module (ice-9 popen) - #:use-module (web uri) - #:export (take-at-most - - package-description-shtml - package-synopsis-shtml - - location->ilink - package-build-issues - package-issues? - package-lint-issues - package-patches - package-url-path - packages/group-by-letter)) - - -;;; -;;; Helper procedures. -;;; - -(define (take-at-most lst max) - "Take up to MAX elements from LST." - (let loop ((lst lst) - (result '()) - (total 0)) - (match lst - (() - (reverse result)) - ((head . tail) - (if (>= total max) - (reverse result) - (loop tail (cons head result) (+ 1 total))))))) - -(define (texinfo->shtml texi) - "Parse TEXI, a string, and return the corresponding SHTML." - ;; 'texi-fragment->stexi' uses 'call-with-input-string', so make sure - ;; those string ports are Unicode-capable. - (with-fluids ((%default-port-encoding "UTF-8")) - (let ((shtml (stexi->shtml (texi-fragment->stexi texi)))) - (pre-post-order shtml - `((*ENTITY* - . ,(lambda (tag entity) - (match entity - ("nbsp" (string #\xa0)) - ("hellip" (string #\x2026)) - (_ " ")))) - (*default* - . ,(lambda args args)) - (*text* - . ,(lambda (_ txt) txt))))))) - -(define (package-description-shtml package) - "Return a SXML representation of PACKAGE description field with HTML -vocabulary." - (and=> (and=> (package-description package) P_) texinfo->shtml)) - -(define (package-synopsis-shtml package) - "Return a SXML representation of PACKAGE synopsis field with HTML -vocabulary." - (and=> (and=> (package-synopsis package) P_) - (lambda (synopsis) - ;; Strip the paragraph that 'texinfo->shtml' adds. - (match (texinfo->shtml synopsis) - (('div ('p text ...)) - text) - (text ;fishy description - text))))) - -(define git-description - (delay - (let* ((guix (find (lambda (p) - (file-exists? (string-append p "/guix/config.scm"))) - %load-path)) - (pipe (with-directory-excursion guix - (open-pipe* OPEN_READ "git" "describe"))) - (desc (read-line pipe)) - (git? (close-pipe pipe))) - (and (zero? git?) desc)))) - -(define (location->ilink loc) - "Convert the given location LOC into an Ilink. - - LOC () - A location object as defined in the GNU Guix API reference. - - RETURN () - An Ilink object as defined in (apps packages types)." - (ilink (basename (location-file loc)) - (guix-git-tree-url - (string-append (location-file loc) - (or (and=> (force git-description) - (cut string-append "?id=" <>)) - "") - "#n" - (number->string (location-line loc)))))) - - -;;; TODO: Stub. Implement. -;;; https://bitbucket.org/sirgazil/guixsd-website/issues/45/ -(define (package-build-issues package) - "Return the list of build issues for the given PACKAGE. - - PACKAGE () - A package object as defined in the GNU Guix API reference. - - RETURN (list) - A list of objects as defined in (apps packages types) - that represent build issues." - (list)) - - -;;; TODO: Add unit tests. -;;; https://bitbucket.org/sirgazil/guixsd-website/issues/44/ -(define (package-issues? package) - "Return true if the PACKAGE has lint or build issues. - - PACKAGE () - A package object as defined in the GNU Guix API reference." - (or (not (null? (package-lint-issues package))) - (not (null? (package-build-issues package))))) - - -;;; TODO: Stub. Implement. -;;; https://bitbucket.org/sirgazil/guixsd-website/issues/43/ -(define (package-lint-issues package) - "Return the list of lint issues for the given PACKAGE. - - PACKAGE () - A package object as defined in the GNU Guix API reference. - - RETURN (list) - A list of objects as defined in (apps packages types)." - (list)) - - -(define (package-patches package) - "Return the list of patches for the given PACKAGE. - - PACKAGE () - A package object as defined in the GNU Guix API reference. - - RETURN (list) - A list of objects as defined in (apps packages types) - representing patches." - (define patch-url - (match-lambda - ((? string? patch) - (string-append - "//git.savannah.gnu.org/cgit/guix.git/tree/gnu/packages/patches/" - (basename patch))) - ((? origin? patch) - (uri->string - (first (maybe-expand-mirrors (string->uri - (match (origin-uri patch) - ((? string? uri) uri) - ((head . tail) head))) - %mirrors)))) - (_ - ;; It might be a or some other file-like object. - #f))) - - (define patch-name - (match-lambda - ((? string? patch) - (basename patch)) - ((? origin? patch) - (match (origin-file-name patch) - (#f - (match (origin-uri patch) - ((? string? uri) (basename uri)) - ((head . tail) (basename head)))) - (file - file))))) - - (define (snippet-link) - (let* ((loc (or (package-field-location package 'source) - (package-location package))) - (link (location->ilink loc))) - (ilink "snippet" (ilink-url link)))) - - (define patches - (filter-map (lambda (patch) - (let ((url (patch-url patch))) - (and url - (ilink `(span (@ (class "mono")) ,(patch-name patch)) - (patch-url patch))))) - (match (package-source package) - (#f '()) - ((? origin? o) (origin-patches o))))) - - (define snippet - (match (package-source package) - (#f - #f) - ((? origin? o) - (and (origin-snippet o) - (snippet-link))))) - - (if snippet - (cons snippet patches) - patches)) - - -(define (package-url-path package) - "Return a URL path for the PACKAGE in the form packages/NAME-VERSION/. - - PACKAGE () - A package object as defined in the GNU Guix API reference." - (url-path-join "packages" - (string-append (package-name package) - "-" - (package-version package)))) - - -(define (packages/group-by-letter packages) - "Return a list of alphabetically grouped packages. - - PACKAGES (list) - A list of package objects as defined in the GNU Guix API reference. - - RETURN (list) - A list of lists of packages where each list corresponds to the - packages whose name starts with a specific letter." - (define (starts-with-digit? package) - (char-set-contains? char-set:digit - (string-ref (package-name package) 0))) - - (define (starts-with-letter? letter) - (let ((letter (string-downcase letter))) - (lambda (package) - (string-prefix? letter (package-name package))))) - - (map (lambda (letter) - (match letter - ("0-9" - (cons letter (filter starts-with-digit? packages))) - (_ - (cons letter - (filter (starts-with-letter? letter) packages))))) - alphabet)) diff --git a/website/haunt.scm b/website/haunt.scm index 01e2af7..455bdc8 100644 --- a/website/haunt.scm +++ b/website/haunt.scm @@ -7,7 +7,6 @@ ((apps download builder) #:prefix download:) (apps i18n) ((apps media builder) #:prefix media:) - ((apps packages builder) #:prefix packages:) (haunt asset) (haunt builder assets) (haunt reader) @@ -25,5 +24,4 @@ blog:builder download:builder media:builder - packages:builder (static-directory "static")))) diff --git a/website/tests/all.scm b/website/tests/all.scm index a984002..ae4fb1d 100644 --- a/website/tests/all.scm +++ b/website/tests/all.scm @@ -10,5 +10,4 @@ (tests apps aux system) (tests apps aux web) (tests apps base types) - (tests apps blog utils) - (tests apps packages utils)) + (tests apps blog utils)) diff --git a/website/tests/apps/packages/utils.scm b/website/tests/apps/packages/utils.scm deleted file mode 100644 index 4ee38b2..0000000 --- a/website/tests/apps/packages/utils.scm +++ /dev/null @@ -1,107 +0,0 @@ -;;; GNU Guix web site -;;; Initially written by sirgazil who waives all -;;; copyright interest on this file. - -(define-module (tests apps packages utils) - #:use-module (apps packages types) - #:use-module (apps packages utils) - #:use-module (guix packages) - #:use-module (srfi srfi-64)) - - -;;; -;;; Constants. -;;; - -(define SUITE_NAME "apps-packages-utils") - - - -;;; -;;; Test suite. -;;; - -(test-begin SUITE_NAME) - -;;; FIXME: Rewrite with real Guix packages in mind. -;;; -;; (test-group -;; "[procedure] package-issues?" - -;; (test-equal -;; "Return false if the package has no lint nor build issues." -;; (package-issues? (package #:name "arau")) -;; #false) - -;; (test-equal -;; "Return true if the package has lint issues." -;; (package-issues? (package #:name "arau" -;; #:lint-issues '((lint-issue "A" "...") -;; (lint-issue "B" "...") -;; (lint-issue "C" "...")))) -;; #true) - -;; (test-equal -;; "Return true if the package has build issues." -;; (package-issues? (package #:name "kiwi" #:build-issues '(""))) ; FIXME: Pass a real issue object. -;; #true)) - - -;;; FIXME: Rewrite with real Guix packages in mind. -;;; -;; (test-group -;; "[procedure] package-url-path" - -;; (test-equal -;; "Return the correct URL path to the package." -;; (package-url-path (package #:name "arau" #:version "1.0.0")) -;; "packages/arau-1.0.0")) - - -;;; FIXME: Rewrite with real Guix packages in mind. -;;; -;; (test-group -;; "[procedure] packages/group-by-letter" - -;; (test-equal -;; "Return an empty list if there are no packages." -;; (packages/group-by-letter '()) -;; '()) - -;; (test-equal -;; "Group packages by letter." -;; (packages/group-by-letter (list (package #:name "agua") -;; (package #:name "azul") -;; (package #:name "fuego") -;; (package #:name "tierra"))) -;; (list -;; (cons "0-9" '()) -;; (cons "A" (list (package #:name "agua") (package #:name "azul"))) -;; (cons "B" '()) -;; (cons "C" '()) -;; (cons "D" '()) -;; (cons "E" '()) -;; (cons "F" (list (package #:name "fuego"))) -;; (cons "G" '()) -;; (cons "H" '()) -;; (cons "I" '()) -;; (cons "J" '()) -;; (cons "K" '()) -;; (cons "L" '()) -;; (cons "M" '()) -;; (cons "N" '()) -;; (cons "O" '()) -;; (cons "P" '()) -;; (cons "Q" '()) -;; (cons "R" '()) -;; (cons "S" '()) -;; (cons "T" (list (package #:name "tierra"))) -;; (cons "U" '()) -;; (cons "V" '()) -;; (cons "W" '()) -;; (cons "X" '()) -;; (cons "Y" '()) -;; (cons "Z" '())))) - - -(test-end SUITE_NAME) base-commit: c9b6bc1993cd59648d393b840f116d11903a3184 -- 2.38.0