X-Git-Url: http://git.kpe.io/?p=lml.git;a=blobdiff_plain;f=2%2Fdownloads.lisp;fp=2%2Fdownloads.lisp;h=0000000000000000000000000000000000000000;hp=21473d15f8366b8bd585b2efc342ca9b58670975;hb=d69fd6931095af586a7ba72e0586330a436f0803;hpb=ffe053ab486b6e503513cf57f5321c61bd38b9c2 diff --git a/2/downloads.lisp b/2/downloads.lisp deleted file mode 100644 index 21473d1..0000000 --- a/2/downloads.lisp +++ /dev/null @@ -1,174 +0,0 @@ -;;;; -*- 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$ -;;;; -;;;; This file, part of LML2, is Copyright (c) 2000-2003 by Kevin Rosenberg. -;;;; Rights of modification and redistribution are in the LICENSE file. -;;;; -;;;; ************************************************************************* - -(in-package #:lml2) - - -(defstruct dl-data base url name indent signed) - -(defun list-files (files dl-data) - "List files in a directory for downloading" - ;;files.sort() - (mapcar (lambda (f) (print-file f dl-data)) files)) - -(defun strip-dl-base (file base) - (let ((fdir (pathname-directory file)) - (bdir (pathname-directory 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 dl-data) - (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 (dl-data-base dl-data))) - (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" - (dl-data-url dl-data) dl-name basename) - (lml-princ "") - (lml-format " (~A, ~:D KB)" modtime size) - (when (probe-file sig-path) - (setf (dl-data-signed dl-data) t) - (lml-format " [Signature]" - (dl-data-url dl-data) dl-name)) - (html :br)))) - -(defun display-header (name url) - (lml-princ "

Download

") - (lml-princ "
") - (lml-format "

Browse ~A Download Site

" name) - (let ((*print-circle* nil)) - (lml-format "~A" url url))) - -(defun display-footer (dl-data) - (when (dl-data-signed dl-data) - (lml-princ "

GPG Public Key

") - (lml-princ "Use this key to verify file signtatures")) - (lml-princ "
")) - -(defun print-sect-title (title dl-data) - (lml-format "~A" - (dl-data-indent dl-data) title (dl-data-indent dl-data))) - -(defun match-base-name? (name base-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 base-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 base-name) - (delete-if-not - (lambda (f) (match-base-name? (pathname-name f) base-name)) - files)) - -(defun filter-latest (files base-name) - (delete-if - (lambda (f) (match-base-name-latest? (pathname-name f) base-name)) - files)) - -(defun sort-pathnames (list) - (sort list (lambda (a b) (string< (namestring a) (namestring b))))) - -(defun display-one-section (title pat dl-data) - (let ((files (sort-pathnames - (filter-latest - (filter-against-base (directory pat) (dl-data-name dl-data)) - (dl-data-name dl-data))))) - (when files - (print-sect-title title dl-data) - (lml-princ "
") - (list-files files dl-data) - (lml-princ "
")))) - -(defun display-sections (sects dl-data) - (when sects - (let ((title (car sects)) - (value (cadr sects))) - (if (consp title) - (dolist (sect sects) - (display-sections sect dl-data)) - (if (consp value) - (progn - (print-sect-title title dl-data) - (incf (dl-data-indent dl-data)) - (display-sections value dl-data) - (decf (dl-data-indent dl-data))) - (display-one-section title value dl-data)))))) - -(defun display-page (pkg-name pkg-base dl-base dl-url sects) - (let ((dl-data (make-dl-data :indent 3 - :base dl-base - :url dl-url - :name pkg-base - :signed nil))) - (display-header pkg-name dl-url) - (dolist (sect sects) - (display-sections sect dl-data)) - (display-footer dl-data))) - -(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))))))))