mathb.lisp

;;;; MathB - A Mathematics Pastebin that Powers MathB.in
;;;; ===================================================


(ql:quickload "hunchentoot")
(require "uiop")


;;; Special Modes
;;; -------------

(defvar *log-mode* t
  "Write logs iff true.")

(defvar *main-mode* t
  "Run main function iff true.")


;;; General Definitions
;;; -------------------

(defun universal-time-string (universal-time-seconds)
  "Return given universal time in yyyy-mm-dd HH:MM:SS +0000 format."
  (multiple-value-bind (sec min hour date month year)
      (decode-universal-time universal-time-seconds 0)
    (format nil "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d +0000"
            year month date hour min sec)))

(defun current-utc-time-string ()
  "Return current UTC date and time in yyyy-mm-dd HH:MM:SS +0000 format."
  (universal-time-string (get-universal-time)))

(defun directory-exists-p (path)
  "Check whether the specified directory exists on the filesystem."
  (uiop:directory-exists-p path))

(defun make-directory (path)
  "Create a new directory along with its parents."
  (ensure-directories-exist path))

(defun read-file (filename)
  "Read file and close the file."
  (uiop:read-file-string filename))

(defun write-file (filename text)
  "Write text to file and close the file."
  (make-directory filename)
  (with-open-file (f filename :direction :output :if-exists :supersede)
    (write-sequence text f)))

(defun append-file (filename text)
  "Append text to file and close the file."
  (make-directory filename)
  (with-open-file (f filename :direction :output
                              :if-exists :append
                              :if-does-not-exist :create)
    (write-sequence text f)))

(defun real-ip ()
  "Return address of the remote client (not of the local reverse-proxy)."
  (hunchentoot:real-remote-addr))

(defun string-starts-with (prefix string)
  "Test that string starts with the given prefix."
  (and (<= (length prefix) (length string))
       (string= prefix string :end2 (length prefix))))

(defun string-replace (old new string)
  "Replace non-empty old substring in string with new substring."
  (with-output-to-string (s)
    (let* ((next-index 0)
           (match-index))
      (loop
        (setf match-index (search old string :start2 next-index))
        (unless match-index
          (format s "~a" (subseq string next-index))
          (return))
        (format s "~a~a" (subseq string next-index match-index) new)
        (setf next-index (+ match-index (length old)))))))

