;;; TODO

;; Adjust the URLS for the new situation
;; Provide search for:
;;  . Functions
;;    - Traditional
;;    - New style
;;  . Full text
;;

(defpackage :mcclim-doc
    (:use :http :common-lisp))

(in-package :mcclim-doc)

(defparameter *input-base* #p"/home/gilbert/cl-http/clim-spec/data/")

#+NIL
(defparameter *base* "http://nx01.base:8008/clim-doc/"
  "Where to export this stuff to ...")

#-NIL
(defparameter *base* "http://bauhh.dyndns.org:8000/clim-spec/"
  "Where to export this stuff to ...")

(defun foo-response (url stream)
  (write-line "<PRE>" stream)
  (describe url stream)
  (write-line "</PRE>" stream))

;;;; Kitchen Sink

(defun rcurry (fun &rest args)
  #'(lambda (&rest more)
      (apply fun (append more args))))

(defun split-by-if (predicate seq &key (start 0) (nuke-empty-p nil))
  (let ((p0 (position-if predicate seq :start start)))
    (if p0
        (if (and nuke-empty-p (= start p0))
            (split-by-if predicate seq :start (+ p0 1) :nuke-empty-p nuke-empty-p)
            (cons (subseq seq start p0)
                  (split-by-if predicate seq :start (+ p0 1) :nuke-empty-p nuke-empty-p)))
        (if (and nuke-empty-p (= start (length seq)))
            nil
            (list (subseq seq start))))))

