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