(defun string-trim-whitespace (s)
  "Trim whitespace from given string."
  (string-trim '(#\Space #\Tab #\Return #\Newline) s))

(defun fix-lines (s)
  "Remove carriage returns from string."
  (remove #\Return s))

(defun weekday-name (weekday-index)
  "Given an index, return the corresponding day of week."
  (nth weekday-index '("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun")))

(defun month-name (month-number)
  "Given a number, return the corresponding month."
  (nth month-number '("X" "Jan" "Feb" "Mar" "Apr" "May" "Jun"
                      "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")))

(defun decode-weekday-name (year month date)
  "Given a date, return the day of week."
  (let* ((encoded-time (encode-universal-time 0 0 0 date month year))
         (decoded-week (nth-value 6 (decode-universal-time encoded-time)))
         (weekday-name (weekday-name decoded-week)))
    weekday-name))

(defun simple-date (date-string)
  "Convert yyyy-mm-dd HH:MM:SS TZ to simple date."
  (let* ((year (parse-integer (subseq date-string 0 4)))
         (month (parse-integer (subseq date-string 5 7)))
         (date (parse-integer (subseq date-string 8 10)))
         (hour (parse-integer (subseq date-string 11 13)))
         (minute (parse-integer (subseq date-string 14 16)))
         (month-name (month-name month))
         (weekday-name (decode-weekday-name year month date)))
    (format nil "~a, ~2,'0d ~a ~4,'0d ~2,'0d:~2,'0d GMT"
            weekday-name date month-name year hour minute)))

(defun alist-get (key alist)
  "Given a key, return its value found in the list of parameters."
  (cdr (assoc key alist :test #'string=)))


;;; Tool Definitions
;;; ----------------

(defvar *data-directory* "/opt/data/mathb/"
  "Directory where post files and data are written to and read from.")

(defvar *log-directory* "/opt/log/mathb/"
  "Directory where log files are written to.")

(defun log-file-path ()
  "Return path to the log file."
  (format nil "~amathb.log" *log-directory*))

(defun write-log (fmt &rest args)
  "Log message with specified arguments."
  (when *log-mode*
    (append-file (log-file-path)
     (with-output-to-string (s)
       (format s "~a - [~a] \"~a ~a\" "
               (real-ip)
               (current-utc-time-string)
               (hunchentoot:request-method*)
               (hunchentoot:request-uri*))
       (apply #'format s fmt args)
       (terpri s)))))

(defun lock (directory)
  "Acquire lock for specified directory and return t iff successful."
  (let ((lock-dir (merge-pathnames "lock/" directory))
        (failures 0)
        (max-failures 10)
        (status))
    (loop
      (when (nth-value 1 (ensure-directories-exist lock-dir))
        (write-log "Acquired lock")
        (setf status t)
        (return))
      (incf failures)
      (write-log "Could not acquire lock ~a after ~a of ~a attempts"
                 lock-dir failures max-failures)
      (when (= failures max-failures)
        (write-log "Failed to acquire lock")
        (return))
      (sleep 0.2))
    status))

(defun unlock (directory)
  "Release lock for specified directory."
  (uiop:delete-empty-directory (merge-pathnames "lock/" directory))
  (write-log "Released lock"))

(defun read-options (directory)
  "Read options file."
  (let ((path (merge-pathnames "opt.lisp" directory)))
    (when (probe-file path)
      (read-from-string (read-file path)))))

(defun from-post (name)
  "Get the value of a POST parameter."
  (hunchentoot:post-parameter name))

(defun home-request-p (request)
  "Return true iff the home page is requested."
  (and (member (hunchentoot:request-method request) '(:head :get))
       (string= (hunchentoot:script-name request) "/")))

(defun meta-request-p (request)
  "Return true iff the meta page is requested."
  (and (member (hunchentoot:request-method request) '(:head :get))
       (string= (hunchentoot:script-name request) "/0")))

(defun math-request-p (request)
  "Return true iff a mathematics post is requested."
  (and (member (hunchentoot:request-method request) '(:head :get))
       (string/= (hunchentoot:script-name request) "/")
       (string/= (hunchentoot:script-name request) "/0")
       (every #'digit-char-p (subseq (hunchentoot:script-name request) 1))))

(defun post-request-p (request)
  "Return true iff a post submission has been made."
  (and (member (hunchentoot:request-method request) '(:post))
       (or (string= (hunchentoot:script-name request) "/")
           (every #'digit-char-p (subseq (hunchentoot:script-name request) 1)))))

(defun slug-to-path (directory slug)
  "Convert a slug to path, e.g., 1234567 to /directory/post/1/1234/1234567.txt"
  (let* ((short-prefix (floor slug 1000000))
         (long-prefix (floor slug 1000)))
    (format nil "~apost/~d/~d/~d.txt" directory short-prefix long-prefix slug)))

(defun split-text (text)
  "Split text into head and body."
  (let ((delimiter-index (search (format nil "~%~%") text)))
    (values (subseq text 0 (1+ delimiter-index))
            (subseq text (+ 2 delimiter-index)))))

(defun parse-headers (head)
  "Parse head content into an alist of key-value pairs."
  (let ((next-index 0)
        (headers))
    (loop
      (let* ((sep-index (search ":" head :start2 next-index))
             (end-index (search (format nil "~%") head :start2 sep-index))
             (key (subseq head next-index sep-index))
             (tail (subseq head (1+ sep-index) end-index))
             (value (if (string= tail "") "" (subseq tail 1))))
        (push (cons key value) headers)
        (setf next-index (1+ end-index))
        (when (= next-index (length head))
          (return))))
    headers))

(defun parse-text (text)
  "Parse text into an alist of headers and body."
  (multiple-value-bind (head body) (split-text text)
    (let ((headers (parse-headers head)))
      (values (alist-get "Date" headers)
              (alist-get "Title" headers)
              (alist-get "Name" headers)
              body))))

(defun read-slug (directory)
  "Read slug if it exists."
  (let ((filename (merge-pathnames "slug.txt" directory)))
    (when (probe-file filename)
      (parse-integer (read-file filename)))))

(defun valid-slug (new-slug protected-slug)
  "Check if new slug is protected."
  (if (<= new-slug protected-slug)
      (write-log "Slug ~a is protected" new-slug)
      t))

(defun increment-slug (directory protected-slug)
  "Acquire data lock, increment slug, and return t iff successful."
  (let ((filename (merge-pathnames "slug.txt" directory))
        (slug 0))
    (when (lock directory)
      (when (probe-file filename)
        (setf slug (parse-integer (read-file filename))))
      (incf slug)
      (when (<= slug protected-slug)
        (write-log "Cannot use protected slug ~a" slug)
        (setf slug nil))
      (when slug
        (write-file filename (format nil "~a~%" slug)))
      (unlock directory)
      slug)))

(defun meta-code (directory last-post-time flood-table)
  "Return post code for meta page."
  (let ((slug (read-slug directory))
        (options (read-options directory)))
    (format nil "- Current time: ~a
- Last post time: ~a
- Last post slug: [~a](~a)
- Flood table size: ~a
- Options: ~a"
            (current-utc-time-string)
            (universal-time-string last-post-time)
            slug slug
            (hash-table-count flood-table)
            (floor (length options) 2))))

(defun header-value (s)
  "Format header value to make is suitable for writing to text file."
  (if (string= s "") "" (format nil " ~a" s)))

(defun make-text (date title name code)
  "Convert post fields to text to be written to post file."
  (format nil "Date:~a~%Title:~a~%Name:~a~%~%~a~%"
          (header-value date) (header-value title) (header-value name) code))

(defun render-html (html options date title name code error class)
  "Render HTML for a page."
  (setf html (string-replace "{{ date }}" date html))
  (setf html (string-replace "{{ title }}" title html))
  (setf html (string-replace "{{ name }}" name html))
  (setf html (string-replace "{{ code }}" code html))
  (setf html (string-replace "{{ error }}" error html))
  (setf html (string-replace "{{ class }}" class html)))

(defun error-html (reason)
  "Return HTML for an error message."
  (format nil "<div id=\"error\">ERROR: ~a</div>" reason))


;;; Post Control
;;; ------------

(defvar *last-post-time* 0
  "The universal-time at which the last post was successfully submitted.")

(defvar *flood-table* (make-hash-table :test #'equal :synchronized t)
  "A map of IP addresses to last time they made a successful post.")

(defmacro set-flood-data (ip current-time last-post-time-var flood-table-var)
  "Update flood control state variables."
  `(progn
     (setf ,last-post-time-var ,current-time)
     (setf (gethash ,ip ,flood-table-var) ,current-time)))

(defun accept-post (ip current-time directory slug title name code)
  "Accept post, update flood data, and redirect client to saved post."
  (write-file (slug-to-path directory slug)
              (make-text (universal-time-string current-time) title name code))
  (set-flood-data ip current-time *last-post-time* *flood-table*)
  (write-log "Post ~a written successfully" slug)
  (hunchentoot:redirect (format nil "/~a" slug)))

(defun reject-post (options title name code reason)
  "Reject post with an error message."
  (let ((html (read-file "web/html/mathb.html")))
    (write-log "Post rejected: ~a" reason)
    (render-html html options "" title name code (error-html reason) "")))

(defun process-post (options ip current-time directory title name code)
  "Process post and either accept it or reject it."
  (let ((slug (increment-slug directory (getf options :protect 0))))
    (cond ((not slug)
           (reject-post options title name code "Cannot make slug!"))
          (t
           (accept-post ip current-time directory slug title name code)))))


;;; Validators
;;; ----------

(defun bad-length-p (string min-length max-length)
  "Check if the length of the given string is within a specified range."
  (cond ((< (length string) min-length)
         (format nil "must contain at least ~a character~a"
                 min-length (if (= 1 min-length) "" "s")))
        ((> (length string) max-length)
         (format nil "must not contain more than ~a character~a"
                 max-length (if (= 1 max-length) "" "s")))))

(defun improper-code-p (options code)
  "Check if expected tokens are missing from submitted code."
  (let ((tokens (getf options :expect)))
    (and tokens
         (notany (lambda (token) (search token code)) tokens))))

(defun dodgy-content-p (options title name code)
  "Check if post content contains banned words."
  (let ((words (getf options :block))
        (text (format nil "~a:~a:~a" title name code)))
    (some (lambda (word) (search word text)) words)))

(defun calc-token (a)
  "Calculate token from given integer."
  (let ((b (mod a 91))
        (c (mod a 87)))
    (+ (* 1000000 a) (* 1000 b) c)))

(defun dodgy-post-p (token)
  "Check if post content contains invalid token."
  (let* ((digits (and (string/= token "") (every #'digit-char-p token)))
         (x (if digits (parse-integer token) 0))
         (a (floor x 1000000))
         (xx (calc-token a)))
    (or (< x 123) (/= x xx))))

(defun dodgy-ip-p (options ip)
  "Check if given IP address is not allowed to post."
  (let ((prefixes (getf options :ban))
        (formatted-ip (format nil "~a$" ip))
        (result))
    (dolist (prefix prefixes)
      (when (string-starts-with prefix formatted-ip)
        (setf result ip)
        (return)))
    result))

(defun global-flood-p (options current-time last-post-time)
  "Compute number of seconds before next post will be accepted."
  (let* ((post-interval (getf options :global-post-interval 0))
         (wait-time (- (+ last-post-time post-interval) current-time)))
    (when (plusp wait-time)
      wait-time)))

(defun client-flood-p (options ip current-time flood-table)
  "Compute number of seconds client must wait to avoid client flooding."
  (let ((post-interval (or (getf options :client-post-interval) 0)))
    (maphash #'(lambda (key value)
                 (when (>= current-time (+ value post-interval))
                   (remhash key flood-table)))
             flood-table)
    (write-log "Flood table size is ~a" (hash-table-count flood-table))
    (let* ((last-post-time (gethash ip flood-table 0))
           (wait-time (- (+ last-post-time post-interval) current-time)))
      (when (plusp wait-time)
        wait-time))))

(defun reject-post-p (options ip current-time title name code token)
  "Validate post and return error message if validation fails."
  (let ((min-title-length (getf options :min-title-length 0))
        (max-title-length (getf options :max-title-length 120))
        (min-name-length (getf options :min-name-length 0))
        (max-name-length (getf options :max-name-length 120))
        (min-code-length (getf options :min-code-length 1))
        (max-code-length (getf options :max-code-length 10000))
        (result))
    (cond ((getf options :lock-down)
           "Site is locked down!")
          ((getf options :read-only)
           "New posts have been disabled temporarily!")
          ((setf result (bad-length-p title min-title-length max-title-length))
           (format nil "Title ~a!" result))
          ((setf result (bad-length-p name min-name-length max-name-length))
           (format nil "Name ~a!" result))
          ((setf result (bad-length-p code min-code-length max-code-length))
           (format nil "Code ~a!" result))
          ((or (find #\Return title) (find #\Newline title))
           (format  nil "Title must not contain newline!"))
          ((or (find #\Return name) (find #\Newline name))
           (format  nil "Name must not contain newline!"))
          ((improper-code-p options code)
           "Improper code!")
          ((dodgy-content-p options title name code)
           "Dodgy content!")
          ((dodgy-post-p token)
           "Dodgy post!")
          ((setf result (dodgy-ip-p options ip))
           (format nil "IP address ~a is banned!" result))
          ((setf result (global-flood-p options current-time *last-post-time*))
           (format nil "Wait for ~a s before submitting!" result))
          ((setf result (client-flood-p options ip current-time *flood-table*))
           (format nil "Wait for ~a s before resubmitting!" result)))))


;;; HTTP Request Handlers
;;; ---------------------

(defun home-page (directory)
  "Return HTML of the home page."
  (let ((html (read-file "web/html/mathb.html"))
        (options (read-options directory)))
    (render-html html options "" "" "" "" "" "")))

(defun meta-page (directory)
  "Return HTML of meta page."
  (let ((html (read-file "web/html/mathb.html"))
        (options (read-options directory))
        (date (simple-date (current-utc-time-string)))
        (code (meta-code directory *last-post-time* *flood-table*))
        (class " class=\"post\""))
    (render-html html options date "Metadata" "" code "" class)))

(defun math-page (directory)
  "Return page to client."
  (let* ((html (read-file "web/html/mathb.html"))
         (options (read-options directory))
         (slug (parse-integer (subseq (hunchentoot:script-name*) 1)))
         (path (slug-to-path directory slug))
         (class " class=\"post\""))
    (cond ((getf options :lock-down)
           (render-html html options "" "" "" ""
                        (error-html "Site is locked down!") ""))
          ((probe-file path)
           (multiple-value-bind (date title name code) (parse-text (read-file path))
             (render-html html options (simple-date date)
                          title name code "" class)))
          (t
           (progn (setf (hunchentoot:return-code*) 404) nil)))))

(defun post-response (directory)
  "Process submitted post form."
  (let* ((options (read-options directory))
         (ip (real-ip))
         (current-time (get-universal-time))
         (title (string-trim-whitespace (or (from-post "title") "")))
         (name (string-trim-whitespace (or (from-post "name") "")))
         (code (string-trim-whitespace (fix-lines (or (from-post "code") ""))))
         (token (or (from-post "token") ""))
         (reject (reject-post-p options ip current-time title name code token)))
    (if reject
        (reject-post options title name code reject)
        (process-post options ip current-time directory title name code))))

(defun define-handlers ()
  "Define handlers for HTTP requests."
  (let ((directory *data-directory*))
    (hunchentoot:define-easy-handler (home-handler :uri #'home-request-p) ()
      (home-page directory))
    (hunchentoot:define-easy-handler (meta-handler :uri #'meta-request-p) ()
      (meta-page directory))
    (hunchentoot:define-easy-handler (math-handler :uri #'math-request-p) ()
      (math-page directory))
    (hunchentoot:define-easy-handler (post-handler :uri #'post-request-p) ()
      (post-response directory))))

(defclass custom-acceptor (hunchentoot:easy-acceptor)
  ())

(defmethod hunchentoot:acceptor-status-message
    ((acceptor custom-acceptor) http-status-code &key)
  "Custom error page."
  (let ((html (read-file "web/html/error.html"))
        (reason-phrase (hunchentoot:reason-phrase http-status-code)))
    (setf html (string-replace "{{ status-code }}" http-status-code html))
    (setf html (string-replace "{{ reason-phrase }}" reason-phrase html))
    html))

(defun start-server ()
  "Start HTTP server."
  (let ((acceptor (make-instance 'custom-acceptor
                                 :address "127.0.0.1"
                                 :port 4242
                                 :access-log-destination (log-file-path))))
    (setf (hunchentoot:acceptor-document-root acceptor) #p"_live/")
    (hunchentoot:start acceptor)))

(defun main ()
  "Set up HTTP request handlers and start server."
  (define-handlers)
  (start-server)
  (sleep most-positive-fixnum))

(when *main-mode*
  (main))