(in-package :kira)

(defun render-login-form (&optional login-name return-uri)
  (let ((return-uri (or return-uri (request-uri))))
    (html
     ((:standard-form :action (:uri-to 'login :return-uri return-uri))
      ((:field :class "first field") "Login name" (text-field "login-name" login-name :size 16))
      (:field "Password" (text-field "password" nil :type "password" :size 16))
      (:p (submit-button nil "Log in")))
     ((:p :class "last")
      "New here? "
      (:a (:uri-to 'register :return-uri return-uri)
	  "Create an account")
      "."))))

(defhandler (login)
  (:title "Log in")
  (:authorized-p t)
  (with-query (return-uri login-name (error keyword))
    (when error
      (html
       ((:p :class "error")
	(case error
	  (:name (html "Login name does not exist."))
	  (:password (html "Password incorrect."))))))
    (render-login-form login-name return-uri)))

(defhandler :post (login)
  (with-query (return-uri login-name password)
    (let ((person (person login-name)))
      (whereas
	  ((error
	    (cond
	      ((not person) :name)
	      ((not (equal (password person) password)) :password))))
	(redirect
	 'login
	 :return-uri return-uri
	 :login-name login-name
	 :error error))
      (set-cookie "id" (id person) "password" password)
      (redirect return-uri))))

(defhandler (logout)
  (:title "Log out")
  (set-cookie "id" nil "password" nil)
  (redirect (request-query-value "return-uri")))

(defun render-challenge ()
  (html
   (:fieldset
    "Challenge (to protect against spam)"
    (:field
     (:princ (challenge-question))
     (text-field "challenge" nil :size 20) (:br)
     "(" ((:a :target "_blank") (:princ (challenge-hint)) "Hint?") ")"))))

(defun challenge-answered-p ()
  (with-query (challenge)
    (when challenge
      (search (challenge-answer) challenge :test #'char-equal))))

(defhandler (register)
  (:title "Create Account")
  (:authorized-p t)
  (with-query (return-uri login-name (error keyword))
    (html
     (:when error
       ((:p :class "error")
	(case error
	  (:no-name (html "Login name?"))
	  (:no-password (html "Password?"))
	  (:name (html "Login already in use."))
	  (:password (html "Passwords must match."))
	  (:challenge (html "Wrong challenge answer.")))))
     (:standard-form
      (:field "Login name" (text-field "login-name" login-name :size 20))
      (:field "Password" (text-field "password" nil :type "password" :size 20))
      (:field "Confirm password" (text-field "password-1" nil :type "password" :size 20))
      (render-challenge)
      (:p (submit-button))))))

(defhandler :post (register)
  (with-query (return-uri login-name password password-1 challenge)
    (when login-name (setf login-name (remove-extra-spaces login-name)))
    (whereas
	((error
	  (cond
	    ((not login-name) :no-name)
	    ((not password) :no-password)
	    ((not (challenge-answered-p)) :challenge)
	    ((string/= password password-1) :password)
	    ((person login-name) :name))))
      (redirect
       'register
       :return-uri return-uri
       :login-name login-name
       :error error))
    (let (person)
      (with-transaction ()
	(setf person
	      (make-instance
	       'person
	       :creation-time *now*
	       :login-name login-name
	       :password password))
	(add-kv (next-in-uri *root*) login-name person)
	(add-to (people *root*) person))
      (set-cookie "id" (id person) "password" password)
      (redirect return-uri))))

(defun administratorp (person)
  (and person (member (login-name person) +administrators+ :test #'string=)))

(defun uri-authorized-p (object &rest args)
  (multiple-value-bind (node view query)
      (etypecase object
	(node (if args (values object (first args) (rest args)) (values object nil nil)))
	(symbol (values *root* object args)))
    (cond
      ((or (eq view nil) (keywordp view) (administratorp *person*)) t)
      ((method-exists nil #'authorized-p node view) (apply #'authorized-p node view query))
      (t (loop with package = (symbol-package view)
	       with name = (symbol-name view)
	       for end = (position #\/ name :from-end t)
	       then (position #\/ name :end end :from-end t)
	       while end
	       do (whereas ((view (find-symbol (subseq name 0 end) package)))
		    (when (method-exists nil #'authorized-p node view)
		      (return (apply #'authorized-p node view query))))
	       finally (return *person*))))))

(defun authorize (&rest args)
  (unless (apply #'uri-authorized-p args)
    (if *person*
	(standard-page (:title "Permission Denied"))
	(redirect 'login :return-uri (request-uri)))))