(defpackage :webutils.misc (:use :cl :araneida :webutils.application)
            (:export :with-body-params :define-configuration-variable :reload-configuration-variables
                     :with-query-params
                     :expire-authorization-tokens :make-authorization-token :is-authorized
                     :expire-request-authorization :handler-url :define-handler-hierarchy))
(in-package :webutils.misc)
(webutils::export-all :webutils.misc)

(defun conanicalize-body-param (param)
  (when param
    (map 'string
         #'(lambda (char)
             (if (typep char 'base-char)
                 char
                 #\?)) param)))

(defmacro with-body-params (param-pairs request &body body)
  (when (null body)
    (error "I think you forgot the request argument to with-body-params."))
  (let ((request-name (gensym)))
    `(let* ((,request-name ,request)
            ,@(mapcar #'(lambda (param-pair)
                          (let ((bind-to (if (listp param-pair)
                                             (first param-pair)
                                             param-pair))
                                (param-name (if (listp param-pair)
                                                (second param-pair)
                                                (string-downcase (symbol-name param-pair)))))
                            `(,bind-to
                              (conanicalize-body-param
                               (body-param ,param-name
                                           (request-body ,request-name))))))
                      param-pairs))
       ,@body)))

(defmacro with-query-params (param-pairs request &body body)
  (when (null body)
    (error "I think you forgot the request argument to with-query-params."))
  (let ((url-name (gensym)))
    `(let* ((,url-name (request-url ,request))
            ,@(mapcar #'(lambda (param-pair)
                          (let ((bind-to (if (listp param-pair)
                                             (first param-pair)
                                             param-pair))
                                (param-name (if (listp param-pair)
                                                (second param-pair)
                                                (string-downcase (symbol-name param-pair)))))
                            `(,bind-to
                              (first (url-query-param ,url-name ,param-name)))))
                      param-pairs))
       ,@body)))

(defparameter *configuration-variable-reload-hooks* nil)

(defmacro define-configuration-variable (variable value-load-form)
  `(progn
    (defparameter ,variable ,value-load-form)
    (setf (cdr (or (assoc ',variable *configuration-variable-reload-hooks*)
                   (first (push (cons ',variable nil) *configuration-variable-reload-hooks*))))
          (lambda ()
            (declare (special ,variable))
            (setf ,variable ,value-load-form)))))

(defun reload-configuration-variables ()
  (loop for hook in *configuration-variable-reload-hooks*
       do (funcall (cdr hook))))

(defparameter *authorization-tokens* nil)

(defun expire-authorization-tokens (&key (timeout (* 60 60)) (filter (constantly nil)))
  (let ((now (get-universal-time)))
    (setf *authorization-tokens*
          (remove-if #'(lambda (token)
                         (or (< (+ (first token) timeout) now)
                             (funcall filter (third token))))
                     *authorization-tokens*))))

(defun expire-request-authorization (request)
  (let ((token (is-authorized request)))
    (if token
        (setf *authorization-tokens*
              (remove token *authorization-tokens* :key #'second)))))

(defun make-authorization-token (&key extra (path "/"))
  (let ((token (random 10000000)))
    (push (list (get-universal-time) token extra)
          *authorization-tokens*)
    (format nil "AUTHTOKEN=~A; path=~A" token path)))

(defun is-authorized (request &key (update t))
  (let* ((token (parse-integer (or (request-cookie request "AUTHTOKEN") "-1") :junk-allowed t))
         (found (find token *authorization-tokens* :key #'second)))
    (when found
      (when update (setf (first found) (get-universal-time)))
      (values token (third found)))))

(defgeneric handler-url (handler-class-name))

(defmacro define-handler-hierarchy (listener-or-application &rest hierarchy)
  (let (handler-class-definitions)
    (multiple-value-bind (listener extra-superclasses)
        (if (listp listener-or-application)
            (ecase (first listener-or-application)
              (:listener (values (second listener-or-application) nil))
              (:application (values `(application-listener (find-application ',(second listener-or-application)))
                                    (list (second listener-or-application))))))
      ;; a four of three elements - class name, superclasses, URL root, and inexact-p
      (labels ((parse-root-group (root-group existing-root)
                 (let ((new-url (if existing-root
                                    `(merge-url ,existing-root ,(first root-group))
                                    (first root-group))))
                   (if (and (or (eql (length root-group) 2)
                                (eql (length root-group) 4))
                            (or (symbolp (second root-group))
                                (every #'symbolp (second root-group)))
                            (or (eql (length root-group) 2)
                                (and (eq (third root-group) :inexact))))
                       ;; it's actually a single handler definition
                       (push (list (if (symbolp (second root-group))
                                       (second root-group)
                                       (first (second root-group)))
                                   (if (symbolp (second root-group))
                                       nil
                                       (cdr (second root-group)))
                                   new-url
                                   (if (eq (length root-group) 4)
                                       (fourth root-group)))
                             handler-class-definitions)
                       (loop for sub-root-group in (cdr root-group)
                          do (parse-root-group sub-root-group new-url))))))
        (loop for group in hierarchy
           do (parse-root-group group nil)))
      `(progn
         ,@(loop for (class-name superclasses root-url inexact) in handler-class-definitions
              with g = (gensym)
              collect `(defclass ,class-name (handler ,@superclasses ,@extra-superclasses) ())
              collect `(defmethod handler-url ((,g (eql ',class-name)))
                         ,root-url)
              collect `(install-handler (http-listener-handler ,listener)
                                        (make-instance ',class-name)
                                        (urlstring (handler-url ',class-name))
                                        (not ,inexact)))))))