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   (lml-format "<a style=\"padding-left:20pt;\" href=\"~A\">~A</a>" url url))
  64
  65 (defun display-footer (dl-data)
  66   (when (dl-data-signed dl-data)
  67     (lml-princ "<h3>GPG Public Key</h3>")
  68     (lml-princ "Use this <a href=\"https://www.b9.com/kevin.gpg.asc\">key</a> to verify file signtatures"))
  69   (lml-princ "</div>"))
  70
  71 (defun print-sect-title (title dl-data)
  72   (lml-format "<h~D>~A</h~D>"
  73               (dl-data-indent dl-data) title (dl-data-indent dl-data)))
  74
  75 (defun match-base-name? (name base-name)
  76   (let ((len-base-name (length base-name)))
  77     (when (>= (length name) len-base-name)
  78       (string= name base-name :end1 len-base-name :end2 len-base-name))))
  79
  80 (defun match-base-name-latest? (name base-name)
  81   (let* ((latest (concatenate 'string base-name "-latest"))
  82          (len-latest (length latest)))
  83     (when (>= (length name) len-latest)
  84       (string= name latest :end1 len-latest :end2 len-latest))))
  85
  86 (defun filter-against-base (files base-name)
  87   (delete-if-not
  88    (lambda (f) (match-base-name? (pathname-name f) base-name))
  89    files))
  90
  91 (defun filter-latest (files base-name)
  92   (delete-if
  93    (lambda (f) (match-base-name-latest? (pathname-name f) base-name))
  94    files))
  95
  96 (defun sort-pathnames (list)
  97   (sort list (lambda (a b) (string< (namestring a) (namestring b)))))
  98
  99 (defun display-one-section (title pat dl-data)
 100   (let ((files (sort-pathnames
 101                 (filter-latest
 102                  (filter-against-base (directory pat) (dl-data-name dl-data))
 103                  (dl-data-name dl-data)))))
 104     (when files
 105       (print-sect-title title dl-data)
 106       (lml-princ "<div style=\"padding-left: 20pt;\">")
 107       (list-files files dl-data)
 108       (lml-princ "</div>"))))
 109
 110 (defun display-sections (sects dl-data)
 111   (when sects
 112     (let ((title (car sects))
 113           (value (cadr sects)))
 114       (if (consp title)
 115           (dolist (sect sects)
 116             (display-sections sect dl-data))
 117         (if (consp value)
 118             (progn
 119               (print-sect-title title dl-data)
 120               (incf (dl-data-indent dl-data))
 121               (display-sections value dl-data)
 122               (decf (dl-data-indent dl-data)))
 123           (display-one-section title value dl-data))))))
 124
 125 (defun display-page (pkg-name pkg-base dl-base dl-url sects)
 126   (let ((dl-data (make-dl-data :indent 3
 127                                :base dl-base
 128                                :url dl-url
 129                                :name pkg-base
 130                                :signed nil)))
 131     (display-header pkg-name dl-url)
 132     (dolist (sect sects)
 133       (display-sections sect dl-data))
 134     (display-footer dl-data)))
 135
 136 (defun std-dl-page (pkg-name pkg-base dl-base dl-url)
 137   (let ((base (parse-namestring dl-base)))
 138     (let ((tgz-path (make-pathname :defaults base :type "gz" :name :wild))
 139           (zip-path (make-pathname :defaults base :type "zip" :name :wild))
 140           (doc-path (make-pathname :defaults base :type "pdf" :name :wild)))
 141       (display-page pkg-name pkg-base dl-base dl-url
 142                     `(("Manual" ,doc-path)
 143                       ("Source Code"
 144                        (("Unix (.tar.gz)" ,tgz-path)
 145                         ("Windows (.zip)" ,zip-path))))))))
 146
 147 (defun full-dl-page (pkg-name pkg-base dl-base dl-url)
 148   (let ((base (parse-namestring dl-base)))
 149     (let ((tgz-path (make-pathname :defaults base :type "gz" :name :wild))
 150           (zip-path (make-pathname :defaults base :type "zip" :name :wild))
 151           (doc-path (make-pathname :defaults base :type "pdf" :name :wild))
 152           (deb-path (merge-pathnames
 153                      (make-pathname :directory '(:relative "linux-debian")
 154                                     :type :wild :name :wild)
 155                      base))
 156           (rpm-path (merge-pathnames
 157                      (make-pathname :directory '(:relative "linux-rpm")
 158                                     :type :wild :name :wild)
 159                      base))
 160           (w32-path (merge-pathnames
 161                      (make-pathname :directory '(:relative "win32")
 162                                     :type :wild :name :wild)
 163                      base)))
 164       (display-page pkg-name pkg-base dl-base dl-url
 165                     `(("Manual" ,doc-path)
 166                       ("Source Code"
 167                        (("Unix (.tar.gz)" ,tgz-path)
 168                         ("Windows (.zip)" ,zip-path)))
 169                       ("Binaries"
 170                        (("Linux Binaries"
 171                          (("Debian Linux" ,deb-path)
 172                           ("RedHat Linux" ,rpm-path)))
 173                         ("Windows Binaries" ,w32-path))))))))