From 4192e898a4256bab275f75d744969dfab8e06b6d Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Sun, 14 Jun 2015 20:52:42 +0200 Subject: list-packages: Move to guix-artwork repository. In order to integrate the package list in the GuixSD website, the listing of packages has been moved into the website implementation. * build-aux/list-packages.scm: Remove file. * Makefile.am (EXTRA_DIST): Adapt to it. --- build-aux/list-packages.scm | 450 -------------------------------------------- 1 file changed, 450 deletions(-) delete mode 100755 build-aux/list-packages.scm (limited to 'build-aux/list-packages.scm') diff --git a/build-aux/list-packages.scm b/build-aux/list-packages.scm deleted file mode 100755 index c4f445291b..0000000000 --- a/build-aux/list-packages.scm +++ /dev/null @@ -1,450 +0,0 @@ -#!/bin/sh -exec guile -l "$0" \ - -c '(apply (@ (list-packages) list-packages) - (cdr (command-line)))' -!# -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès -;;; Copyright © 2013 Alex Sassmannshausen -;;; -;;; This file is part of GNU Guix. -;;; -;;; GNU Guix is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; GNU Guix 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 General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Guix. If not, see . - -(define-module (list-packages) - #:use-module (guix utils) - #:use-module (guix packages) - #:use-module (guix licenses) - #:use-module (guix gnu-maintenance) - #:use-module ((guix download) #:select (%mirrors)) - #:use-module ((guix build download) #:select (maybe-expand-mirrors)) - #:use-module (gnu packages) - #:use-module (sxml simple) - #:use-module (sxml fold) - #:use-module (web uri) - #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:export (list-packages)) - -;;; Commentary: -;;; -;;; Emit an HTML representation of the packages available in GNU Guix. -;;; -;;; Code: - -(define lookup-gnu-package - (let ((gnu (official-gnu-packages))) - (lambda (name) - "Return the package description for GNU package NAME, or #f." - (find (lambda (package) - (equal? (gnu-package-name package) name)) - gnu)))) - -(define (list-join lst item) - "Join the items in LST by inserting ITEM between each pair of elements." - (let loop ((lst lst) - (result '())) - (match lst - (() - (match (reverse result) - (() - '()) - ((_ rest ...) - rest))) - ((head tail ...) - (loop tail - (cons* head item result)))))) - -(define (package->sxml package previous description-ids remaining) - "Return 3 values: the HTML-as-SXML for PACKAGE added to all previously -collected package output in PREVIOUS, a list of DESCRIPTION-IDS and the number -of packages still to be processed in REMAINING. Also Introduces a call to the -JavaScript prep_pkg_descs function as part of the output of PACKAGE, every -time the length of DESCRIPTION-IDS, increasing, is 15 or when REMAINING, -decreasing, is 1." - (define (location-url loc) - (string-append "http://git.savannah.gnu.org/cgit/guix.git/tree/" - (location-file loc) "#n" - (number->string (location-line loc)))) - - (define (source-url package) - (let ((loc (package-location package))) - (and loc (location-url loc)))) - - (define (license package) - (define ->sxml - (match-lambda - ((lst ...) - `(div ,(map ->sxml lst))) - ((? license? license) - (let ((uri (license-uri license))) - (case (and=> (and uri (string->uri uri)) uri-scheme) - ((http https) - `(div (a (@ (href ,uri) - (title "Link to the full license")) - ,(license-name license)))) - (else - `(div ,(license-name license) " (" - ,(license-comment license) ")"))))) - (#f ""))) - - (->sxml (package-license package))) - - (define (patches package) - (define patch-url - (match-lambda - ((? string? patch) - (string-append - "http://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)))))) - - (define patch-name - (match-lambda - ((? string? patch) - (basename patch)) - ((? origin? patch) - (match (origin-uri patch) - ((? string? uri) (basename uri)) - ((head . tail) (basename head)))))) - - (define (snippet-link snippet) - (let ((loc (or (package-field-location package 'source) - (package-location package)))) - `(a (@ (href ,(location-url loc)) - (title "Link to patch snippet")) - "snippet"))) - - (and (origin? (package-source package)) - (let ((patches (origin-patches (package-source package))) - (snippet (origin-snippet (package-source package)))) - (and (or (pair? patches) snippet) - `(div "patches: " - ,(let loop ((patches patches) - (number 1) - (links '())) - (match patches - (() - (let* ((additional (and snippet - (snippet-link snippet))) - (links (if additional - (cons additional links) - links))) - (list-join (reverse links) ", "))) - ((patch rest ...) - (loop rest - (+ 1 number) - (cons `(a (@ (href ,(patch-url patch)) - (title ,(string-append - "Link to " - (patch-name patch)))) - ,(number->string number)) - links)))))))))) - - (define (status package) - (define (url system) - `(a (@ (href ,(string-append "http://hydra.gnu.org/job/gnu/master/" - (package-full-name package) "." - system)) - (title "View the status of this architecture's build at Hydra")) - ,system)) - - `(div "status: " - ,(list-join (map url - (lset-intersection - string=? - %hydra-supported-systems - (package-transitive-supported-systems package))) - " "))) - - (define (package-logo name) - (and=> (lookup-gnu-package name) - gnu-package-logo)) - - (define (insert-tr description-id js?) - (define (insert-js-call description-ids) - "Return an sxml call to prep_pkg_descs, with up to 15 elements of -description-ids as formal parameters." - `(script (@ (type "text/javascript")) - ,(format #f "prep_pkg_descs(~a)" - (string-append "'" - (string-join description-ids "', '") - "'")))) - - (let ((description-ids (cons description-id description-ids))) - `(tr (td ,(if (gnu-package? package) - `(img (@ (src "/graphics/gnu-head-mini.png") - (alt "Part of GNU") - (title "Part of GNU"))) - "")) - (td (a (@ (href ,(source-url package)) - (title "Link to the Guix package source code")) - ,(package-name package) " " - ,(package-version package))) - (td (span ,(package-synopsis package)) - (div (@ (id ,description-id)) - ,(match (package-logo (package-name package)) - ((? string? url) - `(img (@ (src ,url) - (height "35") - (class "package-logo") - (alt ("Logo of " ,(package-name package)))))) - (_ #f)) - (p ,(package-description package)) - ,(license package) - (a (@ (href ,(package-home-page package)) - (title "Link to the package's website")) - ,(package-home-page package)) - ,(status package) - ,(patches package) - ,(if js? - (insert-js-call description-ids) - "")))))) - - (let ((description-id (symbol->string - (gensym (package-name package))))) - (cond ((= remaining 1) ; Last package in packages - (values - (reverse ; Fold has reversed packages - (cons (insert-tr description-id 'js) ; Prefix final sxml - previous)) - '() ; No more work to do - 0)) ; End of the line - ((= (length description-ids) 15) ; Time for a JS call - (values - (cons (insert-tr description-id 'js) - previous) ; Prefix new sxml - '() ; Reset description-ids - (1- remaining))) ; Reduce remaining - (else ; Insert another row, and build description-ids - (values - (cons (insert-tr description-id #f) - previous) ; Prefix new sxml - (cons description-id description-ids) ; Update description-ids - (1- remaining)))))) ; Reduce remaining - -(define (packages->sxml packages) - "Return an HTML page as SXML describing PACKAGES." - `(div - (h2 "GNU Guix Package List") - (div (@ (id "intro")) - (div - (img (@ (src "graphics/GuixSD-V.png") - (alt "Guix System Distribution") - (height "83")))) - (p "This web page lists the packages currently provided by the " - (a (@ (href "manual/guix.html#GNU-Distribution")) - "Guix System Distribution") - ". " - "Our " (a (@ (href "http://hydra.gnu.org/jobset/gnu/master")) - "continuous integration system") - " shows their current build status.")) - (table (@ (id "packages")) - (tr (th "GNU?") - (th "Package version") - (th "Package details")) - ,@(fold-values package->sxml packages '() '() (length packages))) - (a (@ (href "#intro") - (title "Back to top.") - (id "top")) - "^"))) - - -(define (insert-css) - "Return the CSS for the list-packages page." - (format #t -"")) - -(define (insert-js) - "Return the JavaScript for the list-packages page." - (format #t -"")) - - -(define (list-packages . args) - "Return an HTML page listing all the packages found in the GNU distribution, -with gnu.org server-side include and all that." - ;; Don't attempt to translate descriptions. - (setlocale LC_ALL "C") - - ;; Output the page as UTF-8 since that's what the gnu.org server-side - ;; headers claim. - (set-port-encoding! (current-output-port) "UTF-8") - - (let ((packages (sort (fold-packages cons '()) - (lambda (p1 p2) - (string - -GNU Guix - GNU Distribution - GNU Project -") - (insert-css) - (insert-js) - (format #t "") - - (sxml->xml (packages->sxml packages)) - (format #t " - -
- -

Please send general FSF & GNU inquiries to -<gnu@gnu.org>. -There are also other ways to contact -the FSF. Broken links and other corrections or suggestions can be sent -to <bug-guix@gnu.org>.

- -

Copyright © 2013 Free Software Foundation, Inc.

- -

This page is licensed under a Creative -Commons Attribution-NoDerivs 3.0 United States License.

- -

Updated: - -$Date$ - -

-
- - - -")) - ) - -;;; list-packages.scm ends here -- cgit v1.2.3