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