;;;; -*- Mode: Lisp; Base: 10; Syntax: ANSI-Common-Lisp; Package: kira; Coding: utf-8 -*-
;;;; Copyright © 2018 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)))

(defstruct request
  (parameters '())
  (method :get)
  (address nil)
  (cookie nil)
  (uri "/"))

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

(defun make-line-buffer (&optional (size +line-buffer-size+))
  (make-array size :fill-pointer 0 :element-type 'character))

(define-symbol-macro +html-content-type+ "text/html; charset=utf-8")
(defstaticvar *content-buffer* (make-buffer +content-buffer-size+))
(defstaticvar *hourly-mark* (unix-time (get-local-time)))
(defstaticvar *line-buffer* (make-line-buffer))
(defstaticvar *quoted-string* (make-line-buffer))
(defparameter *request* (make-request))
(defparameter *session* nil)

(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 fixnum 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 dot-position (max-fill-pointer 80))
  (when (<= (fill-pointer buffer) max-fill-pointer) (return-from trim-buffer buffer))
  (let ((new-fill-pointer (position #\- buffer :end max-fill-pointer :from-end t))
        (type (if dot-position (subseq buffer (1+ dot-position)))))
    ;; Allow type even if it puts us (slightly) over the MAX-FILL-POINTER.
    (setf (fill-pointer buffer) (or new-fill-pointer max-fill-pointer))
    (when (and type (<= (length type) 6)) (format buffer ".~A" type))

(defun collapse (string &optional pathname-type-p &key (start 0) end)
  "Make STRING acceptable as the filename part of a logical namestring."
  (with-lexer (string start end)
    (loop initially (lexer-skip (not word)) with dot-position and state = 0
          with buffer = (make-buffer (- $lexer-end $lexer-start) 'standard-char)
          do (lexer-case (char (loop-finish))
               (word (unless (eql state 0)
                       (let ((position (vector-push-extend #\- buffer)))
                         (when (eql state 2) (setq dot-position position))))
                     (vector-push-extend char buffer) (setq state 0))
               ;; All punctuation other than apostrophe are separators.
               (#\') (#\. (setq state 2)) (otherwise (setq state 1)))
          ;; Retain type marker if specified.
          finally (when (and pathname-type-p dot-position)
                    (setf (char buffer dot-position) #\.)
                    (return (trim-buffer buffer dot-position)))
                  (return (trim-buffer buffer)))))

(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) (error "Bad headers in ~S." multipart))
        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)
  (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)))
    (unless (equal value "") value)))

(defun parameter-object (name)
  (let ((value (parameter name)))
    (when (stringp value)
      (uri-object value))))

  (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 variable-name &optional reason-phrase)
  (orf reason-phrase (nstring-capitalize (nsubstitute #\  #\- (string-trim "+" variable-name))))
  `(defstatic ,variable-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 +forbidden+)
(defstatus 404 +not-found+)
(defstatus 405 +method-not-allowed+)

(defmacro end-of-headers (&optional content-type &environment environment)
  (with-output-to-vector (stream nil :external-format +header-external-format+)
    (when (setq content-type (macro-eval content-type environment))
      (format stream "Content-Type: ~A~%" content-type))
    (write-line "Server: Kira" stream) (terpri stream)))

(defun handle-request (request http-output)
  (let* ((request-cookie (request-cookie request)) (*session* (when request-cookie (cookie-session request-cookie)))
         (uri (request-uri request)) (query (uri-query uri)) (object (uri-object uri)) response canonical-path)
    (multiple-value-bind (status location body)
        (cond ((not object) (values +not-found+ nil nil))
              ((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)))) (values response nil))
              (t (if (uri-p response) (values +moved-temporarily+ response) (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* ((response-time (get-local-time))
               (content-length (length body))
               (good-response-p (< status-code 400))
               (request-method (request-method request))
               (cookie (when *session* (session-cookie *session*))))
          (format http-output "Date: ~/kira:822-time/~%" response-time)
          (when (> (- (unix-time response-time) *hourly-mark*) 3600)
            (cache-xml 'rss) (setq *hourly-mark* (unix-time response-time)))
          (when (eq request-method :post) (if good-response-p (fail-safe (commit) (rollback)) (rollback)))
          (when (and cookie (or (not (eql cookie request-cookie)) (renew-session-p *session* response-time)))
            (let ((expiration-time (expiration-time *session*)) (securep (eq (uri-scheme *base-uri*) :https)))
              (format http-output "Set-Cookie: session=~36R; path=/; " cookie)
              (format http-output "expires=~:/kira:822-time/; HttpOnly" expiration-time)
              (if securep (write-line "; Secure" http-output) (terpri http-output))))
          (format http-output "Content-Length: ~D~%" content-length)
          (when location (format http-output "Location: ~A~%" location))
          (cond ((eql content-length 0) (write-sequence (end-of-headers) http-output))
                (t (write-sequence (end-of-headers +html-content-type+) http-output)
                   (unless (eq request-method :head) (write-sequence body http-output))))
          ;; Send the response.
          (finish-output http-output))))))

(defgeneric handle (object)
  (:method ((object-without-post t))
    (throw 'response +method-not-allowed+)))

(defconstant +session-code-bits+ 128)
(defconstant +session-days-alive+ 60)
(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))))))

(define-persistent-class session ()
  ((pad :initform nil :accessor session-pad :initarg :pad)
   (log :initform nil :accessor session-log :initarg :log)
   (name :initform nil :accessor session-name :initarg :name)
   (token :initform nil :accessor session-token :initarg :token)
   (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 :reader session-code :initform (random (ash 1 +session-code-bits+)))
   (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
    (let ((cookie (logior (ash object-id +session-code-bits+) session-code)))
      (setf (slot-value session 'cookie) cookie))))

(defun cookie-session (cookie)
  (let ((code (ldb (byte +session-code-bits+ 0) cookie)))
    (whereas ((session (get-object (ash cookie (- +session-code-bits+)))))
      (when (and (typep session 'session) (= code (session-code session)))

(defun get-response (object &optional (buffer (reset-buffer *content-buffer*)))
  (with-output-to-vector (*html-output* buffer :external-format +content-external-format+)
    (cond ((not (eq (request-method *request*) :post)) (render-page object) buffer)
          (t (orf *session* (make-instance 'session))
             (handle object) (redirect object) buffer))))

(defun redirect (object &rest parameters)
  "Immediately send a 302 redirect to the designated resource."
  (throw 'response (apply #'absolute-uri-to object parameters)))

(defun forbidden-if-not (allow-access-p)
  "Send 403 Forbidden if ALLOW-ACCESS-P is false."
  (or allow-access-p (throw 'response +forbidden+)))

(defun log-condition (condition)
  (let ((now (get-local-time)))
    (with-open-log (stream "kira:data;error.log")
      (format stream "~&[~A] ~A~%" now condition))))

(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
               (setf (values
                      (request-cookie request)
                      (request-address request)
                      (request-parameters request))
                     (values nil))
               (with-accessors ((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 (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))))))))