;;;; -*- Mode: Lisp; Base: 10; Syntax: ANSI-Common-Lisp; Package: kira; Coding: utf-8 -*-
;;;; Copyright © 2020 David Mullen. All Rights Reserved. Origin: <https://cl-pdx.com/kira/>

(in-package :kira)

  (defstatic +header-external-format+
    '(:character-encoding :iso-8859-1
      :line-termination :crlf)))

(defconstant +line-buffer-size+ 1024)
(defconstant +content-buffer-size+ 131072)
(defconstant +multipart-buffer-size+ 16384)
(defconstant +multipart-window-target+ 4096)

(defstruct* request
  (uri #u"/~dummy/")
  (method :get)

(defstaticvar *content-buffer* (make-buffer +content-buffer-size+))
(defstaticvar *line-buffer* (make-buffer +line-buffer-size+ 'character))
(defstaticvar *quoted-string* (make-buffer +line-buffer-size+ 'character))
(defparameter *request* (make-request))
(defparameter *session* nil)

  (defun make-status-line (status-code reason-phrase)
    (with-output-to-vector (stream nil :external-format +header-external-format+)
      (format stream "HTTP/1.0 ~D ~A~%" status-code reason-phrase))))

(defmacro defstatus (status-code name &optional reason-phrase)
  (orf reason-phrase (nstring-capitalize (substitute #\Space #\- (remove #\$ (string name)))))
  `(define-symbol-macro ,name '(,status-code . ,(make-status-line status-code reason-phrase))))

(defstatus 200 $ok "OK")
(defstatus 301 $moved-permanently)
(defstatus 302 $moved-temporarily)
(defstatus 400 $bad-request)
(defstatus 403 $authorized-personnel-only)
(defstatus 404 $not-found)
(defstatus 405 $method-not-allowed)

(defun make-multipart (content-length)
  (cons (let ((buffer (make-array +multipart-buffer-size+ :element-type 'octet)))
          (make-array 0 :adjustable t :displaced-to buffer :element-type 'octet))

(defun read-header-line (stream)
  (loop with line-buffer = (reset-buffer *line-buffer*)
        for char of-type character = (read-char stream)
        when (char= char #\Newline) return line-buffer
        do (vector-push-extend char line-buffer)))

(defun read-request-line (stream)
  (with-lexer ((read-header-line stream))
    (values (with-lexer-error ("request method")
              (match-symbol (:get :head :post)
                            :case-sensitive-p t
                            :if-none-match :error
                            :terminated-by #\Space))
            ;; Space on both sides.
            (parse-uri lexer-string
                       :start lexer-position
                       :end (lexer-find #\Space)))))

(defun multipart-displacement (multipart)
  (check-type multipart (cons t fixnum))
  (array-displacement (car multipart)))

(defun multipart-position (multipart)
  (multiple-value-bind (buffer position)
      (multipart-displacement multipart)
    (declare (ignore buffer)) position))

(defun read-body-part (multipart delimiter input output)
  (with-accessors ((position multipart-position)) multipart
    (loop with buffer = (multipart-displacement multipart)
          for window = (ensure-multipart-window multipart input)
          do (multiple-value-bind (start end final-delimiter-p)
                 (find-delimiter delimiter window)
               (declare (type array-index start))
               (unless (or end (> start (the array-index position)))
                 (error "Encountered EOF before boundary: ~S." multipart))
               (write-sequence buffer output :start position :end start)
               (advance-multipart-window multipart (or end start))
               (when end (return final-delimiter-p))))))

(defun advance-multipart-window (multipart new-position)
  (multiple-value-bind (buffer old-position) (multipart-displacement multipart)
    (let ((shrink (- (the array-index new-position) (the array-index old-position))))
      (declare (type array-index shrink))
      (let ((window (car multipart)))
        (adjust-array window
                      (- (array-total-size window) shrink)
                      :displaced-index-offset new-position
                      :displaced-to buffer)))))

(defun read-into-multipart-buffer (multipart stream)
  (destructuring-bind (window . content-length) multipart
    (unless (plusp content-length) (return-from read-into-multipart-buffer window))
    (multiple-value-bind (buffer old-position) (multipart-displacement multipart)
      (let ((end (the array-index (+ (the fixnum old-position) (length window)))))
        (declare (type array-index end old-position content-length))
        (replace buffer buffer :start2 old-position :end2 end)
        (adjust-array window (decf end old-position) :displaced-to buffer)
        (let* ((available-space (- (the fixnum (array-total-size buffer)) end))
               (maximum-end (+ end (the fixnum (min available-space content-length))))
               (new-end (read-sequence buffer stream :start end :end maximum-end)))
          (declare (type array-index available-space maximum-end new-end))
          (decf (cdr multipart) (the fixnum (- new-end end)))
          (adjust-array window new-end :displaced-to buffer))))))

(defun ensure-multipart-window (multipart stream &aux (window (car multipart)))
  (cond ((>= (the fixnum (length window)) +multipart-window-target+) window)
        (t (read-into-multipart-buffer multipart stream))))

  (defconstant +cr+ (char-code #\Return))
  (defconstant +lf+ (char-code #\Linefeed))
  (defconstant +hyphen+ (char-code #\-)))

(defmacro with-headers ((stream header-name) &body clauses)
  (loop for (key) in clauses for keys = (ensure-list key)
        append (remove-if-not #'keywordp keys) into header-names
        finally (return (with-gensyms (header-stream read-header-tag)
                          `(prog ((,header-stream ,stream))
                             (with-lexer ((read-header-line ,header-stream))
                               (unless (eql lexer-start lexer-end)
                                 (with-lexer-error ("header")
                                   (let ((,header-name
                                           :terminated-by #\:)))
                                     (declare (type symbol ,header-name))
                                     (when ,header-name (skip-lws))
                                     (case ,header-name ,@clauses)
                                     (go ,read-header-tag))))))))))

(defmacro skip-lws (&optional class)
  (let ((skip '(loop while (lexer-match horizontal-whitespace))))
    (if class `(prog2 ,skip (lexer-match ,class) ,skip) skip)))

(defmacro parse-quoted-string ()
  `(let ((buffer (reset-buffer *quoted-string*)))
     (loop (lexer-case (char (lexer-error))
             (#\" (return (copy-seq buffer)))
             (t (when (char= char #\\)
                  (lexer-case (escaped-quote)
                    (#\" (setq char escaped-quote))))
                (vector-push-extend char buffer))))))

(define-char-class separator ()
  '(or #\Tab " ()<>\"@,;:\\[]?={}/"))

(define-char-class token ()
  '(and graphic (not separator)))

(defmacro parse-http-value ()
  `(or (lexer-case (open-quote)
         (#\" (parse-quoted-string)))
       (get-token token)))

(defmacro expect-keyword (keywords terminated-by)
  `(match-symbol ,keywords :if-none-match :error
                 :terminated-by ,terminated-by))

(defmacro parse-content-type ()
  `(progn (expect-keyword :multipart/form-data #\;)
          (skip-lws) (expect-keyword :boundary #\=)

(defmacro parse-x-forwarded-for ()
  "Get client IP address from X-Forwarded-For."
  `(get-token (and graphic (not ", "))))

(defmacro parse-cookie ()
  `(loop for cookie-name = (match-symbol session :terminated-by #\=)
         for parsed-cookie-value = (when cookie-name (lexer-unsigned 36))
         thereis parsed-cookie-value do (or (lexer-match t) (loop-finish))))

(defun read-request-headers (stream)
  (let ((content-length 0) boundary)
    (declare (type fixnum content-length))
    (with-headers (stream header-name)
      (:content-type (setq boundary (parse-content-type)))
      (:cookie (setf (request-cookie *request*) (parse-cookie)))
      (:x-forwarded-for (setf (request-address *request*) (parse-x-forwarded-for)))
      (:content-length (setq content-length (require-type (lexer-unsigned) 'fixnum))))
    (values content-length boundary stream)))

(defun make-delimiter (boundary &aux (prefix (constant-octet-vector +lf+ +hyphen+ +hyphen+)))
  (concatenate '(vector octet) prefix (map '(vector (unsigned-byte 8)) #'char-code boundary)))

(defun find-delimiter (delimiter window &optional seen-crlf-p)
  (declare (type (simple-array (unsigned-byte 8) (*)) delimiter))
  (with-array-data ((vector window) (window-start 0) window-end)
    (declare (type (simple-array (unsigned-byte 8) (*)) vector))
    (prog* ((delimiter-length (length delimiter))
            (i window-start) (j 0) (start i))
      (declare (type array-index i j start))
      (declare (type array-index delimiter-length))
      (when seen-crlf-p (incf j) (go match-delimiter))
      (loop while (< i window-end)
            do (when (= (aref vector i) +cr+)
                 ;; CR is implicit in DELIMITER.
                 (setq start i j 0 i (1+ i))
                 (go match-delimiter))
               (incf i))
      ;; No CR found.
      (return window-end)
      (loop while (< i window-end) while (< j delimiter-length)
            do (when (/= (aref vector i) (aref delimiter j))
                 (go find-cr)) ; Mismatch.
               (incf i) (incf j))
      ;; Match CRLF and maybe hyphens.
      (let ((remaining (- window-end i)))
        (declare (type fixnum remaining))
        (when (< remaining 2)
          ;; Need more input.
          (return start))
        (when (= (aref vector i) +cr+)
          (when (= (aref vector (the fixnum (+ i 1))) +lf+)
            (return (values start (the fixnum (+ i 2)) nil))))
        ;; Need to check for final delimiter.
        (when (< remaining 4) (return start))
        (when (and (= (aref vector i) +hyphen+)
                   (= (aref vector (the fixnum (+ i 1))) +hyphen+)
                   (= (aref vector (the fixnum (+ i 2))) +cr+)
                   (= (aref vector (the fixnum (+ i 3))) +lf+))
          ;; Matched the final delimiter.
          (let ((end (the fixnum (+ i 4))))
            (return (values start end t)))))
      ;; Mismatch.
      (go find-cr))))

(defmacro parse-content-disposition ()
  `(loop initially (expect-keyword :form-data #\;) (skip-lws)
         for keyword = (expect-keyword (:name :filename) #\=)
         for value of-type simple-string = (parse-http-value)
         if (eq keyword :filename) do (setq filename value)
         else do (setq name value) while (skip-lws #\;)))

(defun find-end-of-header-block (vector)
  (with-array-data ((vector vector) (start 0) end)
    (declare (type (simple-array (unsigned-byte 8) (*)) vector))
    (when (<= (decf end 3) 0) (return-from find-end-of-header-block))
    (loop for i of-type array-index from start below end
          when (and (= (aref vector i) +cr+)
                    (= (aref vector (the array-index (+ i 1))) +lf+)
                    (= (aref vector (the array-index (+ i 2))) +cr+)
                    (= (aref vector (the array-index (+ i 3))) +lf+))
          ;; Position past the blank line.
          return (the array-index (+ i 4)))))

(defun skip-preamble (multipart delimiter stream)
  (let ((window (ensure-multipart-window multipart stream)))
    (multiple-value-bind (start end final-delimiter-p) (find-delimiter delimiter window t)
      (advance-multipart-window multipart (or end (error "Expected boundary in ~S." multipart)))
      (values final-delimiter-p start end))))

(defun trim-buffer (buffer &optional (max-fill-pointer 80))
  (cond ((<= (fill-pointer buffer) max-fill-pointer) buffer)
        (t (let ((fill-pointer (position #\- buffer :end max-fill-pointer :from-end t))
                 (type (when (find #\. buffer) (subseq buffer (1+ (position #\. buffer))))))
             ;; Include type even if it puts us (somewhat) over the MAX-FILL-POINTER.
             (setf (fill-pointer buffer) (or fill-pointer max-fill-pointer))
             (when (and type (< (length type) 7)) (format buffer ".~A" type))

(defun collapse (string &optional allow-dots-p &key (start 0) end)
  "Make STRING acceptable as the filename part of a logical namestring."
  (with-lexer (string start end)
    (loop with state = nil
          with buffer-size fixnum = (- lexer-end lexer-start)
          with buffer = (make-buffer buffer-size 'standard-char)
          do (lexer-case (char (return (trim-buffer buffer)))
               (#\_ (vector-push-extend #\_ buffer)
                    (setq state :hard-separator))
                (when (eq state :soft-separator)
                  (vector-push-extend #\- buffer))
                (vector-push-extend char buffer)
                (setq state :alphanumeric-sequence))
                (cond ((eql char #\')) ; Skip apostrophes.
                      ((and allow-dots-p (eql char #\.))
                       (vector-push-extend #\. buffer)
                       (setq state :hard-separator))
                      ((eq state :alphanumeric-sequence)
                       (setq state :soft-separator))))))))

(defun sanitize-filename (filename)
  "Discard directory components."
  (with-lexer ((or filename ""))
    (unless (eql lexer-end lexer-start)
      (loop for position = (lexer-find "\\/")
            if position do (setq lexer-position (1+ position))
            else return (collapse filename t :start lexer-position)))))

(defun read-post (content-length boundary input &aux parameter)
  (unless (eq (request-method *request*) :post) (return-from read-post))
  (assert (and (plusp content-length) boundary) (content-length boundary))
  (loop with multipart = (make-multipart content-length)
        with buffer = (multipart-displacement multipart)
        with delimiter = (make-delimiter boundary)
        for name = nil for filename = nil initially (when (skip-preamble multipart delimiter input) (loop-finish))
        for window = (ensure-multipart-window multipart input) as start = (nth-value 1 (array-displacement window))
        for end-of-headers fixnum = (or (find-end-of-header-block window) (respond-with $bad-request))
        do (with-input-from-vector
               (input buffer :external-format +header-external-format+ :start start :end end-of-headers)
             (with-headers (input header-name) (:content-disposition (parse-content-disposition)))
             (assert name (name) "Invalid Content-Disposition: parameter name required."))
        ;; We have the name of the parameter. Next, read its value.
        collect (setq parameter (list name)) into request-parameters
        finally (setf (request-parameters *request*) request-parameters)
        do (advance-multipart-window multipart end-of-headers)
        until (if (plusp (length (setq filename (sanitize-filename filename))))
                  (with-temporary-file (binary-output :element-type 'octet)
                    (rplacd parameter (cons filename (pathname binary-output)))
                    (read-body-part multipart delimiter input binary-output))
                  (with-output-to-vector (binary-output (reset-buffer *content-buffer*))
                    (prog1 (read-body-part multipart delimiter input binary-output)
                      (setf (fill-pointer *content-buffer*) (file-position binary-output))
                      (rplacd parameter (decode-content-from-octets *content-buffer*)))))))

(defun parameter (name &optional errorp (parser #'identity))
  (let ((value (cdr (assoc name (uri-alist (request-uri *request*)) :test #'string-equal))))
    (when (plusp (length value)) (setq value (percent-decode value :plus-to-space-p t)))
    (orf value (cdr (assoc name (request-parameters *request*) :test #'string-equal)))
    (or (if (stringp value) (if (equal value "") nil (funcall parser value)) value)
        (when errorp (respond-with $not-found)))))

(defun handle-request (request http-output)
  (setf (request-input request) nil)
  (let* ((request-method (request-method request))
         (request-cookie (request-cookie request))
         (uri (request-uri request)) object response canonical-path
         (*session* (if request-cookie (cookie-session request-cookie)))
         (query (uri-query uri)))
    (multiple-value-bind (status location body)
        (cond ((not (setq object (uri-object uri))) $not-found)
              ((string/= (uri-path uri) (setq canonical-path (canonical-path object)))
               (values $moved-permanently (resolve-uri (make-uri :path canonical-path :query query))))
              ((consp (setq response (catch 'response (get-response object request-method)))) response)
              (t (if (uri-p response) (values $moved-temporarily response nil) (values $ok nil response))))
      (destructuring-bind (status-code . status-line) status
        (check-type status-code array-index "a status code")
        (write-sequence status-line http-output)
        (let* ((content-length (length body))
               (response-time (get-local-time))
               (content-type "text/html; charset=utf-8")
               (good-response-p (< (the fixnum status-code) 400))
               (cookie (when *session* (session-cookie *session*))))
          (format http-output "Date: ~/kira:822-time/~%" response-time)
          (if good-response-p (fail-safe (commit) (rollback)) (rollback))
          (when (set-cookie-p cookie request-cookie *session* response-time)
            (symbol-macrolet ((expiration-time (expiration-time *session*)))
              (format http-output "Set-Cookie: session=~36R; path=/; " cookie)
              (format http-output "expires=~:/kira:822-time/; HttpOnly" expiration-time)
              (format http-output "~:[; Secure~;~]~%" (eq (uri-scheme *base-uri*) :http))))
          (format http-output "Content-Length: ~D~%" content-length)
          (cond (location (format http-output "Location: ~A~%" location))
                (t (format http-output "Content-Type: ~A~%" content-type)))
          (format http-output "Server: Kira~%~%")
          (unless (eq request-method :head)
            (write-sequence body http-output))
          (finish-output http-output))))))

(defun respond-with (designator)
  (throw 'response designator))

    respond-with (designator)
  `(throw 'response ,designator))

(defgeneric handle (object)
  (:method ((object-without-post t))
    (respond-with $method-not-allowed)))

(defconstant +session-days-alive+ 90)
(defconstant +session-renewal-at+ 30)

(defun get-expiration-time (&aux (expiration-time (get-local-time)))
  (incf (local-time-day expiration-time) +session-days-alive+)

(defun renew-session-p (session &optional (present (get-local-time)))
  (with-accessors ((expiration-time expiration-time)) session
    (let ((days-left (- (local-time-day expiration-time) (local-time-day present))))
      (when (<= days-left +session-renewal-at+) (setq expiration-time (get-expiration-time))))))

(defun set-cookie-p (session-cookie request-cookie session response-time)
  (and session-cookie (or (not (eql session-cookie request-cookie))
                          (renew-session-p session response-time))))

(define-persistent-class session ()
  ((log :initform nil :accessor session-log :initarg :log)
   (name :initform nil :accessor session-name :initarg :name)
   (authorization-time :initform nil :accessor authorization-time)
   (ip-address :accessor ip-address :initform (request-address *request*))
   (expiration-time :accessor expiration-time :initform (get-expiration-time))
   (code :accessor session-code :documentation "Computed with MAC function.")
   (cookie :allocation :instance :reader session-cookie)))

(defmethod slot-unbound ((class t) (session session) (slot-name (eql 'cookie)))
  (with-accessors ((object-id object-id) (session-code session-code)) session
    (symbol-macrolet ((cookie (logior (ash object-id +mac-bits+) session-code)))
      (setf (slot-value session 'cookie) cookie))))

(defmethod slot-unbound ((class t) (session session) (slot-name (eql 'code)))
  (symbol-macrolet ((id (object-id session)) (session-key (get 'system 'session-key)))
    (setf (slot-value session 'code) (mac (with-output-to-vector (binary-stream)
                                            (write-binary-object id binary-stream))

(defun cookie-session (cookie)
  (symbol-macrolet ((code (ldb (byte +mac-bits+ 0) cookie)))
    (let ((session (get-object (ash cookie (- +mac-bits+)))))
      (with-accessors ((session-code session-code)) session
        (when (and (typep session 'session) (= code session-code))

(define-persistent-class input ()
  ((time :reader input-time :reader edited-time :initform (get-local-time))
   (uri :accessor input-uri :initarg :uri :initform (request-uri *request*))
   (ip-address :accessor ip-address :initform (request-address *request*))
   (parameters :accessor parameters :initform (request-parameters *request*))
   (session :accessor session :initarg :session :initform *session*)))

(defun ensure-input ()
  (orf (request-input *request*)
       (make-instance 'input)))

(defun get-response (object request-method &aux (buffer (reset-buffer *content-buffer*)))
  (with-output-to-vector (*html-output* buffer :external-format +content-external-format+)
    (symbol-macrolet ((bot (assoc :submit (request-parameters *request*) :test #'string-equal)))
      (case request-method
         (when bot (respond-with $bad-request))
         (orf *session* (make-instance 'session))
         (progn (handle object) (redirect object)))
        (otherwise (render-page object) buffer)))))

(defun redirect (object &rest parameters)
  "Immediately send 302 redirect to the specified resource."
  (cond ((typep object 'uri) (respond-with (resolve-uri object)))
        ((respond-with (apply #'absolute-uri-to object parameters)))))

(defun http-error (condition)
  (log-condition condition)
  (throw 'accept-connection

(defun http-warning (condition)
  (log-condition condition)
  (muffle-warning condition))

(defun http-serve (&key (port 8080))
  (with-open-socket (http-listener
                     :connect :passive :local-port port
                     :type :stream :local-host "")
    ;; The request object is reused.
    (loop with request = (make-request)
          with *request* = request
          do (catch 'accept-connection
               (with-accessors ((request-cookie request-cookie)
                                (request-address request-address)
                                (request-parameters request-parameters)
                                (request-method request-method)
                                (uri request-uri)) request
                 (handler-bind ((serious-condition #'http-error) (warning #'http-warning))
                   (with-open-stream (http-connection (accept-connection http-listener))
                     (setf (values request-cookie request-address request-parameters) nil)
                     (setf (stream-external-format http-connection) +header-external-format+)
                     (setf (values request-method uri) (read-request-line http-connection))
                     (multiple-value-call #'read-post (read-request-headers http-connection))
                     (handle-request request http-connection))))))))