;;;===========================================================================
;;;
;;; utils.lisp
;;;
;;; Eduardo Muņoz
;;; Time-stamp: "Saturday, 31 July 2004 - 18:20:01"
;;;
;;;===========================================================================

(in-package :weblisp)

(use-package '(:htout))

(defun process-command (command &rest args)
  (html (:h3 command (dolist (arg args) (htm (fmt " ~A" arg))))
        (:pre (str (with-output-to-string (out)
                     (ext:run-program command args :wait t :output out))))))

(defun get-query-item (component query)
  (cadr (assoc component query :test #'string=)))

(defun get-http-query (command)
  (parse-query (cdr (assoc "posted-content" command
                           :test #'string=))))

(defun get-url-query (command)
  (parse-query (cdr (assoc "url-query" command
                           :test #'string=))))

(defun parse-query (query)
  (when (and (stringp query)
             (string/= query ""))
    ;; Decode after parsing to avoid false positives
    (mapcar #'(lambda (x) (list (car x) (decode-url (cadr x))))
            (mapcar #'(lambda (x) (string-parse x '(#\=)))
                    (string-parse query '(#\&))))))

(defun decode-url (string)
  (with-output-to-string (url)
    (let (percent-p buffer)
      (loop for char across string do
            (cond (buffer (write-char
                           (code-char
                            (parse-integer
                             (coerce (list buffer char) 'string)
                             :radix 16))
                           url)
                          (setq buffer nil))
                  (percent-p (setq buffer char)
                             (setq percent-p nil))
                  (t (case char
                       (#\% (setq percent-p t))
                       (#\+ (write-char #\Space url))
                       (otherwise (write-char char url)))))))))

(defun read-double-quoted (stream sub-char n-args)
  (declare (ignore sub-char n-args))
  (let* ((char (read-char stream nil nil))
         (next-char (read-char stream nil nil))
         (str (make-string-output-stream)))
    (loop while (not (and (eql char #\·) (eql next-char #\#))) do
          (write-char char str)
          (setf char next-char
                next-char (read-char stream nil nil))
          finally (return (get-output-stream-string str)))))

(set-dispatch-macro-character #\# #\· #'read-double-quoted)


;;;===========================================================================
;;;
;;; Website management
;;;

(defun list-apache-addresses ()
  (format t "~%Address")
  (let ((i 0))
    (maphash (lambda (x y)
               (incf i)
               (let ((fn (page-function y)))
                 (format t "~%~A~30T" x)
                 (cond
                   ((not (functionp fn))
                    (format t "Static"))
                   ((compiled-function-p fn)
                    (format t "Compiled"))
                   (t
                    (format t "Interpreted")))))
             *apache-address-table*)
    (format t "~%~%Total ~D pages" i)))

(defun delete-apache-addresses (&rest addresses)
  (dolist (address addresses)
    (multiple-value-bind (page found)
        (gethash address *apache-address-table*)
      (declare (ignore page))
      (when found
        (format t "Deleting: ~A" address)
        (remhash address *apache-address-table*)))))

(defun test-apache-address (url &optional (command '()))
  (let ((pos (position #\? url)))
    (when pos
      (setq command (cons (cons "url-query" (subseq url (1+ pos)))
                          command)
            url (subseq url 0 pos)))
    (multiple-value-bind (function found)
        (gethash url *apache-address-table*)
      (when found
        (funcall (page-function function) command)))))


;;;===========================================================================
;;;
;;; General purpose functions
;;;

(defvar *last-value* nil)

(defun wl-debug (foo)
  (format *debug-io* "~S~%* " (setf *last-value* foo))
  (force-output *debug-io*))

(defun string-parse (string chars &optional (allow-blanks t))
  (loop for start = 0 then (1+ end)
        for end = (position-if #'(lambda (x) (member x chars))
                               string :start start)
        when (or allow-blanks (not (eql start end)))
        collect (subseq string start end)
        while end))

(defun string-replace (string old new &optional (start 0))
  (let ((length-new (length new))
        (length-old (length old)))
    (loop while (setf start (search old string :start2 start)) do
          (setf string (concatenate 'string
                                    (subseq string 0 start)
                                    new
                                    (subseq string (+ start length-old)))
                start (+ start length-new))
          finally (return string))))


(defun parse-lang (lang)
  (let ((components (string-parse lang '(#\,) nil)))
    ;; Forget quota and country by now
    (mapcar #'(lambda (x) (car (string-parse x '(#\; #\-) nil)))
            components)))


(defvar *pale-colors* '("#99CC99" "#99CCFF" "#66CCFF" "#FFFFCC"
                        "#33CCFF" "#99CCCC" "#FFCCCC" "#33CCCC"))

(defvar *all-colors* '("#000000" "#000033" "#000066" "#000099" "#0000CC"
"#0000FF" "#003300" "#003333" "#003366" "#003399" "#0033CC" "#0033FF"
"#006600" "#006633" "#006666" "#006699" "#0066CC" "#0066FF" "#009900"
"#009933" "#009966" "#009999" "#0099CC" "#0099FF" "#00CC00" "#00CC33"
"#00CC66" "#00CC99" "#00CCCC" "#00CCFF" "#00FF00" "#00FF33" "#00FF66"
"#00FF99" "#00FFCC" "#00FFFF" "#330000" "#330033" "#330066" "#330099"
"#3300CC" "#3300FF" "#333300" "#333333" "#333366" "#333399" "#3333CC"
"#3333FF" "#336600" "#336633" "#336666" "#336699" "#3366CC" "#3366FF"
"#339900" "#339933" "#339966" "#339999" "#3399CC" "#3399FF" "#33CC00"
"#33CC33" "#33CC66" "#33CC99" "#33CCCC" "#33CCFF" "#33FF00" "#33FF33"
"#33FF66" "#33FF99" "#33FFCC" "#33FFFF" "#660000" "#660033" "#660066"
"#660099" "#6600CC" "#6600FF" "#663300" "#663333" "#663366" "#663399"
"#6633CC" "#6633FF" "#666600" "#666633" "#666666" "#666699" "#6666CC"
"#6666FF" "#669900" "#669933" "#669966" "#669999" "#6699CC" "#6699FF"
"#66CC00" "#66CC33" "#66CC66" "#66CC99" "#66CCCC" "#66CCFF" "#66FF00"
"#66FF33" "#66FF66" "#66FF99" "#66FFCC" "#66FFFF" "#990000" "#990033"
"#990066" "#990099" "#9900CC" "#9900FF" "#993300" "#993333" "#993366"
"#993399" "#9933CC" "#9933FF" "#996600" "#996633" "#996666" "#996699"
"#9966CC" "#9966FF" "#999900" "#999933" "#999966" "#999999" "#9999CC"
"#9999FF" "#99CC00" "#99CC33" "#99CC66" "#99CC99" "#99CCCC" "#99CCFF"
"#99FF00" "#99FF33" "#99FF66" "#99FF99" "#99FFCC" "#99FFFF" "#CC0000"
"#CC0033" "#CC0066" "#CC0099" "#CC00CC" "#CC00FF" "#CC3300" "#CC3333"
"#CC3366" "#CC3399" "#CC33CC" "#CC33FF" "#CC6600" "#CC6633" "#CC6666"
"#CC6699" "#CC66CC" "#CC66FF" "#CC9900" "#CC9933" "#CC9966" "#CC9999"
"#CC99CC" "#CC99FF" "#CCCC00" "#CCCC33" "#CCCC66" "#CCCC99" "#CCCCCC"
"#CCCCFF" "#CCFF00" "#CCFF33" "#CCFF66" "#CCFF99" "#CCFFCC" "#CCFFFF"
"#FF0000" "#FF0033" "#FF0066" "#FF0099" "#FF00CC" "#FF00FF" "#FF3300"
"#FF3333" "#FF3366" "#FF3399" "#FF33CC" "#FF33FF" "#FF6600" "#FF6633"
"#FF6666" "#FF6699" "#FF66CC" "#FF66FF" "#FF9900" "#FF9933" "#FF9966"
"#FF9999" "#FF99CC" "#FF99FF" "#FFCC00" "#FFCC33" "#FFCC66" "#FFCC99"
"#FFCCCC" "#FFCCFF" "#FFFF00" "#FFFF33" "#FFFF66" "#FFFF99" "#FFFFCC"
"#FFFFFF"))

(defun one-of (elements)
  (nth (random (length elements)) elements))

(defun some-pale-color ()
  (one-of *pale-colors*))

(defun some-color ()
  (one-of *all-colors*))

(defun colors-row ()
  (html
   (:address
    (:table
     (:tr
      (dotimes (i 15)
        (htm ((:td :bgcolor (some-pale-color) :width "20" :heigth "5")
              " "))))))))