2/apache-dir.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          lml2.asd
   6 ;;;; Purpose:       ASDF definition file for Lisp Markup Language Version 2
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Aug 2002
   9 ;;;;
  10 ;;;; $Id: lml2.asd 7061 2003-09-07 06:34:45Z kevin $
  11 ;;;;
  12 ;;;; This file, part of LML2, is Copyright (c) 2002 by Kevin M. Rosenberg
  13 ;;;;
  14 ;;;; LML2 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 #:lml2)
  20
  21 (defparameter *apache-name-width* 24)
  22
  23 (defun write-name-trailing-spaces (stream name)
  24   (let* ((spaces (- *apache-name-width* (length name))))
  25     (when (plusp spaces)
  26       (print-n-chars #\space spaces stream))))
  27
  28 (defun write-name-link (stream link name)
  29   (html-stream
  30    stream
  31    ((:a :href link) (:princ (string-maybe-shorten name *apache-name-width*))))
  32   (write-name-trailing-spaces stream name))
  33
  34 (defun sort-dir-entries (entries sort-field direct)
  35   (case sort-field
  36     (:name
  37      (sort entries
  38            (lambda (a b)
  39              (funcall (if (eq direct :asc) #'string-lessp #'string-greaterp)
  40                       (aif (third a) it "")
  41                       (aif (third b) it "")))))
  42     (:modified
  43      (sort entries
  44            (lambda (a b)
  45              (funcall (if (eq direct :asc) #'< #'>)
  46                       (aif (fourth a) it 0)
  47                       (aif (fourth b) it 0)))))
  48     (:size
  49      (sort entries
  50            (lambda (a b)
  51              (funcall (if (eq direct :asc) #'< #'>)
  52                       (aif (fifth a) it 0)
  53                       (aif (fifth b) it 0)))))
  54     (:description
  55      (sort entries
  56            (lambda (a b)
  57              (funcall (if (eq direct :asc) #'string-lessp #'string-greaterp)
  58                       (aif (sixth a) it "")
  59                       (aif (sixth b) it "")))))
  60     (t
  61      entries)))
  62
  63 (defun write-html-apache-directory (stream title entries this-url &key parent address query-string
  64                                     icon-base)
  65   (let* ((query (when query-string (split-uri-query-string query-string)))
  66          (sort-field (if query
  67                          (cond
  68                           ((string-equal (caar query) "N") :name)
  69                           ((string-equal (caar query) "M") :modified)
  70                           ((string-equal (caar query) "S") :size)
  71                           ((string-equal (caar query) "D") :description)
  72                           (t :name))
  73                        :name))
  74          (dir (cond
  75                ((and query (string-equal (cdr (first query)) "D") :desc))
  76                (t :asc))))
  77     (setq entries (sort-dir-entries entries sort-field dir))
  78
  79     (html-stream
  80      stream
  81      "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.0 Transitional//EN\" \"http://www.w3.org/TR/REC-html40/loose.dtd\">"
  82      :newline
  83      (:html
  84       :newline
  85       (:head
  86        :newline
  87        (:title (:princ title)))
  88       :newline
  89       ((:body :bgcolor "#FFFFFF" :text "#000000")
  90        :newline
  91        (:table
  92         (:tr
  93          ((:td :bgcolor "#FFFFFF" :class "title")
  94           ((:font :size "+3" :face "Hevetica,Arial,sans-serif")
  95            (:b (:princ title))))))
  96        :newline
  97        (:pre
  98         (when icon-base
  99           (html-stream
 100            stream
 101            ((:img :border "0"
 102                   :src (format nil "~Ablank.png" icon-base)
 103                   :alt "     "))))
 104         " "
 105         ((:a :href (format nil "~A?N=~A" this-url
 106                            (if (and (eq sort-field :name) (eq dir :asc))
 107                                "D" "A")))
 108          "Name")
 109         (:princ (format nil "~20A" ""))
 110         " "
 111         ((:a :href (format nil "~A?M=~A" this-url
 112                            (if (and (eq sort-field :modified) (eq dir :asc))
 113                                "D" "A")))
 114          "Last modified")
 115         "      "
 116         ((:a :href (format nil "~A?S=~A" this-url
 117                            (if (and (eq sort-field :size) (eq dir :asc))
 118                                "D" "A")))
 119          "Size")
 120         "   "
 121         ((:a :href (format nil "~A?D=~A" this-url
 122                            (if (and (eq sort-field :description) (eq dir :asc))
 123                                "D" "A")))
 124          "Description")
 125         :newline
 126         (:princ "<hr noshade align=\"left\" width=\"80%\">")
 127         :newline
 128         (when parent
 129           (html-stream
 130            stream
 131            (when icon-base
 132              (html-stream
 133               stream
 134               ((:img :border "0"
 135                      :src (format nil "~Aback.png" icon-base
 136                                   :alt "[DIR]")))))
 137            " "
 138            (write-name-link stream (first parent) (second parent))
 139            " "
 140            (print-n-chars #\space 17 stream)
 141            "     -"
 142            :newline))
 143         (dolist (entry entries)
 144           (html-stream
 145            stream
 146            (when icon-base
 147              (html-stream
 148               stream
 149               ((:img :border "0"
 150                      :src
 151                      (case (car entry)
 152                        (:dir (format nil "~Afolder.png" icon-base))
 153                        (:text (format nil "~Atext.png" icon-base))
 154                        (t (format nil "~Af.png" icon-base))]
 155                      :alt
 156                      (case (car entry)
 157                        (:dir "[DIR]")
 158                        (:text "[TXT]")
 159                        (t "[FIL]"))))))
 160               " "
 161            (write-name-link stream (second entry) (third entry))
 162            " "
 163            (:princ (universal-time-to-apache-date (fourth entry)))
 164            (:princ
 165             (cond
 166               ((or (eq :dir (first entry))
 167                    (null (fifth entry)))
 168                "     -")
 169               ((< (fifth entry) (* 1024 1024))
 170                (format nil "~5,' Dk" (round (fifth entry) 1024)))
 171               ((< (fifth entry) (* 1024 1024 1024))
 172                (format nil "~5,' Dm" (round (fifth entry) (* 1024 1024))))
 173               (t
 174                (format nil "~5,' Dg" (round (fifth entry) (* 1024 1024 1024))))
 175               ))
 176            " "
 177            (:princ
 178             (if (sixth entry)
 179                 (sixth entry)
 180                 ""))
 181            :newline)))
 182        (:princ "<hr noshade align=\"left\" width=\"80%\">")
 183        :newline
 184        (when address
 185          (html-stream
 186           stream
 187           (:address address))))))))
 188