downloads.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          downloads.lisp
   6 ;;;; Purpose:       Generate downloads page
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Aug 2002
   9 ;;;;
  10 ;;;; $Id$
  11 ;;;;
  12 ;;;; This file, part of LML2, is Copyright (c) 2000-2003 by Kevin Rosenberg.
  13 ;;;; Rights of modification and redistribution are in the LICENSE file.
  14 ;;;;
  15 ;;;; *************************************************************************
  16
  17 (in-package #:lml2)
  18
  19
  20 (defstruct dl-data base url name indent signed)
  21
  22 (defun list-files (files dl-data)
  23   "List files in a directory for downloading"
  24   ;;files.sort()
  25   (mapcar (lambda (f) (print-file f dl-data)) files))
  26
  27 (defun strip-dl-base (file base)
  28   (let ((fdir (pathname-directory file))
  29         (bdir (pathname-directory base)))
  30     (make-pathname
  31      :name (pathname-name file)
  32      :type (pathname-type file)
  33      :directory
  34      (when (> (length fdir) (length bdir))
  35        (append '(:absolute)
  36                (subseq fdir (length bdir) (length fdir)))))))
  37
  38 (defun print-file (file dl-data)
  39   (let ((size 0)
  40         (modtime (date-string (file-write-date file)))
  41         (basename (namestring
  42                    (make-pathname :name (pathname-name file)
  43                                   :type (pathname-type file))))
  44         (dl-name (strip-dl-base file (dl-data-base dl-data)))
  45         (sig-path (concatenate 'string (namestring file) ".asc")))
  46     (when (plusp (length basename))
  47       (with-open-file (strm file :direction :input)
  48                       (setq size (round (/ (file-length strm) 1024))))
  49       (lml-format "<a href=\"~A~A\">~A</a>"
  50                   (dl-data-url dl-data) dl-name basename)
  51       (lml-princ "<span class=\"modtime\">")
  52       (lml-format " (~A, <b>~:D <span style=\"font-size:90%;\">KB</span></b>)</span>" modtime size)
  53       (when (probe-file sig-path)
  54         (setf (dl-data-signed dl-data) t)
  55         (lml-format " [<a href=\"~A~A.asc\">Signature</a>]"
  56                     (dl-data-url dl-data) dl-name))
  57       (html :br))))
  58
  59 (defun display-header (name url)
  60   (lml-princ "<h1>Download</h1>")
  61   (lml-princ "<div class=\"mainbody\">")
  62   (lml-format "<h3>Browse ~A Download Site</h3>" name)
  63   (let ((*print-circle* nil))
  64     (lml-format "<a style=\"padding-left:20pt;\" href=\"~A\">~A</a>" url url)))
  65
  66 (defun display-footer (dl-data)
  67   (when (dl-data-signed dl-data)
  68     (lml-princ "<h3>GPG Public Key</h3>")
  69     (lml-princ "Use this <a href=\"https://www.b9.com/kevin.gpg.asc\">key</a> to verify file signtatures"))
  70   (lml-princ "</div>"))
  71
  72 (defun print-sect-title (title dl-data)
  73   (lml-format "<h~D>~A</h~D>"
  74               (dl-data-indent dl-data) title (dl-data-indent dl-data)))
  75
  76 (defun match-base-name? (name base-name)
  77   (let ((len-base-name (length base-name)))
  78     (when (>= (length name) len-base-name)
  79       (string= name base-name :end1 len-base-name :end2 len-base-name))))
  80
  81 (defun match-base-name-latest? (name base-name)
  82   (let* ((latest (concatenate 'string base-name "-latest"))
  83          (len-latest (length latest)))
  84     (when (>= (length name) len-latest)
  85       (string= name latest :end1 len-latest :end2 len-latest))))
  86
  87 (defun filter-against-base (files base-name)
  88   (delete-if-not
  89    (lambda (f) (match-base-name? (pathname-name f) base-name))
  90    files))
  91
  92 (defun filter-latest (files base-name)
  93   (delete-if
  94    (lambda (f) (match-base-name-latest? (pathname-name f) base-name))
  95    files))
  96
  97 (defun sort-pathnames (list)
  98   (sort list (lambda (a b) (string< (namestring a) (namestring b)))))
  99
 100 (defun display-one-section (title pat dl-data)
 101   (let ((files (sort-pathnames
 102                 (filter-latest
 103                  (filter-against-base (directory pat) (dl-data-name dl-data))
 104                  (dl-data-name dl-data)))))
 105     (when files
 106       (print-sect-title title dl-data)
 107       (lml-princ "<div style=\"padding-left: 20pt;\">")
 108       (list-files files dl-data)
 109       (lml-princ "</div>"))))
 110
 111 (defun display-sections (sects dl-data)
 112   (when sects
 113     (let ((title (car sects))
 114           (value (cadr sects)))
 115       (if (consp title)
 116           (dolist (sect sects)
 117             (display-sections sect dl-data))
 118         (if (consp value)
 119             (progn
 120               (print-sect-title title dl-data)
 121               (incf (dl-data-indent dl-data))
 122               (display-sections value dl-data)
 123               (decf (dl-data-indent dl-data)))
 124           (display-one-section title value dl-data))))))
 125
 126 (defun display-page (pkg-name pkg-base dl-base dl-url giturl gitweb sects)
 127   (let ((dl-data (make-dl-data :indent 3
 128                                :base dl-base
 129                                :url dl-url
 130                                :name pkg-base
 131                                :signed nil)))
 132     (display-header pkg-name dl-url)
 133     (dolist (sect sects)
 134       (display-sections sect dl-data))
 135     (when giturl
 136       (lml-format "<h2>Git Repository</h2><tt>~A</tt>" giturl)
 137       (when gitweb
 138         (lml-format "&nbsp;&nbsp;[<a href=\"~A\">Browse</a>]" gitweb)))
 139     (display-footer dl-data)))
 140
 141 (defun std-dl-page (pkg-name pkg-base dl-base dl-url &optional giturl gitweb)
 142   (let ((base (parse-namestring dl-base)))
 143     (let ((tgz-path (make-pathname :defaults base :type "gz" :name :wild))
 144           (zip-path (make-pathname :defaults base :type "zip" :name :wild))
 145           (doc-path (make-pathname :defaults base :type "pdf" :name :wild)))
 146       (display-page pkg-name pkg-base dl-base dl-url giturl gitweb
 147                     `(("Manual" ,doc-path)
 148                       ("Source Code"
 149                        (("Unix (.tar.gz)" ,tgz-path)
 150                         ("Windows (.zip)" ,zip-path))))))))
 151
 152 (defun full-dl-page (pkg-name pkg-base dl-base dl-url &optional giturl gitweb)
 153   (let ((base (parse-namestring dl-base)))
 154     (let ((tgz-path (make-pathname :defaults base :type "gz" :name :wild))
 155           (zip-path (make-pathname :defaults base :type "zip" :name :wild))
 156           (doc-path (make-pathname :defaults base :type "pdf" :name :wild))
 157           (deb-path (merge-pathnames
 158                      (make-pathname :directory '(:relative "linux-debian")
 159                                     :type :wild :name :wild)
 160                      base))
 161           (rpm-path (merge-pathnames
 162                      (make-pathname :directory '(:relative "linux-rpm")
 163                                     :type :wild :name :wild)
 164                      base))
 165           (w32-path (merge-pathnames
 166                      (make-pathname :directory '(:relative "win32")
 167                                     :type :wild :name :wild)
 168                      base))
 169           (mac-path (merge-pathnames
 170                      (make-pathname :directory '(:relative "mac")
 171                                     :type :wild :name :wild)
 172                      base))
 173           (linux-path (merge-pathnames
 174                      (make-pathname :directory '(:relative "linux")
 175                                     :type :wild :name :wild)
 176                      base)))
 177       (display-page pkg-name pkg-base dl-base dl-url giturl gitweb
 178                     `(("Manual" ,doc-path)
 179                       ("Source Code"
 180                        (("Unix (.tar.gz)" ,tgz-path)
 181                         ("Windows (.zip)" ,zip-path)))
 182                       ("Binaries"
 183                        (("Linux Binaries" ,linux-path)
 184                         ("Linux .deb Packages" ,deb-path)
 185                         ("Linux .rpm Packages" ,rpm-path)
 186                         ("Mac Binaries" ,mac-path)
 187                         ("Windows Binaries" ,w32-path))))))))