File: downloads.lisp

package info (click to toggle)
cl-lml2 1.6.6-4.1
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, sid
  • size: 184 kB
  • sloc: lisp: 1,316; makefile: 39
file content (178 lines) | stat: -rw-r--r-- 7,196 bytes parent folder | download | duplicates (3)
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
169
170
171
172
173
174
175
176
177
178
;;;; -*- 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 href=\"~A~A\">~A</a>"
                  (dl-data-url dl-data) 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)
        (setf (dl-data-signed dl-data) t)
        (lml-format " [<a href=\"~A~A.asc\">Signature</a>]"
                    (dl-data-url dl-data) dl-name))
      (html :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)
  (let ((*print-circle* nil))
    (lml-format "<a style=\"padding-left:20pt;\" href=\"~A\">~A</a>" url url)))

(defun display-footer (dl-data)
  (when (dl-data-signed dl-data)
    (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 dl-data)
  (lml-format "<h~D>~A</h~D>"
              (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 "<div style=\"padding-left: 20pt;\">")
      (list-files files dl-data)
      (lml-princ "</div>"))))

(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 giturl gitweb 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))
    (when giturl
      (lml-format "<h2>Git Repository</h2><tt>~A</tt>" giturl)
      (when gitweb
        (lml-format "&nbsp;&nbsp;[<a href=\"~A\">Browse</a>]" gitweb)))
    (display-footer dl-data)))

(defun std-dl-page (pkg-name pkg-base dl-base dl-url &optional giturl gitweb)
  (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 giturl gitweb
                    `(("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 &optional giturl gitweb)
  (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 giturl gitweb
                    `(("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))))))))