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 universal-time-to-apache-date (utime)
  35   (multiple-value-bind
  36         (second minute hour day-of-month month year day-of-week daylight-p zone)
  37       (decode-universal-time utime)
  38     (declare (ignore second day-of-week daylight-p zone))
  39     (format nil
  40             (formatter "~2,'0D-~3/kmrcl::monthname/-~4,'0D ~2,'0D:~2,'0D")
  41             day-of-month month year hour minute)))
  42
  43 (defun sort-dir-entries (entries sort-field direct)
  44   (case sort-field
  45     (:name
  46      (sort entries
  47            (lambda (a b)
  48              (funcall (if (eq direct :asc) #'string-lessp #'string-greaterp)
  49                       (aif (third a) it "")
  50                       (aif (third b) it "")))))
  51     (:modified
  52      (sort entries
  53            (lambda (a b)
  54              (funcall (if (eq direct :asc) #'< #'>)
  55                       (aif (fourth a) it 0)
  56                       (aif (fourth b) it 0)))))
  57     (:size
  58      (sort entries
  59            (lambda (a b)
  60              (funcall (if (eq direct :asc) #'< #'>)
  61                       (aif (fifth a) it 0)
  62                       (aif (fifth b) it 0)))))
  63     (:description
  64      (sort entries
  65            (lambda (a b)
  66              (funcall (if (eq direct :asc) #'string-lessp #'string-greaterp)
  67                       (aif (sixth a) it "")
  68                       (aif (sixth b) it "")))))
  69     (t
  70      entries)))
  71
  72 (defun write-html-apache-directory (stream title entries this-url &key parent address query-string
  73                                     icon-base)
  74   (let* ((query (when query-string (split-uri-query-string query-string)))
  75          (sort-field (if query
  76                          (cond
  77                            ((string-equal (caar query) "N") :name)
  78                            ((string-equal (caar query) "M") :modified)
  79                            ((string-equal (caar query) "S") :size)
  80                            ((string-equal (caar query) "D") :description)
  81                            (t :name))
  82                          :name))
  83          (dir (cond
  84                 ((and query (string-equal (cdr (first query)) "D") :desc))
  85                 (t :asc))))
  86     (setq entries (sort-dir-entries entries sort-field dir))
  87
  88     (html-stream
  89      stream
  90      "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.0 Transitional//EN\" \"http://www.w3.org/TR/REC-html40/loose.dtd\">"
  91      :newline
  92      (:html
  93       :newline
  94       (:head
  95        :newline
  96        (:title (:princ title)))
  97       :newline
  98       ((:body :bgcolor "#FFFFFF" :text "#000000")
  99        :newline
 100        (:table
 101         (:tr
 102          ((:td :bgcolor "#FFFFFF" :class "title")
 103           ((:font :size "+3" :face "Hevetica,Arial,sans-serif")
 104            (:b (:princ title))))))
 105        :newline
 106        (:pre
 107         (when icon-base
 108           (html-stream
 109            stream
 110            ((:img :border "0"
 111                   :src (format nil "~Ablank.png" icon-base)
 112                   :alt "     "))))
 113         " "
 114         ((:a :href (format nil "~A?N=~A" this-url
 115                            (if (and (eq sort-field :name) (eq dir :asc))
 116                                "D" "A")))
 117          "Name")
 118         (:princ (format nil "~20A" ""))
 119         " "
 120         ((:a :href (format nil "~A?M=~A" this-url
 121                            (if (and (eq sort-field :modified) (eq dir :asc))
 122                                "D" "A")))
 123          "Last modified")
 124         "      "
 125         ((:a :href (format nil "~A?S=~A" this-url
 126                            (if (and (eq sort-field :size) (eq dir :asc))
 127                                "D" "A")))
 128          "Size")
 129         "   "
 130         ((:a :href (format nil "~A?D=~A" this-url
 131                            (if (and (eq sort-field :description) (eq dir :asc))
 132                                "D" "A")))
 133          "Description")
 134         :newline
 135         (:princ "<hr noshade align=\"left\" width=\"80%\">")
 136         :newline
 137         (when parent
 138           (html-stream
 139            stream
 140            (when icon-base
 141              (html-stream
 142               stream
 143               ((:img :border "0"
 144                      :src (format nil "~Aback.png" icon-base
 145                                   :alt "[DIR]")))))
 146            " "
 147            (write-name-link stream (first parent) (second parent))
 148            " "
 149            (print-n-chars #\space 17 stream)
 150            "     -"
 151            :newline))
 152         (dolist (entry entries)
 153           (html-stream
 154            stream
 155            (when icon-base
 156              (html-stream
 157               stream
 158               ((:img :border "0"
 159                      :src
 160                      (case (car entry)
 161                        (:dir (format nil "~Afolder.png" icon-base))
 162                        (:text (format nil "~Atext.png" icon-base))
 163                        (t (format nil "~Af.png" icon-base)))
 164                      :alt
 165                      (case (car entry)
 166                        (:dir "[DIR]")
 167                        (:text "[TXT]")
 168                        (t "[FIL]"))))))
 169            " "
 170            (write-name-link stream (second entry) (third entry))
 171            " "
 172            (:princ (universal-time-to-apache-date (fourth entry)))
 173            (:princ
 174             (cond
 175               ((or (eq :dir (first entry))
 176                    (null (fifth entry)))
 177                "     -")
 178               ((< (fifth entry) (* 1024 1024))
 179                (format nil "~5,' Dk" (round (fifth entry) 1024)))
 180               ((< (fifth entry) (* 1024 1024 1024))
 181                (format nil "~5,' Dm" (round (fifth entry) (* 1024 1024))))
 182               (t
 183                (format nil "~5,' Dg" (round (fifth entry) (* 1024 1024 1024))))
 184               ))
 185            " "
 186            (:princ
 187             (if (sixth entry)
 188                 (sixth entry)
 189                 ""))
 190            :newline)))
 191        (:princ "<hr noshade align=\"left\" width=\"80%\">")
 192        :newline
 193        (when address
 194          (html-stream
 195           stream
 196           (:address address))))))))
 197