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

(in-package :kira)

(eval-always
  (defstatic +header-external-format+  '(:character-encoding :iso-8859-1 :line-termination :crlf))
  (defconstant +multipart-buffer-size+ 131072 "The chunk size for multipart/form-data processing.")
  (defconstant +line-buffer-size+        1024 "The expected header line size (not a hard limit)."))

(defstruct* request
  (uri #u"/system/")
  (method :get)
  parameters
  address
  cookie)

(defstaticvar *content-buffer* (make-buffer +multipart-buffer-size+))
(defstaticvar *line-buffer* (make-buffer +line-buffer-size+ 'character))
(defstaticvar *quoted-string* (make-buffer +line-buffer-size+ 'character))
(defparameter *request* (make-request :uri #u"/**/" :address "0.0.0.0"))
(defparameter *response-time* nil "Sent as the Date header in response.")
(defparameter *timestamp* nil "Timestamp parameter of a POST request.")
(defparameter *content-type* nil "Content-Type header of the response.")

(eval-always
  (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 #\- (symbol-name name))))
  (let ((response-cons `(,status-code . ,(make-status-line status-code reason-phrase))))
    `(setf (get ',name 'http-status) ',response-cons)))

(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))
        content-length))

(defun read-header-line (stream)
  (loop with line-buffer = (reset-buffer *line-buffer*)
        for char = (read-char stream nil :premature-end)
        do (case char
             (#\Newline (return line-buffer))
             (:premature-end (throw 'accept-connection nil))
             (otherwise (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 old-position) (array-total-size window))))
        (declare (type array-index end old-position content-length))
        (replace buffer buffer :start2 old-position :end2 end)
        (decf end old-position) ; Shift towards origin.
        (adjust-array window end :displaced-to buffer)
        (let* ((available-space (- +multipart-buffer-size+ 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)
  "Ensure the window is big enough for a boundary."
  (let ((window (car multipart)))
    (if (< (array-total-size window) (* 2 +line-buffer-size+))
        (read-into-multipart-buffer multipart stream)
        window)))

(eval-always
  (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))
                            ,read-header-tag
                             (with-lexer ((read-header-line ,header-stream))
                               (unless (eql lexer-start lexer-end)
                                 (with-lexer-error ("header")
                                   (let ((,header-name
                                          (match-symbol
                                           ,header-names
                                           :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 #\=)
          (parse-http-value)))

(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))
     find-cr
      (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)
     match-delimiter
      (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 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)))))

(defconstant +session-days-alive+ 90 "Expire this many days from response time.")
(defconstant +session-renewal-at+ 30 "Renew cookie when this many days are left.")
(defparameter *session* nil "The active session, taken from the REQUEST-COOKIE.")

(defun handle-request (request http-output)
  (let* ((request-method (request-method request))
         (request-cookie (request-cookie request))
         (*content-type* "text/html; charset=utf-8")
         (uri (request-uri request)) (query (uri-query uri))
         (*session* (if request-cookie (cookie-session request-cookie)))
         object response canonical-path (*response-time* (get-local-time)))
    (multiple-value-bind (status location body)
        (cond ((not (setq object (find-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))))
              ((symbolp (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)
          (or (get status 'http-status) (list status))
        (check-type status-code (integer 0 999))
        (write-sequence status-line http-output)
        (let ((content-length (length body))
              (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))

(define-compiler-macro
    respond-with (designator)
  `(throw 'response ,designator))

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

(defun check-submission-time-sanity (local-time &optional (minimum-delay (+ 2 (random 5))))
  (when (< (- (universal-time *response-time*) (universal-time local-time)) minimum-delay)
    (respond-with #u"/static/error.shtml?fast")))

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

(defun renew-session-p (session &optional (present *response-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)
   (expiration-time :accessor expiration-time :initform (get-expiration-time))
   (ip-address :accessor ip-address :initform (request-address *request*))
   (code :reader session-code :documentation "MAC of the session ID.")
   (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
    (setf (slot-value session 'cookie) (make-session-cookie object-id session-code))))

(defmethod slot-unbound ((class t) (session session) (slot-name (eql 'code)))
  (setf (slot-value session 'code) (compute-session-code (object-id session))))

(defun cookie-session (cookie &aux session)
  (multiple-value-bind (session-id code) (decode-cookie cookie)
    (when (typep (setq session (get-object session-id)) 'session)
      (when (= code (session-code session)) session))))

(define-persistent-class input-mixin ()
  ((ip-address :initform nil :initarg :ip-address :accessor ip-address)
   (session :initform *session* :initarg :session :accessor session)
   (timestamp :initform nil :initarg :timestamp :accessor timestamp))
  (:default-initargs
    :ip-address (request-address *request*)
    :session *session* :timestamp *timestamp*))

(defun get-response (object request-method &aux (buffer (reset-buffer *content-buffer*)))
  (with-output-to-vector (*html-output* buffer :external-format +content-external-format+)
    (flet ((form-entry (name) (assoc name (request-parameters *request*) :test #'string-equal)))
      (if (eq request-method :post)
          (let ((*timestamp* (parameter 'timestamp nil #'authenticate-timestamp)))
            ;; The dumber bots tend to include an anonymous submit button
            ;; in the form submission (naming it "submit" or a blank name).
            (when (or (form-entry "") (form-entry :submit) (not *timestamp*))
              (respond-with :bad-request))
            (check-submission-time-sanity *timestamp*)
            (orf *session* (make-instance 'session))
            (progn (handle object) (redirect object)))
          ;; Either GET or HEAD request method.
          (progn (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 open-log (pathname &rest options)
  (appendf options '(:if-exists :append :if-does-not-exist :create))
  (appendf options '(:direction :output :external-format :utf-8))
  (apply #'open pathname options))

(defmacro with-open-log ((stream pathname &rest options) &body body)
  `(with-open-stream (,stream (open-log ,pathname ,@options)) ,@body))

(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
    condition))

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

(defun ignore-epipe (stream context)
  (declare (ignore stream context))
  (throw 'accept-connection nil))

(defun http-serve (&key (port 8080))
  (let ((*epipe-handler* #'ignore-epipe))
    (with-open-socket (http-listener
                       :connect :passive :local-port port
                       :type :stream :local-host "127.0.0.1")
      ;; The request object is reused.
      (loop with request = (make-request)
            with *request* = request
            do (catch 'accept-connection
                 (with-accessors ((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 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)))))))))