(in-package :araneida)

;;; The list of registered URL handlers, and functions for
;;; manipulating it

;; List of (method match url-prefix handler) 
(defvar *authentication-handlers* (list nil))
(defvar *authorization-handlers* (list nil))
(defvar *response-handlers* (list nil))
(defvar *error-handlers* (list nil))
(defvar *log-handlers* (list nil))

(defun export-method (export) (first export))
(defun export-match (export) (second export))
(defun export-prefix (export) (third export))
;(defun export-handler (export) (fourth export))
(defun export-needs-discriminator-p (export) (fifth export))

(defun handlers-for-stage (stage)
  (case stage
    (:authentication *authentication-handlers*)
    (:authorization *authorization-handlers*)
    (:response *response-handlers*)
    (:error *error-handlers*)
    (:log *log-handlers*)
    (t stage)))

(defun export-eq (e1 e2)
  (and (eql (export-method e1) (export-method e2))
       (eql (export-match e1) (export-match e2))
       (string= (export-prefix e1) (export-prefix e2))))

(defun string-prefix-length (short-string long-string)
  (let ((short-length (length short-string)))
    (if (> short-length (length long-string))
         nil
      (let ((m (mismatch long-string short-string)))
        (cond ((eql m nil) short-length)
              ((< m short-length) nil)
              (t m))))))

(defun matching-export-method-p (export method)
  (let ((m (export-method export)))
    (or (eql m t) (eql m method))))

(defun matching-export-p (export urlstring method)
  "Is EXPORT a valid handler for URLSTRING MATCH PREFIX?"
  (and (matching-export-method-p export method)
       (if (eql (export-match export) :prefix)
           (string-prefix-length (export-prefix export) urlstring)
           (string=  (export-prefix export) urlstring))))

;;; Precondition: both e1 and e2 satisfy matching-export-p
;;; - the longer prefix is preferred over the shorter one
;;; - :exact match favoured over :component over :prefix, 
;;; - exact method export selected over T (default) export
(defun export-better-p (e1 e2)
  (labels ((match (arg) (case arg (:exact 0) (:component 1) (:prefix 2))))
    (let ((l (- (length (export-prefix e1)) (length (export-prefix e2)))))
      (cond ((> l 0) t)
            ((< l 0) nil)
            (t
             (let ((m1 (match (export-match e1)))
                   (m2 (match (export-match e2))))
               (cond ((< m1 m2) t)
                     ((> m1 m2) nil)
                     ((and (not (eql t (export-method e1)))
                           (eql t (export-method e2))) t)
                     (t nil))))))))

(defvar *root-handler*)
(defun export-handler (url handler
                       &key
                       (match :prefix)
                       (method t)
                       needs-discriminator
                       (stage :response))
  "Add HANDLER to the list of exported URL handlers.  HANDLER may be a
function designator, which will be called with arguments REQUEST and
REST-OF-URL, or a list whose car designates a function and whose cdr will
be passed to it as aditional arguments.  Keyword :MATCH may be :PREFIX
or :EXACT.  *ROOT-HANDLER* must be bound to the root handler for some 
appropriate listener."
  (let ((handlers (handlers-for-stage stage))
        (export (list
                 method match (urlstring url) handler needs-discriminator)))
    (install-handler *root-handler* (make-instance 'legacy-handler)
		     (urlstring url) (eql match :exact))
    (aif (find export handlers :test #'export-eq)
         (rplacd it (cdr export))
         (nconc handlers (list export)))))

(defun find-export (url-string stage method)
  (let ((handlers (handlers-for-stage stage))
        (best nil))
    (loop for export in handlers
          if (and (matching-export-p export url-string method)
                  (or (not best) (export-better-p export best)))
          do (setf best export))
    (if best
        best
        (list nil nil nil nil))))
    

#+nil
(defvar *exported-servers* '())
#+nil
(defvar *default-server* nil
  "Server for requests without a Host header (e.g. HTTP/0.9")

#+nil
(defun export-server (server)
  (unless *default-server* (setf *default-server* server))
  (or (find server *exported-servers* :test #'server-equal-p)
      (push server *exported-servers*)))

#+nil
(defun server-for-url (url)
  (find (merge-url url "/")
        *exported-servers* :key #'server-base-url :test #'url-equal-p))

#+nil
(defun server-for-name-colon-port (name-colon-port-string)
  (let* ((colon-pos (position #\: name-colon-port-string))
         (name (subseq name-colon-port-string 0 colon-pos))
         (port-s (when colon-pos
                   (subseq name-colon-port-string
                           (1+ (length name)) nil)))
         (port (if port-s (parse-integer port-s) 80)))
    (or (find-if (lambda (s) (and (string-equal name (server-name s))
                                  (eql port (server-port s))))
                 *exported-servers*)
        (error "Unable to find exported server ~A" name))))


;;; exported
#+nil
(defun output-apache-conf (&optional (stream t))
  "Output a chunk of text suitable for including in an Apache configuration,
which comprises a VirtualHost section with ProxyPass for each exported server"
  (dolist (i  *exported-servers*)
    (output-apache-conf-segment i stream)))