;;;===========================================================================
;;;
;;; utils.lisp
;;;
;;; Eduardo Muņoz
;;; Time-stamp: "Saturday, 26 March 2005 - 22:57:35"
;;;
;;;===========================================================================

(in-package :weblisp)

(use-package '(:htout))

;;; http stuff

(defun get-header (header command)
  (cdr (assoc (etypecase header
                (keyword (ecase header
                           (:lang "Accept-Language")
                           (:content "posted-content")
                           ))
                (string header))
              command
              :test #'string=)))

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

(defun get-http-query (command)
  (parse-query (get-header :content command)))

(defun get-url-query (command)
  (parse-query (get-header "url-query" command)))

(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)))))))))


;;; Accept-Language header 

(defun sort-lang-header (header &optional (strip-country t))
  "Returns a sorted list of preferred languages"
  (delete-duplicates 
   (mapcar #'car (stable-sort (parse-lang-header header strip-country)
                              #'> :key #'cdr))
   :test #'string=))

(defun parse-lang-header (header &optional (strip-country t))
  (loop for start = 0 then (1+ comma)
        for comma = (position #\, header :start start)
        collect (parse-lang-item (subseq header start comma)
                                 strip-country)
        while comma))

(defun parse-lang-item (item &optional (strip-country t))
  "Parse \"en-us;q=0.8\" into (\"en-us\" . 0.8). No quota (q=) means 1.0"
  (flet ((maybe-strip-country (lang)
           (string-trim " "
                        (if strip-country
                            (subseq lang 0 (position #\- lang))
                            lang))))
    (if-bind (semicolon (position #\; item))
        (cons (maybe-strip-country (subseq item 0 semicolon))
              (let (*read-eval*)
                (read-from-string
                 (string-trim "q=" (subseq item (1+ semicolon))))))
        (cons (maybe-strip-country item) 1.0))))


;; (sort-lang-header "es;q=1.0,en;q=0.9") ;-> ("es" "en")
;; (sort-lang-header "es,en;q=0.3") ;-> ("es" "en")
;; (sort-lang-header "jp;q=0.3,en,es;q=0.7,de-ch;q=0.8" nil)
;;     ;-> ("en" "de-ch" "es" "jp")

#+nil
(defun test-lang-header (&optional (strip-country t))
  (let ((headers (clsql:select 'lang :from 'log :order-by '(([id] :desc))
                               :flatp t :limit 1000 :database *web-db*)))
    (dolist (header headers)
      (format t "~S -> ~S~%" header (sort-lang-header header strip-country)))))



(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))))))



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

(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 shorten-time-string (time)
  (subseq time 0 (position #\. time :from-end t)))

(defvar *last-value* nil)

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