(defun split-by (item &rest args)
  (apply #'split-by-if (curry #'eql item) args))

(defun split-by-member (items &rest args)
  (apply #'split-by-if (rcurry #'member items) args))


;;;; Dumping

(eval-when (compile eval load)
  (defconstant +nbsp+ (code-char 160)))

(defun node-attr (node attr)
  (do ((q (cdr node) (cddr q)))
      ((or (null q) (not (keywordp (car q))))
       nil)
    (when (eq (car q) attr)
      (return (cadr q)))))

(defun node-children (node)
  (do ((q (cdr node) (cddr q)))
      ((or (null q) (not (keywordp (car q))))
       q)))

(defparameter *no-end-tag* '(:BR :LINK :IMG))

(defun write-lhtml (x sink)
  (cond ((stringp x) (dump-string x sink))
        ((eq (car x) :raw)
         (write-string (cadr x) sink))
        ((eq (car x) :entity)
         (princ "&" sink)
         (princ (node-attr x :name) sink)
         (princ ";" sink))
        ((consp x)
         (princ "<" sink)
         (princ (car x) sink)
         (do ((q (cdr x) (cddr q)))
             ((not (keywordp (car q)))
              (terpri sink)
              (princ ">" sink)
              (dolist (k q)
                (write-lhtml k sink))
              (unless (or (member (car x) *no-end-tag*)
                          (and (eql (car x) :A)
                               (not (member :href x))))
                (format sink "</~A~%>" (car x)) ))
           (princ " " sink)
           (princ (car q) sink)
           (princ "=\"" sink)
           (dump-string (princ-to-string (cadr q)) sink)
           (princ "\"" sink))) ))

(defun dump-string (string sink)
  (map nil (lambda (c)
             (when (characterp c) (setq c (char-code c)))
             (cond ((= c #.(char-code #\&)) (princ "&amp;" sink))
                   ((= c #.(char-code #\<)) (princ "&lt;" sink))
                   ((= c #.(char-code #\>)) (princ "&gt;" sink))
                   ((= c #.(char-code +nbsp+)) (princ "&nbsp;" sink))
                   ((<= 32 c 126)
                    (write-char (code-char c) sink))
                   (t
                    (format sink "&#~D;" c))))
       string))

;;;; annos

(defun mungle-anno (text)
  ;; returns a list of HTML nodes
  (let ((current-para nil)
        res)
    (dolist (k (mungle-anno-1 text 0 (length text)))
      (cond ((eql k :PAR)
             (push `(:P ,@(reverse current-para)) res)
             (setf current-para nil))
            (t
             (push k current-para))))
    (push `(:P ,@(reverse current-para)) res)
    (setf current-para nil)
    (setf res (reverse res))
    (if (= (length res) 1)
        (cdar res)
        res)))

(defun string-begin-equal (snipset string &key (start2 0) (end2 (length string)))
  (and (>= (- end2 start2) (length snipset))
       (string-equal snipset string :start2 start2 :end2 (+ start2 (length snipset)))))

(defun url-query-escape (string)
  (with-output-to-string (bag)
    (loop for c across string do
          (if (or (alphanumericp c) (find c "-,."))
              (princ c bag)
              (format bag "%~2,'0X" (char-code c))))))

(defun mungle-anno-1 (text &optional (start 0) (end (length text)))
  (cond
    ((= start end)
     nil)
    ;; looking at an empty line?
    ((string-begin-equal #.(format nil "~%~%") text :start2 start)
     (incf start 2)
     ;; a paragraph
     (cons :PAR (mungle-anno-1 text start end)))
    ((string-begin-equal "<PRE>" text :start2 start)
     (let ((p (or (search "</PRE>" text :start2 start :test #'char-equal)
                  end)))
       ;; in case of PRE skip leading and trailing white space.
       (let ((matter (subseq text (+ start 5) p)))
         (setf matter (string-trim (list #\newline #\tab #\space) matter))
         (cons `(:PRE
                 ,matter)
               (mungle-anno-1 text (+ p 6) end)))))
    ((string-begin-equal "<LISP>" text :start2 start)
     (let ((p (or (search "</LISP>" text :start2 start :test #'char-equal)
                  end)))
       (cons `(:SPAN
               :CLASS "cl"
               (:A
                :HREF ,(format nil "edit/apropos?q=~A"
                               (url-query-escape (subseq text (+ start 6) p)))
                ,(subseq text (+ start 6) p)))
             (mungle-anno-1 text (+ p 7) end))))
    (t
     ;; advance until something potential interesting
     (let ((p (or (position-if (lambda (c) (find c #.(format nil "<~%"))) text :start (+ start 1) :end end)
                  end)))
       (cons (subseq text start p)
             (mungle-anno-1 text p end))))))

(defun formatted-annos (aid)
  (let (res)
    (dolist (anno *annotations*)
      (when (string-equal aid (node-attr anno :aid))
        (push `(:div :class "annotation"
                (:i :class "annotationheader" "Note: ")
                (:a :name ,(symbol-name (node-attr anno :id)))
                ,@(mungle-anno (first (node-children anno)))
                " "
                (:A :CLASS "annolink"
                 :HREF ,(format nil "edit/anno?aid=~A&editp=t&id=~A#~A"
                                (url-query-escape aid)
                                (url-query-escape (symbol-name (node-attr anno :id)))
                                (url-query-escape (symbol-name (node-attr anno :id))))
                 "[edit]")
                (:i :class "annotationsignature"
                 "-- " ,(node-attr anno :author)
                 " "
                 ,(if (node-attr anno :date)
                      (iso-date-string (node-attr anno :date) :timep t)
                      ""))
                (:div :style "clear:all" ,(string +nbsp+)))
              res)))
    res))

(defun node-attributes (node)
  (let ((atts nil))
    (and (consp node)
         (do ((q (cdr node) (cddr q)))
             ((not (keywordp (car q)))
              (reverse atts))
           (push (car q) atts)
           (push (cadr q) atts)))))
    
(defparameter *nono-attributes* '(:AID :ID :NOANNO))
(defparameter *no-close-tag* '(:BR :IMG))

(defun write-lhtml-2 (x sink)
  (let ((id (and (consp x) (node-attr x :id))))
    (when id
      (format sink "<A NAME=\"_~A\"></A>" id)))
      
  (cond ((stringp x) (dump-string x sink))
        ((eq (car x) :entity)
         (princ "&" sink)
         (princ (node-attr x :name) sink)
         (princ ";" sink))
        ((consp x)
         (assert (keywordp (car x)))
         (princ "<" sink)
         (princ (car x) sink)
         (do ((q (cdr x) (cddr q)))
             ((not (keywordp (car q)))
              (terpri sink)
              (princ ">" sink)
              (dolist (k q)
                (write-lhtml-2 k sink))
              
              (let ((aid (node-attr x :aid)))
                (when aid
                  (princ " " sink)
                  (write-lhtml-2 `(:A
                                   :HREF ,(format nil "edit/anno?aid=~A#Z" (url-query-escape aid))
                                   :CLASS "annolink"
                                   "[annotate]")
                                 sink))
                (when aid
                  (let ((annos (formatted-annos aid)))
                    (when annos
                      (write-lhtml-2 `(:div
                                       ,@(formatted-annos aid))
                                     sink)))))
              (unless (or (member (car x) *no-close-tag*) )
                (format sink "</~A~%>" (car x)) ))
           (unless (member (car q) *nono-attributes*)
             (princ " " sink)
             (princ (car q) sink)
             (princ "=\"" sink)
             (dump-string (princ-to-string (cadr q)) sink)
             (princ "\"" sink)))) ))

(defun iso-date-string (&optional (ut (get-universal-time))
                                  &key timep
                                       secondsp)
  (multiple-value-bind (second minute hour date month year day daylight-p zone)
      (decode-universal-time ut)
    (declare (ignorable second minute hour date month year day daylight-p zone))
    (format nil "~D-~2,'0D-~2,'0D~:[~; ~2,'0D:~2,'0D~:[~;:~2,'0D~]~]"
            year month date
            timep hour minute
            secondsp second)))

(defvar *annotations* nil)

(defun fetch-annos ()
  (setf *annotations* nil)
  (when (probe-file (merge-pathnames "annotations" *input-base*))
    (with-open-file (input (merge-pathnames "annotations" *input-base*))
      (let ((*package* (find-package :cl-user)))
        (do ((x (read input nil :eof) (read input nil :eof)))
            ((eq x :eof))
          (ecase (car x)
            (:delete
             (setf *annotations* (remove (node-attr x :id) *annotations*
                                  :key #'(lambda (x) (node-attr x :id)) )))
            (:annotation
             (push x *annotations*))))))))

;;;;

(defun fetch (filename output)
  (let ((data
         (with-open-file (input (merge-pathnames
                                 (make-pathname :type "raw" :defaults filename)
                                 *input-base*))
           (let ((*package* (find-package :cl-user)))
             (read input)))))
    (http:with-successful-response (output :html)
      (write-lhtml-2 data output))))

(defun regenerate (filename for-id)
  ;; -> URL
  (let ((data
         (with-open-file (input (make-pathname :type "raw"
                                               :directory '(:relative "data")
                                               :defaults filename))
           (let ((*package* (find-package :cl-user)))
             (read input)))))
    (let* ((fn (make-pathname :type "tmp" :defaults filename))
           (res-file))
      (with-open-file (output fn
                              :direction :output
                              :if-exists :new-version)
        ;; .../edit/clim-spec/ -> ../clim-spec
        (setf res-file
              (make-pathname :name (pathname-name filename)
                             :type "html"
                             :directory (append (pathname-directory "../../")
                                                (list (car (last (pathname-directory (truename fn))))))))
        (write-lhtml-2 data output))
      (ignore-errors (delete-file res-file))
      (rename-file fn res-file)
      (format nil "http://~A~A#~A"
              "HTTP_HOST"
              (namestring
               (merge-pathnames res-file
                                "SCRIPT_NAME"))
              (and for-id (symbol-name for-id))))))

(defun export-pages ()
  (loop for raw-file in (directory (merge-pathnames "*.raw" *input-base*)) do
        (let ((raw-file raw-file))      ;damn you LOOP
          (let ((name (pathname-name raw-file)))
            (export-url (url:intern-url
                         (merge-url (format nil "~A.html" name) (local-context))
                         :if-does-not-exist :create)
                        :computed
                        :response-function (lambda (url stream) (fetch raw-file stream)))))))

(defvar *aid*)
(defvar *aidid*)
(defvar *author*)
(defvar *editp*)
(defvar *text*)

(defun massage (x)
  (labels ((walk (x)
             (cond ((atom x) x)
                   ((string= (node-attr x :aid) *aid*)
                    `(:DIV
                      :STYLE "border: 1px solid; padding: 1em;"
                      (:A :NAME "Z")
                      ,x
                      (:DIV
                       :STYLE "padding: 1em; margin: 1em; background: rgb(80%,80%,80%);"
                       ,@(if *editp*
                             (list `(:B "You are about to edit the annotation.")))
                       (:FORM
                        :METHOD :POST
                        :ACTION "edit/submit"
                        (:INPUT :TYPE :HIDDEN :NAME "aid" :VALUE ,*aid*)
                        ,@(and *editp*
                               (list `(:INPUT :TYPE :HIDDEN :NAME "id" :VALUE ,*aidid*)))
                        ,@(and *editp*
                               (list `(:INPUT :TYPE :HIDDEN :NAME "editp" :VALUE "t")))
                        (:B "Annotation:") (:BR)
                        (:TEXTAREA
                         :COLS 80
                         :ROWS 10
                         :NAME "text"
                         ,(or *text* ""))
                        (:BR)
                        (:BR)
                        (:B "Author: ")
                        (:INPUT :NAME "author" :SIZE 30 :VALUE ,(or *author* ""))
                        ,(make-array 10 :element-type (array-element-type "")
                                     :initial-element +nbsp+)
                        (:BR)
                        (:BR)
                        (:INPUT :TYPE :SUBMIT :VALUE ,(if *editp* "Submit Changes" "Submit"))
                        ,@(and *editp*
                               (list
                                (make-array 10 :element-type (array-element-type "")
                                            :initial-element +nbsp+)
                                `(:INPUT :TYPE :SUBMIT :VALUE "Delete Annotation" :NAME "deletep")))
                        (:UL
                         (:LI "No text formating what so ever is supported
                                  currently. I am open to suggestions.")
                         ,@(and *editp*
                                (list
                                 '(:LI "Please do not edit annotations made by others.")))) ))))
                   ;; Kludge: include the base URL
                   ;; #+NIL
                   ((eq (car x) :head)
                    `(:head (:base :href ,*base*)
                      ,@(cdr x)))
                   (t
                    (cons (car x) (mapcar #'massage (cdr x)))))))
    (walk x)))

(defun anno-response (url stream)
  (let* ((*aid*   (cadr (assoc :aid (url:search-keys url))))
         (*editp* (cadr (assoc :editp (url:search-keys url))))
         (*aidid* (cadr (assoc :id (url:search-keys url))))
         (*text*  nil)
         (*author* "Fred Feuerstein")
         (affected-file
          (with-open-file (input (merge-pathnames "aidmap" *input-base*))
            (let ((*package* (find-package :cl-user)))
              (do ((x (read input nil :eof) (read input nil :eof)))
                  ((eq x :eof)
                   (error "For some reason I lost all memory about annotation ~S!" *aid*))
                (when (string= (first x) *aid*)
                  (return (second x))))))))
    (when *editp*
      (assert *aidid*))
    (print *aidid*)
    (when *editp*
      (dolist (k *annotations*)
        (when (string-equal (node-attr k :id) *aidid*)
          (setf *text* (car (node-children k))
                *author* (node-attr k :author)))))
    (http:with-successful-response (stream :html)
      (write-lhtml (with-open-file (input (merge-pathnames (make-pathname :type "raw" :defaults affected-file)
                                                           *input-base*))
                     (let ((*package* (find-package :cl-user)))
                       `(:raw ,(with-output-to-string (bag)
                                                      (write-lhtml-2 (massage (read input)) bag)))))
                   stream))
    '(print (list aid affected-file) stream)))

;;; ----------------------------------------------------------------------------------------------------
;;;  submit
;;;

(defun submit-response (url stream alist)
  (let ((*aid*   (copy-seq (cadr (assoc :aid alist))))
        (*editp* (copy-seq (cadr (assoc :editp alist))))
        (*deletep* (copy-seq (cadr (assoc :deletep alist))))
        (*aidid* (copy-seq (cadr (assoc :id    alist)))))
    (when (or *deletep* *editp*)
      (assert *aidid*)
      (setf *aidid* (intern *aidid*)))
    (let ((*affected-file*
           (with-open-file (input (merge-pathnames "aidmap" *input-base*))
             (let ((*package* (find-package :cl-user)))
               (do ((x (read input nil :eof) (read input nil :eof)))
                   ((eq x :eof)
                    (error "foo!"))
                 (when (string= (first x) *aid*)
                   (return (second x))))))))
      (let (*author* *text*)
        (unless *deletep*
          (setf *author* (copy-seq (cadr (assoc :author alist))))
          (unless *author* (error "no author?"))
        
          (setf *text* (copy-seq (cadr (assoc  :text alist))))
          (unless *text* (error "no text?")))
        
        (and (boundp '*text*)
             (mungle-anno *text*))

        (with-open-file (output (merge-pathnames "annotations" *input-base*)
                                :direction :output
                                :if-does-not-exist :create
                                :if-exists :append)
          (when (or *editp* *deletep*)
            (print `(:delete :id ,*aidid*) output)
            (setf *annotations* (remove *aidid* *annotations*
                                        :key #'(lambda (x) (node-attr x :id)) )))
          (unless *deletep*
            (let ((new `(:annotation
                         :author ,*author*
                         :date ,(get-universal-time)
                         :track-info (:addr
                                      (my-getenv "REMOTE_ADDR"))
                         :aid ,*aid*
                         :id ,(let ((*package* (find-package "CL-USER"))) (gentemp "Z"))
                         ,*text*)))
              (push new *annotations*)
              (print new output)))))

      (http:with-successful-response (stream :html)
        ;; hmm.
        (print "Done." stream)))))
        


(defun apropos-response (url stream)
  (describe url)
  (describe (url:search-keys url))
  (let ((q (cadr (assoc :q (url:search-keys url)))))
    (unless q
      (error "No Q?"))
    ;; Grrr, XXXX
    (setf q (substitute #\space #\+ q))
    (setf q
          (split-by-member '(#\space #\newline #\tab) q :nuke-empty-p t))
    (let (results)
      ;;
      (with-open-file (input (merge-pathnames "mrindex" *input-base*))
        (let ((*package* (find-package :cl-user)))
          (do ((x (read input nil nil)
                  (read input nil nil)))
              ((null x))
            (when (every (lambda (q) (search q (car x) :test #'string-equal))
                         q)
              (push x results)))))
      ;;
      ;;(print results)
      
      (http:with-successful-response (stream :html)
        (write-lhtml-2 `(:html :lang "en"
                         (:head
                          (:title "Search results")
                          (:base :href ,*base*)
                          (:link :rel :stylesheet :href "clim.css"))
                         (:body
                          (:h1 "Search Results")
                          (:p
                           "Query seen was: " (:B ,(format nil "~S" q)))
                          (:ul
                           ,@(mapcar (lambda (result)
                                       `(:LI (:A :HREF ,(caddr result)
                                              ,@(cadr result))))
                                     results))
                          (:h2 "In context")
                          ,@(apropos-in-context-results results)
                          )
                         )
                       stream)))))

(defun apropos-in-context-results (results)
  (mapcar #'apropos-in-context-result results))

(defun apropos-in-context-result (result)
  (let ((url (caddr result)))
    (let ((p1 (position #\. url))
          (p2 (position #\_ url)))
      (let ((file (merge-pathnames (make-pathname :name (subseq url 0 p1) :type "raw")
                                   *input-base*))
            (id (parse-integer (subseq url (1+ p2)))))
        `(:div
          (:h3 ,@(cadr result))
          ,(apropos-find-node file id) )))))

(defun apropos-find-node (file id)
  (labels ((walk (node parents)
             (cond ((not (consp node)) nil)
                   ((eql id (node-attr node :id))
                    (values node parents))
                   (t
                    (dolist (child (node-children node))
                      (multiple-value-bind (x y)
                          (walk child (cons node parents))
                        (when x (return (values x y)))))))))
    (multiple-value-bind (node parents) 
        (walk (with-open-file (input file)
                (let ((*package* (find-package :cl-user)))
                  (read input)))
              nil)
      (loop for x in (cons node parents)
            when (node-eligtible-for-showing-p x)
            return x))))

(defun node-eligtible-for-showing-p (node)
  (or (and (eq (car node) :div)
           (string-equal (node-attr node :class) :defun))
      (eq (car node) :p)))


(let ((http::*local-context* *base*))

  (export-pages)

  ;; Export .css files
  (loop for file in (directory (merge-pathnames "*.css" *input-base*)) do
        (export-url (url:intern-url
                     (merge-url (format nil "~A.~A" (pathname-name file) (pathname-type file))
                                (local-context))
                     :if-does-not-exist :create)
                    :css-file
                    :pathname file))
  ;; Export .png files
  (loop for file in (directory (merge-pathnames "*.png" *input-base*)) do
        (print file)
        (export-url (url:intern-url
                     (merge-url (format nil "~A.~A" (pathname-name file) (pathname-type file))
                                (local-context))
                     :if-does-not-exist :create)
                    :png-image
                    :pathname file))
  ;;
  (export-url #u"edit/anno?"
              :search
              :response-function 'anno-response)
  (export-url #u"edit/submit"
              :html-form
              :pathname "foo.bar.baz"
              :response-function 'submit-response)
  (export-url #u"edit/apropos?"
              :search
              :search-parser #'URL:PARSE-SEARCH-INFO-AS-QUERY-ALIST
              :response-function 'apropos-response)

  ;; finally a redirect for dummies
  (export-url #u""
              :redirect
              :alternate-urls (list #u"index.html"))
  (export-url (subseq *base* 0 (1- (length *base*)))
              :redirect
              :alternate-urls (list #u"index.html"))  
  (fetch-annos)
  )




