;;; call (process-blog-directory)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require 'osicat)
  (require 'cxml)
  (require 'cxml-stp)
  (require 'closure-html)
  (require 'drakma)
  (require 'ironclad)
  (require 'local-time)
  (require 'cl-fad)
  (require 'flexi-streams)
  (require 'cl-ppcre))

(defvar *input-directory* #p"/Users/pkhuong/Blog/")
(defvar *output-directory* #p"/Users/pkhuong/blosxom/entries/"
  "Pathname for the current output directory")
(defvar *resource-path* #p"/Users/pkhuong/Sites/Blog/resources/"
  "Pathname for the resource output directory")
(defvar *external-resource-path* "http://www.pvk.ca/Blog/resources"
  #+nil "file:///Users/pkhuong/Sites/Blog/resources"
  "Path to prepend to the resource files' names")

(defvar *resources* nil
  "Hash table of resource id string -> resource")
(defvar *file-resources* nil
  "Hash table of ``nice'' file name -> resource")

(defvar *local-resources* nil
  "Hash table of local resource name -> resource")
(defvar *entry-title* nil)
(defvar *entry-timestamp* nil
  "Universal time of the entry's creation")

(defun fix-universal-time (time)
  "Convert an DST-unaware universal time to a correct timestamp.
   Slightly wrong, but I don't expect to be publishing around the
   hour change."
  (let ((timestamp (local-time:universal-to-timestamp time)))
    (if (nth-value 1 (local-time:timestamp-subtimezone
                      timestamp
                      local-time:*default-timezone*))
        ;; DST is on
        (local-time:timestamp- timestamp 1 :hour)
        timestamp)))

(defstruct (resource
             (:constructor %make-resource (dest-name pathname)))
  ;; name of the output file
  dest-name
  pathname
  (timestamp nil)
  (count 0))

(defun file-name (name type)
  (if type
      (format nil "~A.~A" name type)
      (format nil "~A" name)))

(defun pathname-unix-string (pathname)
  (file-name (pathname-name pathname)
             (pathname-type pathname)))

(defun pathname-unix-type (pathname)
  (let* ((name (pathname-unix-string pathname))
         (dot  (position #\. name)))
    (and dot
         (subseq name (1+ dot)))))

(defun pathname-unix-name (pathname)
  (let ((name (pathname-unix-string pathname)))
    (subseq name 0 (position #\. name))))

(defun get-resource (hash path)
  (let* ((name (pathname-unix-name path))
         (type (pathname-unix-type path))
         (frobbed-name name))
    (loop for counter upfrom 0
          while (gethash (file-name frobbed-name type) *file-resources*)
          do (setf frobbed-name (format nil "~A-~A" name counter)))
    (let* ((filename (file-name frobbed-name type))
           (resource (%make-resource filename path)))
      (setf (gethash filename *file-resources*) resource
            (gethash hash *resources*)          resource))))

(defun register-resource-file (path)
  (let* ((hash      (file-name (ironclad:byte-array-to-hex-string
                                (ironclad:digest-file :sha256 path)
                                :element-type 'base-char)
                               (pathname-unix-type path)))
         (file-name (pathname-unix-string path))
         (resource  (or (gethash hash *resources*)
                        (get-resource hash path))))
    (setf (gethash file-name *local-resources*) resource)
    (when (and *entry-timestamp*
               (not (resource-timestamp resource)))
      (setf (resource-timestamp resource) *entry-timestamp*))
    path))

(defun find-resource (local-name)
  (let ((resource (gethash local-name *local-resources*)))
    (when resource
      (incf (resource-count resource))
      (format nil "~A/~A"
              *external-resource-path*
              (resource-dest-name resource)))))

(defun filename-pathname (name &optional defaults)
  (let ((dot (position #\. name :from-end t)))
    (multiple-value-bind (name type)
        (if dot
            (values (subseq name 0 dot)
                    (subseq name (1+ dot)))
            (values name nil))
      (make-pathname :name name :type type :defaults defaults))))

(defun copy-resources ()
  (ensure-directories-exist *resource-path*)
  (maphash (lambda (hash resource)
             (declare (ignore hash))
             (when (plusp (resource-count resource))
               (let ((dest (filename-pathname (resource-dest-name resource)
                                              *resource-path*))
                     (time (resource-timestamp resource)))
                 (cl-fad:copy-file (resource-pathname resource)
                                   dest
                                   :overwrite t)
                 (when time
                   (let ((unix-time (local-time:timestamp-to-unix time)))
                     (sb-posix:utimes dest unix-time unix-time))))))
           *resources*))

(defvar *css-lines* nil
  "Extendable vector of css entries")
(defvar *css-line-set* nil
  "Hash table of css entries")

(defun adjoin-css-line (line)
  (unless (gethash line *css-line-set*)
    (setf (gethash line *css-line-set*) t)
    (vector-push-extend line *css-lines*)))

(defun process-css-file (path)
  (with-open-file (s path
                     :element-type 'character
                     :external-format :iso-8859-1)
    (loop for line = (read-line s nil)
          while line
          do (adjoin-css-line line))))

(defvar *file-handlers* '()
  "List of handlers for regular files.")
(defvar *directory-handlers* '()
  "List of handlers for directories.")

(defun walk-directory (directory)
  (osicat:with-directory-iterator (it directory)
    (loop for file = (it)
          while file
          do
       (let ((path (merge-pathnames file directory)))
         (multiple-value-bind (handlers name type)
             (case (osicat:file-kind path :follow-symlinks t)
               (:regular-file
                  (values *file-handlers*
                          (pathname-name path)
                          (pathname-type path)))
               (:directory
                  (let* ((name (car (last (pathname-directory path))))
                         (type nil)
                         (dot  (position #\. name)))
                    (when dot
                      (setf type (subseq name (1+ dot))
                            name (subseq name 0 dot)))
                    (values *directory-handlers* name type))))
           (some (lambda (handler)
                   (funcall handler type name path))
                 handlers))))))

(defun default-directory-handler (type name path)
  (when (not type)   ; no dot in the directory
    (let ((*output-directory*
           (make-pathname
            :directory `(,@(pathname-directory *output-directory*)
                           ,name)
            :defaults *output-directory*)))
      (walk-directory path))
    t))

(defparameter *entity-cache* (make-hash-table))

(defun slurp-stream (stream)
  (let ((sequences  '())
        (size       1024)
        (total-size 0))
    (loop for sequence = (make-array size :element-type '(unsigned-byte 8))
          for len = (read-sequence sequence stream)
          do
       (incf total-size len)
       (cond ((= len size)
              (push sequence sequences)
              (incf size size))
             ((null sequences)
              (return (sb-kernel:%shrink-vector sequence len)))
             (t
              (let ((out (make-array total-size
                                     :element-type '(unsigned-byte 8))))
                (decf total-size len)
                (replace out sequence :start1 total-size)
                (dolist (sequence sequences)
                  (decf total-size (length sequence))
                  (replace out sequence :start1 total-size))
                (return out)))))))

(defun entity-resolver (pubid sysid)
  (declare (ignore pubid))
  (when (eq (puri:uri-scheme sysid) :http)
    (setf sysid (puri:intern-uri sysid))
    (flexi-streams:make-in-memory-input-stream
     (or (gethash sysid *entity-cache*)
         (let ((stream (drakma:http-request sysid :want-stream t)))
           (setf (gethash sysid *entity-cache*)
                 (slurp-stream stream)))))))

(defun string-begins-with (prefix string)
  (let ((mismatch (mismatch prefix string)))
    (or (not mismatch)
        (= mismatch (length prefix)))))

(defun parse-tex-file-for-metadata (path)
  (with-open-file (s path
                     :element-type 'character
                     :external-format :iso-8859-1)
    (loop for line = (read-line s nil)
          while line
          do
       (cond ((string-begins-with "\\date{" line)
              (setf *entry-timestamp*
                    (fix-universal-time
                     (parse-time
                      line
                      :start (1+ (position #\{ line))
                      :end   (position #\} line)))))
             ((string-begins-with "\\title{" line)
              (setf *entry-title*
                    (subseq line
                            (1+ (position #\{ line))
                            (position #\} line))))
             ((search "\\begin{document}" line)
              (return))))))

(defun tex-file-handler (type name path)
  (unless (and (equal type "tex")
               (not (equal name "_region_")))
    (return-from tex-file-handler nil))
  (let ((*entry-title* name)
        (*entry-timestamp*  (local-time:universal-to-timestamp
                             (file-write-date path)))
        (*local-resources* (make-hash-table :test #'equal))
        (output (make-pathname :directory `(,@(pathname-directory path)
                                             ,(format nil "~A.html-out" name)))))
    (parse-tex-file-for-metadata path)
    (when (or (not (cl-fad:directory-exists-p output))
              (<  (file-write-date output) (+ (file-write-date path) (* 5 60))))
      (cl-fad:delete-directory-and-files output :if-does-not-exist :ignore)
      (ensure-directories-exist output)
      (let ((files (make-hash-table :test 'equal))
            (cd    (make-pathname
                    :directory (pathname-directory path))))
        (setf (osicat:current-directory) cd)
        (dolist (file (cl-fad:list-directory cd))
          (setf (gethash (namestring file) files) file))
        (sb-ext:run-program "latex"
                            (list (namestring path))
                            :output *standard-output*
                            :search t :wait t)
        (sb-ext:run-program "latex"
                            (list (namestring path))
                            :output *standard-output*
                            :search t :wait t)
        (sb-ext:run-program "pdflatex"
                            (list "-output-directory" (namestring output)
                                  (namestring path))
                            :output *standard-output*
                            :search t :wait t)
        (sb-ext:run-program "htlatex"
                            (list (namestring path)
                                  "xhtml"
                                  ""
                                  (format nil "-cdvipng -d~A" (namestring output)))
                            :output *standard-output*
                            :search t :wait t)
        (dolist (file (cl-fad:list-directory cd))
          (unless (gethash (namestring file) files)
            (if (cl-fad:directory-pathname-p file)
                (cl-fad:delete-directory-and-files file)
                (delete-file file))))))
    (walk-directory-for-resources output)
    t))

(defun tex-directory-handler (type name path)
  (unless (equal type "tex-dir")
    (return-from tex-directory-handler nil))
  (let ((input (make-pathname :name name
                              :type "tex"
                              :defaults path)))
    (assert (cl-fad:file-exists-p input))
    (tex-file-handler "tex" name input)))

(defun txt-file-handler (type name path)
  (unless (equal type "txt")
    (return-from txt-file-handler nil))
  (let ((date (local-time:universal-to-timestamp
               (file-write-date path)))
        (dest (make-pathname :name name
                             :type "txt"
                             :defaults *output-directory*)))
    (ensure-directories-exist dest)
    (with-open-file (out dest
                         :element-type 'character
                         :external-format :iso-8859-1
                         :direction :output
                         :if-exists :supersede
                         :if-does-not-exist :create)
      (with-open-file (in path
                          :element-type 'character
                          :external-format :iso-8859-1)
        (loop for line = (read-line in nil)
              while line
              do
           (if (string-begins-with "#published " line)
               (setf date (fix-universal-time
                           (parse-time line
                                       :start (1+ (position #\Space line)))))
               (format out "~A~%" line)))))
    (let ((unix-time (local-time:timestamp-to-unix date)))
      (sb-posix:utimes dest unix-time unix-time)))
  t)

(defun walk-directory-for-resources (directory &key (html-file-p t))
  (let (html-path)
    (osicat:with-directory-iterator (it directory)
      (loop
        for file = (it)
        while file
        do
     (let ((full-path (merge-pathnames file)))
       (when (eq (osicat:file-kind file :follow-symlinks t)
                 :regular-file)
         (let ((type (pathname-type full-path)))
           (cond ((string= type "html")
                  ;; do this one last
                  (assert (not html-path))
                  (setf html-path full-path))
                 ((string= type "css")
                  (process-css-file full-path))
                 (t
                  (register-resource-file full-path))))))))
    (when html-file-p
      (assert html-path)
      (process-html-file html-path))))

(defun fixup-local-resources (document-root)
  (cxml-stp:do-recursively (node document-root)
    (flet ((replace-attribute (attribute)
             (let ((hashed (find-resource (cxml-stp:attribute-value
                                           node attribute))))
               (when hashed
                 (setf (cxml-stp:attribute-value node attribute) hashed)))))
      (when (typep node 'cxml-stp:element)
        (cond ((equal "img" (cxml-stp:local-name node))
               (replace-attribute "src"))
              ((equal "a" (cxml-stp:local-name node))
               (replace-attribute "href")))))))

(defclass no-short-form-sink (cxml::sink) ())

;; hack to avoid the short "/>" form for empty tags.
(defmethod sax:end-element ((sink no-short-form-sink) namespace-uri local-name qname)
  (declare (ignore namespace-uri local-name))
  (let ((tag (pop (cxml::stack sink))))
    (unless (cxml::tag-p tag)
      (error "output does not nest: not in an element"))
    (unless (cxml::rod= (cxml::tag-name tag) qname)
      (error "output does not nest: expected ~A but got ~A"
             (cxml::rod qname) (cxml::rod (cxml::tag-name tag))))
    (when (cxml::indentation sink)
      (cxml::end-indentation-block sink)
      (unless (zerop (cxml::tag-n-children tag))
        (cxml::sink-fresh-line sink)))
    (unless (cxml::tag-have-gt tag) ; close tag if needed
      (cxml::sink-write-rod '#.(cxml::string-rod ">") sink))
    (cxml::sink-write-rod '#.(cxml::string-rod "</") sink) ; and emit closing tag.
    (cxml::sink-write-rod qname sink)
    (cxml::sink-write-rod '#.(cxml::string-rod ">") sink)))

(defun stp-document-to-string (stp-node &optional encoding)
  (let ((encoding (or encoding :ascii))
        (ystream (cxml::make-rod-ystream)))
    (setf (cxml::ystream-encoding ystream)
          (runes:find-output-encoding encoding))
    (cxml-stp:serialize (cxml-stp:make-document stp-node)
                        (make-instance 'no-short-form-sink
                                       :ystream ystream
                                       :encoding encoding
                                       :omit-xml-declaration-p t)))
  #+nil
  (cl-ppcre:regex-replace-all
   "&#(10|13);"                         ; HACK! (:
   (cxml-stp:serialize (cxml-stp:make-document stp-node)
                       (cxml:make-string-sink
                        #+nil :indentation #+nil 1
                        :omit-xml-declaration-p t
                        ;; no short closing tag
                        :canonical t))
   (string #\Newline)))

(defun print-body (string out)
  (with-input-from-string (in string)
    (loop for line = (read-line in nil)
          while line
          do (let ((pos (search "<body" line)))
               (when pos
                 (let ((last (position #\> line :start (1+ pos))))
                   (when last
                     (format out "~A~%" (subseq line (1+ last)))))
                 (return))))
    (loop for line = (read-line in nil)
          while line
          do (let ((pos (search "</body>" line)))
               (when pos
                 (format out "~A~%" (subseq line 0 pos))
                 (return))
               (format out "~A~%" line)))))

(defun process-html-file (html-path)
  (let* ((stp (cxml:parse html-path (cxml-stp:make-builder)
                          :entity-resolver #'entity-resolver))
         (body (cxml-stp:find-recursively-if
                (lambda (x)
                  (and (typep x 'cxml-stp:element)
                       (equal "body" (cxml-stp:local-name x))))
                stp))
         (dest (make-pathname :name (pathname-name html-path)
                              :type "txt"
                              :defaults *output-directory*)))
    (fixup-local-resources stp)
    (cxml-stp:detach body)
    (ensure-directories-exist dest)
    (with-open-file (out dest
                         :element-type 'character
                         :external-format :utf-8
                         :direction :output
                         :if-does-not-exist :create
                         :if-exists :supersede)
      (format out "~A~%" *entry-title*)
      (print-body (stp-document-to-string body) out))
    (let ((unix-time (local-time:timestamp-to-unix *entry-timestamp*)))
      (sb-posix:utimes dest unix-time unix-time))))

(defun process-blog-directory (&key
                              (directory *input-directory*)
                              (output *output-directory*)
                              ((:resource-path *resource-path*)
                               *resource-path*)
                              ((:external-path *external-resource-path*)
                               *external-resource-path*))
  (let ((*output-directory* (pathname output))
        (*resources*        (make-hash-table :test #'equal))
        (*file-resources*   (make-hash-table :test #'equal))
        (*css-lines*        (make-array 256
                                        :adjustable t
                                        :fill-pointer 0))
        (*css-line-set*     (make-hash-table :test #'equal))
        (*file-handlers*    '(tex-file-handler txt-file-handler))
        (*directory-handlers* '(tex-directory-handler
                                default-directory-handler)))
    (cl-fad:delete-directory-and-files *output-directory*
                                       :if-does-not-exist :ignore)
    (cl-fad:delete-directory-and-files *resource-path*
                                       :if-does-not-exist :ignore)
    (ensure-directories-exist *output-directory*)
    (ensure-directories-exist *resource-path*)
    (walk-directory (pathname directory))
    (copy-resources)
    (with-open-file (out (make-pathname :name "latex"
                                        :type "css"
                                        :defaults *resource-path*)
                         :element-type 'character
                         :external-format :iso-8859-1
                         :direction :output
                         :if-exists :supersede
                         :if-does-not-exist :create)
      (map nil (lambda (line)
                 (format out "~A~%" line))
           *css-lines*))
    (values)))

;;;; Parse time


;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;

;;; It was subsequently borrowed and modified slightly by Daniel
;;; Barlow <dan@telent.net> to become part of the net-telent-date
;;; package.  Daniel, Tue May 22 05:45:27 BST 2001

;;; **********************************************************************

;;; Parsing routines for time and date strings. PARSE-TIME returns the
;;; universal time integer for the time and/or date given in the string.

;;; Written by Jim Healy, June 1987.

;;; **********************************************************************

(defvar whitespace-chars '(#\space #\tab #\newline #\, #\' #\`))
(defvar time-dividers '(#\: #\.))
(defvar date-dividers '(#\\ #\/ #\-))

(defvar *error-on-mismatch* nil
  "If t, an error will be signalled if parse-time is unable
   to determine the time/date format of the string.")

;;; Set up hash tables for month, weekday, zone, and special strings.
;;; Provides quick, easy access to associated information for these items.

;;; Hashlist takes an association list and hashes each pair into the
;;; specified tables using the car of the pair as the key and the cdr as
;;; the data object.

(defmacro hashlist (list table)
  `(dolist (item ,list)
     (setf (gethash (car item) ,table) (cdr item))))

(defparameter weekday-table-size 23)
(defparameter month-table-size 31)
(defparameter zone-table-size 11)
(defparameter special-table-size 11)

(defvar *weekday-strings* (make-hash-table :test #'equal
					 :size weekday-table-size))

(defvar *month-strings* (make-hash-table :test #'equal
				       :size month-table-size))

(defvar *zone-strings* (make-hash-table :test #'equal
				      :size zone-table-size))

(defvar *special-strings* (make-hash-table :test #'equal
					 :size special-table-size))

;;; Load-time creation of the hash tables.

(hashlist '(("monday" . 0)    ("mon" . 0)
	    ("tuesday" . 1)   ("tues" . 1)   ("tue" . 1)
	    ("wednesday" . 2) ("wednes" . 2) ("wed" . 2)
	    ("thursday" . 3)  ("thurs" . 3)  ("thu" . 3)
	    ("friday" . 4)    ("fri" . 4)
	    ("saturday" . 5)  ("sat" . 5)
	    ("sunday" . 6)    ("sun" . 6))
	  *weekday-strings*)

(hashlist '(("january" . 1)   ("jan" . 1)
	    ("february" . 2)  ("feb" . 2)
	    ("march" . 3)     ("mar" . 3)
	    ("april" . 4)     ("apr" . 4)
	    ("may" . 5)       ("june" . 6)
	    ("jun" . 6)       ("july" . 7)
	    ("jul" . 7)	      ("august" . 8)
	    ("aug" . 8)       ("september" . 9)
	    ("sept" . 9)      ("sep" . 9)
	    ("october" . 10)  ("oct" . 10)
	    ("november" . 11) ("nov" . 11)
	    ("december" . 12) ("dec" . 12))
	  *month-strings*)

(hashlist '(("gmt" . 0) ("est" . 5)
	    ("edt" . 4) ("cst" . 6)
	    ("cdt" . 5) ("mst" . 7)
	    ("mdt" . 6)	("pst" . 8)
	    ("pdt" . 7)) 
	  *zone-strings*)

(hashlist '(("yesterday" . yesterday)  ("today" . today)
	    ("tomorrow" . tomorrow)   ("now" . now))
	  *special-strings*)

;;; Time/date format patterns are specified as lists of symbols repre-
;;; senting the elements.  Optional elements can be specified by
;;; enclosing them in parentheses.  Note that the order in which the
;;; patterns are specified below determines the order of search.

;;; Choices of pattern symbols are: second, minute, hour, day, month,
;;; year, time-divider, date-divider, am-pm, zone, izone, weekday,
;;; noon-midn, and any special symbol.

(defparameter *default-date-time-patterns*
  '( 
     ;; Date formats.
    ((weekday) month (date-divider) day (date-divider) year (noon-midn))
    ((weekday) day (date-divider) month (date-divider) year (noon-midn))
    ((weekday) month (date-divider) day (noon-midn))
    (year (date-divider) month (date-divider) day (noon-midn))
    (month (date-divider) year (noon-midn))
    (year (date-divider) month (noon-midn))

    ((noon-midn) (weekday) month (date-divider) day (date-divider) year)
    ((noon-midn) (weekday) day (date-divider) month (date-divider) year)
    ((noon-midn) (weekday) month (date-divider) day)
    ((noon-midn) year (date-divider) month (date-divider) day)
    ((noon-midn) month (date-divider) year)
    ((noon-midn) year (date-divider) month)

     ;; Time formats.
    (hour (time-divider) (minute) (time-divider) (secondp) (am-pm) 
	  (date-divider) (zone))
    (noon-midn)
    (hour (noon-midn))

     ;; Time/date combined formats.
    ((weekday) month (date-divider) day (date-divider) year
	   hour (time-divider) (minute) (time-divider) (secondp)
	   (am-pm) (date-divider) (zone))
    ((weekday) day (date-divider) month (date-divider) year
	 hour (time-divider) (minute) (time-divider) (secondp)
	 (am-pm) (date-divider) (zone))
    ((weekday) month (date-divider) day
	   hour (time-divider) (minute) (time-divider) (secondp)
	   (am-pm) (date-divider) (zone))
    (year (date-divider) month (date-divider) day
	  hour (time-divider) (minute) (time-divider) (secondp)
	  (am-pm) (date-divider) (zone))
    (month (date-divider) year
	   hour (time-divider) (minute) (time-divider) (secondp)
	   (am-pm) (date-divider) (zone))
    (year (date-divider) month
	  hour (time-divider) (minute) (time-divider) (secondp)
	  (am-pm) (date-divider) (zone))

    (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
	  (date-divider) (zone) (weekday) month (date-divider)
	  day (date-divider) year)
    (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
	  (date-divider) (zone) (weekday) day (date-divider)
	  month (date-divider) year)
    (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
	  (date-divider) (zone) (weekday) month (date-divider)
	  day)
    (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
	  (date-divider) (zone) year (date-divider) month
	  (date-divider) day)
    (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
	  (date-divider) (zone) month (date-divider) year)
    (hour (time-divider) (minute) (time-divider) (secondp) (am-pm)
	  (date-divider) (zone) year (date-divider) month)

     ;; Weird, non-standard formats.
    (weekday month day hour (time-divider) minute (time-divider)
	     secondp (am-pm)
	     (zone) year)
    ((weekday) day (date-divider) month (date-divider) year hour
     (time-divider) minute (time-divider) (secondp) (am-pm)
     (date-divider) (zone))
    ((weekday) month (date-divider) day (date-divider) year hour
     (time-divider) minute (time-divider) (secondp) (am-pm)
     (date-divider) (zone))

    ;; Special-string formats.
    (now (yesterday))
    ((yesterday) now)
    (now (today))
    ((today) now)
    (now (tomorrow))
    ((tomorrow) now)
    (yesterday (noon-midn))
    ((noon-midn) yesterday)
    (today (noon-midn))
    ((noon-midn) today)
    (tomorrow (noon-midn))
    ((noon-midn) tomorrow)
))

;;; HTTP header style date/time patterns: RFC1123/RFC822, RFC850, ANSI-C.
(defparameter *http-date-time-patterns*
  '( 
     ;; RFC1123/RFC822 and RFC850.
    ((weekday) day (date-divider) month (date-divider) year
     hour time-divider minute (time-divider) (secondp) izone)
    ((weekday) day (date-divider) month (date-divider) year
     hour time-divider minute (time-divider) (secondp) (zone))

     ;; ANSI-C.
    ((weekday) month day
     hour time-divider minute (time-divider) (secondp) year)))


;;; The decoded-time structure holds the time/date values which are
;;; eventually passed to 'encode-universal-time' after parsing.

;;; Note: Currently nothing is done with the day of the week.  It might
;;; be appropriate to add a function to see if it matches the date.

(defstruct decoded-time
  (second 0    :type integer)    ; Value between 0 and 59.
  (minute 0    :type integer)    ; Value between 0 and 59.
  (hour   0    :type integer)    ; Value between 0 and 23.
  (day    1    :type integer)    ; Value between 1 and 31.
  (month  1    :type integer)    ; Value between 1 and 12.
  (year   1900 :type integer)    ; Value above 1899 or between 0 and 99.
  (zone   0    :type rational)   ; Value between -24 and 24 inclusive.
  (dotw   0    :type integer))   ; Value between 0 and 6.

;;; Make-default-time returns a decoded-time structure with the default
;;; time values already set.  The default time is currently 00:00 on
;;; the current day, current month, current year, and current time-zone.

(defun make-default-time (def-sec def-min def-hour def-day
			   def-mon def-year def-zone def-dotw)
  (let ((default-time (make-decoded-time)))
    (multiple-value-bind (sec min hour day mon year dotw dst zone)
			 (get-decoded-time)
      (declare (ignore dst))
      (if def-sec
	  (if (eq def-sec :current)
	      (setf (decoded-time-second default-time) sec)
	      (setf (decoded-time-second default-time) def-sec))
	  (setf (decoded-time-second default-time) 0))
      (if def-min
	  (if (eq def-min :current)
	      (setf (decoded-time-minute default-time) min)
	      (setf (decoded-time-minute default-time) def-min))
	  (setf (decoded-time-minute default-time) 0))
      (if def-hour
	  (if (eq def-hour :current)
	      (setf (decoded-time-hour default-time) hour)
	      (setf (decoded-time-hour default-time) def-hour))
	  (setf (decoded-time-hour default-time) 0))
      (if def-day
	  (if (eq def-day :current)
	      (setf (decoded-time-day default-time) day)
	      (setf (decoded-time-day default-time) def-day))
	  (setf (decoded-time-day default-time) day))
      (if def-mon
	  (if (eq def-mon :current)
	      (setf (decoded-time-month default-time) mon)
	      (setf (decoded-time-month default-time) def-mon))
	  (setf (decoded-time-month default-time) mon))
      (if def-year
	  (if (eq def-year :current)
	      (setf (decoded-time-year default-time) year)
	      (setf (decoded-time-year default-time) def-year))
	  (setf (decoded-time-year default-time) year))
      (if def-zone
	  (if (eq def-zone :current)
	      (setf (decoded-time-zone default-time) zone)
	      (setf (decoded-time-zone default-time) def-zone))
	  (setf (decoded-time-zone default-time) zone))
      (if def-dotw
	  (if (eq def-dotw :current)
	      (setf (decoded-time-dotw default-time) dotw)
	      (setf (decoded-time-dotw default-time) def-dotw))
	  (setf (decoded-time-dotw default-time) dotw))
      default-time)))

;;; Converts the values in the decoded-time structure to universal time
;;; by calling encode-universal-time.
;;; If zone is in numerical form, tweeks it appropriately.

(defun convert-to-unitime (parsed-values)
  (let ((zone (decoded-time-zone parsed-values)))
    (encode-universal-time (decoded-time-second parsed-values)
			   (decoded-time-minute parsed-values)
			   (decoded-time-hour parsed-values)
			   (decoded-time-day parsed-values)
			   (decoded-time-month parsed-values)
			   (decoded-time-year parsed-values)
			   (if (or (> zone 24) (< zone -24))
			       (let ((new-zone (/ zone 100)))
				 (cond ((minusp new-zone) (- new-zone))
				       ((plusp new-zone) (- 24 new-zone))
				       ;; must be zero (GMT)
				       (t new-zone)))
			       zone))))

;;; Sets the current values for the time and/or date parts of the 
;;; decoded time structure.

(defun set-current-value (values-structure &key (time nil) (date nil)
						(zone nil))
  (multiple-value-bind (sec min hour day mon year dotw dst tz)
      (get-decoded-time)
    (declare (ignore dst))
    (when time
      (setf (decoded-time-second values-structure) sec)
      (setf (decoded-time-minute values-structure) min)
      (setf (decoded-time-hour values-structure) hour))
    (when date
      (setf (decoded-time-day values-structure) day)
      (setf (decoded-time-month values-structure) mon)
      (setf (decoded-time-year values-structure) year)
      (setf (decoded-time-dotw values-structure) dotw))
    (when zone
      (setf (decoded-time-zone values-structure) tz))))

;;; Special function definitions.  To define a special substring, add
;;; a dotted pair consisting of the substring and a symbol in the
;;; *special-strings* hashlist statement above.  Then define a function
;;; here which takes one argument- the decoded time structure- and
;;; sets the values of the structure to whatever is necessary.  Also,
;;; add a some patterns to the patterns list using whatever combinations
;;; of special and pre-existing symbols desired.

(defun yesterday (parsed-values)
  (set-current-value parsed-values :date t :zone t)
  (setf (decoded-time-day parsed-values)
	(1- (decoded-time-day parsed-values))))

(defun today (parsed-values)
  (set-current-value parsed-values :date t :zone t))

(defun tomorrow (parsed-values)
  (set-current-value parsed-values :date t :zone t)
  (setf (decoded-time-day parsed-values)
	(1+ (decoded-time-day parsed-values))))

(defun now (parsed-values)
  (set-current-value parsed-values :time t))

;;; Predicates for symbols.  Each symbol has a corresponding function
;;; defined here which is applied to a part of the datum to see if
;;; it matches the qualifications.

(defun am-pm (string)
  (and (simple-string-p string)
       (cond ((string= string "am") 'am)
	     ((string= string "pm") 'pm)
	     (t nil))))

(defun noon-midn (string)
  (and (simple-string-p string)
       (cond ((string= string "noon") 'noon)
	     ((string= string "midnight") 'midn)
	     (t nil))))

(defun weekday (string)
  (and (simple-string-p string) (gethash string *weekday-strings*)))

(defun month (thing)
  (or (and (simple-string-p thing) (gethash thing *month-strings*))
      (and (integerp thing) (<= 1 thing 12))))

(defun zone (thing)
  (or (and (simple-string-p thing) (gethash thing *zone-strings*))
      (if (integerp thing)
	  (let ((zone (/ thing 100)))
	    (and (integerp zone) (<= -24 zone 24))))))

;;; Internet numerical time zone, e.g. RFC1123, in hours and minutes.
(defun izone (thing)
  (if (integerp thing)
      (multiple-value-bind (hours mins)
	  (truncate thing 100)
	(and (<= -24 hours 24) (<= -59 mins 59)))))

(defun special-string-p (string)
  (and (simple-string-p string) (gethash string *special-strings*)))

(defun secondp (number)
  (and (integerp number) (<= 0 number 59)))

(defun minute (number)
  (and (integerp number) (<= 0 number 59)))

(defun hour (number)
  (and (integerp number) (<= 0 number 23)))

(defun day (number)
  (and (integerp number) (<= 1 number 31)))

(defun year (number)
  (and (integerp number)
       (or (<= 0 number 99)
	   (<= 1900 number))))

(defun time-divider (character)
  (and (characterp character)
       (member character time-dividers :test #'char=)))

(defun date-divider (character)
  (and (characterp character)
       (member character date-dividers :test #'char=)))

;;; Match-substring takes a string argument and tries to match it with
;;; the strings in one of the four hash tables: *weekday-strings*, *month-
;;; strings*, *zone-strings*, *special-strings*.  It returns a specific
;;; keyword and/or the object it finds in the hash table.  If no match
;;; is made then it immediately signals an error.

(defun match-substring (substring)
  (let ((substring (nstring-downcase substring)))
    (or (let ((test-value (month substring)))
	  (if test-value (cons 'month test-value)))
	(let ((test-value (weekday substring)))
	  (if test-value (cons 'weekday test-value)))
	(let ((test-value (am-pm substring)))
	  (if test-value (cons 'am-pm test-value)))
	(let ((test-value (noon-midn substring)))
	  (if test-value (cons 'noon-midn test-value)))
	(let ((test-value (zone substring)))
	  (if test-value (cons 'zone test-value)))
	(let ((test-value (special-string-p substring)))
	  (if test-value  (cons 'special test-value)))
	(if *error-on-mismatch*
	    (error "\"~A\" is not a recognized word or abbreviation."
		   substring)
	    (return-from match-substring nil)))))

;;; Decompose-string takes the time/date string and decomposes it into a
;;; list of alphabetic substrings, numbers, and special divider characters.
;;; It matches whatever strings it can and replaces them with a dotted pair
;;; containing a symbol and value.

(defun decompose-string (string &key (start 0) (end (length string)) (radix 10))
  (do ((string-index start)
       (next-negative nil)
       (parts-list nil))
      ((eql string-index end) (nreverse parts-list))
    (let ((next-char (char string string-index))
	  (prev-char (if (= string-index start)
			 nil
			 (char string (1- string-index)))))
      (cond ((alpha-char-p next-char)
	     ;; Alphabetic character - scan to the end of the substring.
	     (do ((scan-index (1+ string-index) (1+ scan-index)))
		 ((or (eql scan-index end)
		      (not (alpha-char-p (char string scan-index))))
		  (let ((match-symbol (match-substring
				       (subseq string string-index scan-index))))
		    (if match-symbol
			(push match-symbol parts-list)
			(return-from decompose-string nil)))
		  (setf string-index scan-index))))
	    ((digit-char-p next-char radix)
	     ;; Numeric digit - convert digit-string to a decimal value.
	     (do ((scan-index string-index (1+ scan-index))
		  (numeric-value 0 (+ (* numeric-value radix)
				      (digit-char-p (char string scan-index) radix))))
		 ((or (eql scan-index end)
		      (not (digit-char-p (char string scan-index) radix)))
		  ;; If next-negative is t, set the numeric value to it's
		  ;; opposite and reset next-negative to nil.
		  (when next-negative
		    (setf next-negative nil)
		    (setf numeric-value (- numeric-value)))
		  (push numeric-value parts-list)
		  (setf string-index scan-index))))
	    ((and (or (char= next-char #\-)
                      (char= next-char #\+))
		  (or (not prev-char)
		      (member prev-char whitespace-chars :test #'char=)))
	     ;; If we see a minus or plus sign before a number, but
	     ;; not after one, it is not a date divider, but an offset
	     ;; from GMT, so set next-negative to t if minus and
	     ;; continue.
	     (and (char= next-char #\-)
                  (setf next-negative t))
	     (incf string-index))    
	    ((member next-char time-dividers :test #'char=)
 	     ;; Time-divider - add it to the parts-list with symbol.
	     (push (cons 'time-divider next-char) parts-list)
	     (incf string-index))
	    ((member next-char date-dividers :test #'char=)
	     ;; Date-divider - add it to the parts-list with symbol.
	     (push (cons 'date-divider next-char) parts-list)
	     (incf string-index))
	    ((member next-char whitespace-chars :test #'char=)
	     ;; Whitespace character - ignore it completely.
	     (incf string-index))
	    ((char= next-char #\()
	     ;; Parenthesized string - scan to the end and ignore it.
	     (do ((scan-index string-index (1+ scan-index)))
		 ((or (eql scan-index end)
		      (char= (char string scan-index) #\)))
 		  (setf string-index (1+ scan-index)))))
	    (t
	     ;; Unrecognized character - barf voraciously.
	     (if *error-on-mismatch*
		 (error
		  'simple-error
		  :format-control "Can't parse time/date string.~%>>> ~A~
				   ~%~VT^-- Bogus character encountered here."
		  :format-arguments (list string (+ string-index 4)))
		 (return-from decompose-string nil)))))))

;;; Match-pattern-element tries to match a pattern element with a datum
;;; element and returns the symbol associated with the datum element if
;;; successful.  Otherwise nil is returned.

(defun match-pattern-element (pattern-element datum-element)
  (cond ((listp datum-element)
	 (let ((datum-type (if (eq (car datum-element) 'special)
			       (cdr datum-element)
			       (car datum-element))))
	   (if (eq datum-type pattern-element) datum-element)))
	((funcall pattern-element datum-element)
	 (cons pattern-element datum-element))
	(t nil)))

;;; Match-pattern matches a pattern against a datum, returning the
;;; pattern if successful and nil otherwise.

(defun match-pattern (pattern datum datum-length)
  (if (>= (length pattern) datum-length)
      (let ((form-list nil))
	(do ((pattern pattern (cdr pattern))
	     (datum datum (cdr datum)))
	    ((or (null pattern) (null datum))
	     (cond ((and (null pattern) (null datum))
		    (nreverse form-list))
		   ((null pattern) nil)
		   ((null datum) (dolist (element pattern
						  (nreverse form-list))
				   (if (not (listp element))
				       (return nil))))))
	  (let* ((pattern-element (car pattern))
		 (datum-element (car datum))
		 (optional (listp pattern-element))
		 (matching (match-pattern-element (if optional
						      (car pattern-element)
						      pattern-element)
						  datum-element)))
	    (cond (matching (let ((form-type (car matching)))
			      (unless (or (eq form-type 'time-divider)
					  (eq form-type 'date-divider))
				(push matching form-list))))
		  (optional (push datum-element datum))
		  (t (return-from match-pattern nil))))))))

;;; Deal-with-noon-midn sets the decoded-time values to either noon
;;; or midnight depending on the argument form-value.  Form-value
;;; can be either 'noon or 'midn.

(defun deal-with-noon-midn (form-value parsed-values)
  (cond ((eq form-value 'noon)
	 (setf (decoded-time-hour parsed-values) 12))
	((eq form-value 'midn)
	 (setf (decoded-time-hour parsed-values) 0))
	(t (error "Unrecognized symbol: ~A" form-value)))
  (setf (decoded-time-minute parsed-values) 0)
  (setf (decoded-time-second parsed-values) 0))

;;; Deal-with-am-pm sets the decoded-time values to be in the am
;;; or pm depending on the argument form-value.  Form-value can
;;; be either 'am or 'pm.

(defun deal-with-am-pm (form-value parsed-values)
  (let ((hour (decoded-time-hour parsed-values)))
    (cond ((eq form-value 'am)
	   (cond ((eql hour 12)
		  (setf (decoded-time-hour parsed-values) 0))
		 ((not (<= 0 hour 12))
		  (if *error-on-mismatch*
		      (error "~D is not an AM hour, dummy." hour)))))
	  ((eq form-value 'pm)
	   (if (<= 0 hour 11)
	       (setf (decoded-time-hour parsed-values)
		     (mod (+ hour 12) 24))))
	  (t (error "~A isn't AM/PM - this shouldn't happen." form-value)))))

;;; Internet numerical time zone, e.g. RFC1123, in hours and minutes.
(defun deal-with-izone (form-value parsed-values)
  (multiple-value-bind (hours mins)
      (truncate form-value 100)
    (setf (decoded-time-zone parsed-values) (- (+ hours (/ mins 60))))))

;;; Set-time-values uses the association list of symbols and values
;;; to set the time in the decoded-time structure.

(defun set-time-values (string-form parsed-values)
  (dolist (form-part string-form t)
    (let ((form-type (car form-part))
	  (form-value (cdr form-part)))
      (case form-type
	(secondp (setf (decoded-time-second parsed-values) form-value))
	(minute (setf (decoded-time-minute parsed-values) form-value))
	(hour (setf (decoded-time-hour parsed-values) form-value))
	(day (setf (decoded-time-day parsed-values) form-value))
	(month (setf (decoded-time-month parsed-values) form-value))
	(year (setf (decoded-time-year parsed-values) form-value))
	(zone (setf (decoded-time-zone parsed-values) form-value))
	(izone (deal-with-izone form-value parsed-values))
	(weekday (setf (decoded-time-dotw parsed-values) form-value))
	(am-pm (deal-with-am-pm form-value parsed-values))
	(noon-midn (deal-with-noon-midn form-value parsed-values))
	(special (funcall form-value parsed-values))
	(t (error "Unrecognized symbol in form list: ~A." form-type))))))

(defun parse-time (time-string &key (start 0) (end (length time-string))
			       (error-on-mismatch nil)
			       (patterns *default-date-time-patterns*)
			       (default-seconds nil) (default-minutes nil)
			       (default-hours nil) (default-day nil)
			       (default-month nil) (default-year nil)
			       (default-zone nil) (default-weekday nil))
  "Tries very hard to make sense out of the argument time-string and
   returns a single integer representing the universal time if
   successful.  If not, it returns nil.  If the :error-on-mismatch
   keyword is true, parse-time will signal an error instead of
   returning nil.  Default values for each part of the time/date
   can be specified by the appropriate :default- keyword.  These
   keywords can be given a numeric value or the keyword :current
   to set them to the current value.  The default-default values
   are 00:00:00 on the current date, current time-zone."
  (setq *error-on-mismatch* error-on-mismatch)
  (let* ((string-parts (decompose-string time-string :start start :end end))
	 (parts-length (length string-parts))
	 (string-form (dolist (pattern patterns)
			(let ((match-result (match-pattern pattern
							   string-parts
							   parts-length)))
			  (if match-result (return match-result))))))
    (if string-form
	(let ((parsed-values (make-default-time default-seconds default-minutes
						default-hours default-day
						default-month default-year
						default-zone default-weekday)))
	  (set-time-values string-form parsed-values)
	  (convert-to-unitime parsed-values))
	(if *error-on-mismatch*
	  (error "\"~A\" is not a recognized time/date format." time-string)
	  nil))))