test.lisp

;;;; Tests
;;;; =====

(require "uiop")


;;; Test Definitions
;;; ----------------

(defparameter *pass* 0)
(defparameter *fail* 0)
(defvar *quit* nil)

(defun remove-directory (path)
  "Remove the specified directory tree from the file system."
  (uiop:delete-directory-tree (pathname path) :validate t
                                              :if-does-not-exist :ignore))

(defmacro test-case (name &body body)
  "Execute a test case and print pass or fail status."
  `(progn
     (remove-directory #p"test-tmp/")
     (ensure-directories-exist #p"test-tmp/")
     (let ((test-name (string-downcase ',name)))
       (format t "~&~a: " test-name)
       (handler-case (progn ,@body)
         (:no-error (c)
           (declare (ignore c))
           (incf *pass*)
           (format t "pass~%"))
         (error (c)
           (incf *fail*)
           (format t "FAIL~%")
           (format t "~&  ~a: error: ~a~%" test-name c)))
       (remove-directory #p"test-tmp/"))))

(defmacro test-case! (name &body body)
  "Execute a test case and error out on failure."
  `(progn
     (remove-directory #p"test-tmp/")
     (ensure-directories-exist #p"test-tmp/")
     (let ((test-name (string-downcase ',name)))
       (format t "~&~a: " test-name)
       ,@body
       (incf *pass*)
       (format t "pass!~%")
       (remove-directory #p"test-tmp/"))))

(defun test-done ()
  "Print test statistics."
  (format t "~&~%PASS: ~a~%" *pass*)
  (when (plusp *fail*)
    (format t "~&FAIL: ~a~%" *fail*))
  (when *quit*
    (format t "~&~%quitting ...~%~%")
    (uiop:quit (if (zerop *fail*) 0 1))))


;;; Begin Test Cases
;;; ----------------

(defvar *log-mode* nil)
(defvar *main-mode* nil)
(setf *log-mode* nil)
(setf *main-mode* nil)
(load "mathb.lisp")


;;; Test Mocks
;;; ----------

(defclass mock-request ()
  ((method :initarg :method :reader hunchentoot:request-method)
   (script-name :initarg :script-name :reader hunchentoot:script-name)))

(defun make-mock-request (method script-name)
  (make-instance 'mock-request :method method :script-name script-name))


;;; Test Cases for Reusable Definitions
;;; -----------------------------------

(test-case universal-time-string
  (string= (universal-time-string 0) "1900-01-01 00:00:00 +0000")
  (string= (universal-time-string 1) "1900-01-01 00:00:01 +0000")
  (string= (universal-time-string 86399) "1900-01-01 23:59:59 +0000")
  (string= (universal-time-string 86400) "1900-01-02 00:00:00 +0000")
  (string= (universal-time-string 86401) "1900-01-02 00:00:01 +0000")
  (string= (universal-time-string 3541622400) "2012-03-25 00:00:00 +0000"))

(test-case make-directory
  (make-directory "test-tmp/foo/bar/")
  (assert (directory-exists-p "test-tmp/foo/bar/")))

(test-case remove-directory
  (make-directory "test-tmp/foo/bar/")
  (assert (directory-exists-p "test-tmp/foo/bar/"))
  (remove-directory "test-tmp/foo/")
  (assert (not (directory-exists-p "test-tmp/foo/"))))

(test-case read-write-file-single-line
  (let ((text "foo"))
    (write-file "test-tmp/foo.txt" text)
    (assert (string= (read-file "test-tmp/foo.txt") text))))

(test-case read-write-file-multiple-lines
  (let ((text (format nil "foo~%bar~%baz~%")))
    (write-file "test-tmp/foo.txt" text)
    (assert (string= (read-file "test-tmp/foo.txt") text))))

(test-case read-write-file-nested-directories
  (write-file "test-tmp/foo/bar/baz/qux.txt" "foo")
  (assert (string= (read-file "test-tmp/foo/bar/baz/qux.txt") "foo")))

(test-case append-file-single-line
  (append-file "test-tmp/foo.txt" "foo")
  (assert (string= (read-file "test-tmp/foo.txt") "foo")))

(test-case append-file-multiple-lines
  (append-file "test-tmp/foo.txt" "foo")
  (append-file "test-tmp/foo.txt" (format nil "bar~%"))
  (append-file "test-tmp/foo.txt" "baz")
  (append-file "test-tmp/foo.txt" (format nil "qux~%"))
  (assert (string= (read-file "test-tmp/foo.txt")
                   (format nil "foobar~%bazqux~%"))))

(test-case append-file-nested-directories
  (append-file "test-tmp/foo/bar/baz/qux.txt" "foo")
  (append-file "test-tmp/foo/bar/baz/qux.txt" "bar")
  (assert (string= (read-file "test-tmp/foo/bar/baz/qux.txt") "foobar")))

(test-case write-log
  (write-log "~a, ~a" "hello" "world"))

(test-case string-starts-with
  (assert (eq (string-starts-with "" "") t))
  (assert (eq (string-starts-with "foo" "foo") t))
  (assert (eq (string-starts-with "foo" "foobar") t))
  (assert (eq (string-starts-with "foo" "bazfoobar") nil))
  (assert (eq (string-starts-with "foo" "fo") nil))
  (assert (eq (string-starts-with "foo" "fox") nil))
  (assert (eq (string-starts-with "foo" "foO") nil)))

(test-case string-replace-single
  (assert (string= (string-replace "foo" "foo" "foo") "foo"))
  (assert (string= (string-replace "foo" "bar" "") ""))
  (assert (string= (string-replace "foo" "bar" "foo") "bar"))
  (assert (string= (string-replace "foo" "bar" "foofoo") "barbar"))
  (assert (string= (string-replace "foo" "bar" "foo foo") "bar bar")))

(test-case string-replace-multiple
  (assert (string= (string-replace "foo" "x" "foo:foo") "x:x"))
  (assert (string= (string-replace "foo" "x" "foo:foo:") "x:x:")))

(test-case string-trim-whitespace
  (assert (string= (string-trim-whitespace "") ""))
  (assert (string= (string-trim-whitespace " ") ""))
  (assert (string= (string-trim-whitespace " x  ") "x"))
  (assert (string= (string-trim-whitespace (format nil "~%x~%")) "x"))
  (assert (string= (string-trim-whitespace (format nil "x~a" #\Tab)) "x"))
  (assert (string= (string-trim-whitespace (format nil "x~a" #\Return)) "x"))
  (assert (string= (string-trim-whitespace (format nil "x~a" #\Newline)) "x")))

(test-case fix-lines
  (assert (string= (fix-lines (format nil "")) ""))
  (assert (string= (fix-lines (format nil "~c" #\Return)) ""))
  (assert (string= (fix-lines (format nil "~c~%" #\Return)) (format nil "~%")))
  (assert (string= (fix-lines (format nil "a~c" #\Return)) (format nil "a")))
  (assert (string= (fix-lines (format nil "foo~%")) (format nil "foo~%"))))

(test-case weekday-name
  (assert (string= (weekday-name 0) "Mon"))
  (assert (string= (weekday-name 1) "Tue"))
  (assert (string= (weekday-name 2) "Wed"))
  (assert (string= (weekday-name 3) "Thu"))
  (assert (string= (weekday-name 4) "Fri"))
  (assert (string= (weekday-name 5) "Sat"))
  (assert (string= (weekday-name 6) "Sun")))

(test-case month-name
  (assert (string= (month-name 1) "Jan"))
  (assert (string= (month-name 2) "Feb"))
  (assert (string= (month-name 3) "Mar"))
  (assert (string= (month-name 4) "Apr"))
  (assert (string= (month-name 5) "May"))
  (assert (string= (month-name 6) "Jun"))
  (assert (string= (month-name 7) "Jul"))
  (assert (string= (month-name 8) "Aug"))
  (assert (string= (month-name 9) "Sep"))
  (assert (string= (month-name 10) "Oct"))
  (assert (string= (month-name 11) "Nov"))
  (assert (string= (month-name 12) "Dec")))

(test-case decode-weekday-name
  (assert (string= (decode-weekday-name 2019 01 07) "Mon"))
  (assert (string= (decode-weekday-name 2019 03 05) "Tue"))
  (assert (string= (decode-weekday-name 2020 01 01) "Wed"))
  (assert (string= (decode-weekday-name 2020 02 27) "Thu"))
  (assert (string= (decode-weekday-name 2020 02 28) "Fri"))
  (assert (string= (decode-weekday-name 2020 02 29) "Sat"))
  (assert (string= (decode-weekday-name 2020 03 01) "Sun")))

(test-case simple-date
  (assert (string= (simple-date "2012-03-25 00:00:00 +0000")
                   "Sun, 25 Mar 2012 00:00 GMT"))
  (assert (string= (simple-date "2022-08-01 09:10:11 +0000")
                   "Mon, 01 Aug 2022 09:10 GMT")))

(test-case alist-get
  (assert (not (alist-get nil nil)))
  (assert (not (alist-get "a" nil)))
  (assert (not (alist-get "" '(("a" . "apple") ("b" . "ball")))))
  (assert (string= (alist-get "a" '(("a" . "apple") ("b" . "ball"))) "apple")))

(test-case lock-behaviour
  (assert (lock "test-tmp/"))
  (assert (not (lock "test-tmp/")))
  (unlock "test-tmp/")
  (assert (lock "test-tmp/"))
  (unlock "test-tmp/"))

(test-case lock-implementation
  (lock "test-tmp/")
  (assert (directory-exists-p "test-tmp/lock/"))
  (unlock "test-tmp/")
  (assert (not (directory-exists-p "test-tmp/lock/"))))


;;; Test Cases for Tool Definitions
;;; -------------------------------

(test-case home-request-p
  (assert (home-request-p (make-mock-request :get "/")))
  (assert (home-request-p (make-mock-request :head "/")))
  (assert (not (home-request-p (make-mock-request :post "/"))))
  (assert (not (home-request-p (make-mock-request :get "/foo"))))
  (assert (not (home-request-p (make-mock-request :head "/foo"))))
  (assert (not (home-request-p (make-mock-request :post "/foo")))))

(test-case meta-request-p
  (assert (meta-request-p (make-mock-request :get "/0")))
  (assert (meta-request-p (make-mock-request :head "/0")))
  (assert (not (meta-request-p (make-mock-request :post "/0"))))
  (assert (not (meta-request-p (make-mock-request :get "/"))))
  (assert (not (meta-request-p (make-mock-request :head "/"))))
  (assert (not (meta-request-p (make-mock-request :post "/"))))
  (assert (not (meta-request-p (make-mock-request :get "/-1"))))
  (assert (not (meta-request-p (make-mock-request :head "/-1"))))
  (assert (not (meta-request-p (make-mock-request :post "/-1"))))
  (assert (not (meta-request-p (make-mock-request :get "/123"))))
  (assert (not (meta-request-p (make-mock-request :post "/123"))))
  (assert (not (meta-request-p (make-mock-request :post "/123")))))

(test-case math-request-p
  (assert (math-request-p (make-mock-request :get "/1")))
  (assert (math-request-p (make-mock-request :head "/1")))
  (assert (math-request-p (make-mock-request :get "/123")))
  (assert (math-request-p (make-mock-request :head "/123")))
  (assert (not (math-request-p (make-mock-request :post "/123"))))
  (assert (not (math-request-p (make-mock-request :get "/"))))
  (assert (not (math-request-p (make-mock-request :head "/"))))
  (assert (not (math-request-p (make-mock-request :post "/"))))
  (assert (not (math-request-p (make-mock-request :get "/0"))))
  (assert (not (math-request-p (make-mock-request :head "/0"))))
  (assert (not (math-request-p (make-mock-request :post "/0"))))
  (assert (not (math-request-p (make-mock-request :get "/-1"))))
  (assert (not (math-request-p (make-mock-request :head "/-1"))))
  (assert (not (math-request-p (make-mock-request :post "/-1")))))

(test-case post-request-p
  (assert (not (post-request-p (make-mock-request :get "/"))))
  (assert (not (post-request-p (make-mock-request :head "/"))))
  (assert (post-request-p (make-mock-request :post "/")))
  (assert (not (post-request-p (make-mock-request :get "/foo"))))
  (assert (not (post-request-p (make-mock-request :head "/foo"))))
  (assert (not (post-request-p (make-mock-request :post "/foo")))))

(test-case slug-to-path
  (assert (string= (slug-to-path "/x/" 1) "/x/post/0/0/1.txt"))
  (assert (string= (slug-to-path "/x/" 12) "/x/post/0/0/12.txt"))
  (assert (string= (slug-to-path "/x/" 123) "/x/post/0/0/123.txt"))
  (assert (string= (slug-to-path "/x/" 1234) "/x/post/0/1/1234.txt"))
  (assert (string= (slug-to-path "/x/" 12345) "/x/post/0/12/12345.txt"))
  (assert (string= (slug-to-path "/x/" 123456) "/x/post/0/123/123456.txt"))
  (assert (string= (slug-to-path "/x/" 1234567) "/x/post/1/1234/1234567.txt"))
  (assert (string= (slug-to-path "/x/" 12345678) "/x/post/12/12345/12345678.txt")))

(test-case split-text
  (let ((text (format nil "foo~%~%")))
    (multiple-value-bind (head body) (split-text text)
      (assert (string= head (format nil "foo~%")))
      (assert (string= body (format nil "")))))
  (let ((text (format nil "foo~%~%bar")))
    (multiple-value-bind (head body) (split-text text)
      (assert (string= head (format nil "foo~%")))
      (assert (string= body (format nil "bar")))))
  (let ((text (format nil "foo~%~%bar~%")))
    (multiple-value-bind (head body) (split-text text)
      (assert (string= head (format nil "foo~%")))
      (assert (string= body (format nil "bar~%")))))
  (let ((text (format nil "foo~%~%~%bar~%")))
    (multiple-value-bind (head body) (split-text text)
      (assert (string= head (format nil "foo~%")))
      (assert (string= body (format nil "~%bar~%")))))
  (let ((text (format nil "foo~%bar~%baz~%~%quux~%quuz~%")))
    (multiple-value-bind (head body) (split-text text)
      (assert (string= head (format nil "foo~%bar~%baz~%")))
      (assert (string= body (format nil "quux~%quuz~%"))))))

(test-case parse-headers
  (assert (equal (parse-headers (format nil "a: apple~%"))
                 (list (cons "a" "apple"))))
  (assert (equal (parse-headers (format nil "a: apple~%b: ball~%"))
                 (list (cons "b" "ball") (cons "a" "apple"))))
  (assert (equal (parse-headers (format nil "a: apple~%b: ball~%"))
                 (list (cons "b" "ball") (cons "a" "apple"))))
  (assert (equal (parse-headers (format nil "a:~%"))
                 (list (cons "a" ""))))
  (assert (equal (parse-headers (format nil "a:~%b:~%c: cat~%"))
                 (list (cons "c" "cat") (cons "b" "") (cons "a" ""))))
  (assert (equal (parse-headers (format nil "a: ~%b: ~%c: cat~%"))
                 (list (cons "c" "cat") (cons "b" "") (cons "a" "")))))

(test-case parse-text
  (let ((text (format nil "Date: 2012-03-25 00:00:00 +0000~%~%Foo")))
    (multiple-value-bind (date title name body) (parse-text text)
      (assert (string= date "2012-03-25 00:00:00 +0000"))
      (assert (not title))
      (assert (not name))
      (assert (string= body "Foo"))))
  (let ((text "Date: 2012-03-25 00:00:00 +0000
Title: Hello World
Name: Alice

Foo
Bar"))
    (multiple-value-bind (date title name body) (parse-text text)
      (assert (string= date "2012-03-25 00:00:00 +0000"))
      (assert (string= title "Hello World"))
      (assert (string= name "Alice"))
      (assert (string= body (format nil "Foo~%Bar"))))))

(test-case increment-slug
  (assert (= (increment-slug "test-tmp/" 0) 1))
  (assert (= (increment-slug "test-tmp/" 0) 2))
  (assert (= (increment-slug "test-tmp/" 0) 3))
  (lock "test-tmp/")
  (assert (not (increment-slug "test-tmp/" 0)))
  (unlock "test-tmp/")
  (assert (= (increment-slug "test-tmp/" 0) 4))
  (assert (= (increment-slug "test-tmp/" 0) 5)))

(test-case increment-slug-protected
  (assert (= (increment-slug "test-tmp/" 0) 1))
  (assert (= (increment-slug "test-tmp/" 1) 2))
  (assert (not (increment-slug "test-tmp/" 3)))
  (assert (not (increment-slug "test-tmp/" 4)))
  (assert (= (increment-slug "test-tmp/" 2) 3)))

(test-case make-text
  (assert (string= (make-text "" "" "" "")
                   (format nil "Date:~%Title:~%Name:~%~%~%")))
  (assert (string= (make-text "date" "" "" "")
                   (format nil "Date: date~%Title:~%Name:~%~%~%")))
  (assert (string= (make-text "" "title" "" "")
                   (format nil "Date:~%Title: title~%Name:~%~%~%")))
  (assert (string= (make-text "" "" "name" "")
                   (format nil "Date:~%Title:~%Name: name~%~%~%")))
  (assert (string= (make-text "" "" "" "code")
                   (format nil "Date:~%Title:~%Name:~%~%code~%")))
  (assert (string= (make-text "date" "title" "name" "body")
                   (format nil "Date: date~%Title: title~%Name: name~%~%body~%"))))

(test-case set-flood-data
  (let ((x 0)
        (y (make-hash-table :test #'equal)))
    (set-flood-data "ip1" 1000 x y)
    (assert (= x 1000))
    (assert (= (gethash "ip1" y) 1000))))

(test-case improper-code-p
  (assert (not (improper-code-p nil "foo")))
  (assert (not (improper-code-p '(:expect ("foo")) "foo")))
  (assert (not (improper-code-p '(:expect ("foo" "bar")) "foo")))
  (assert (not (improper-code-p '(:expect ("foo" "bar")) "bar")))
  (assert (not (improper-code-p '(:expect ("foo" "bar")) "foobarbaz")))
  (assert (improper-code-p '(:expect ("bar")) "foo"))
  (assert (improper-code-p '(:expect ("bar" "baz")) "foo")))

(test-case dodgy-content-p
  (assert (not (dodgy-content-p nil "foo" "bar" "qux")))
  (assert (not (dodgy-content-p '(:block ("quux")) "foo" "bar" "qux")))
  (assert (not (dodgy-content-p '(:block ("bar")) "b" "a" "r")))
  (assert (dodgy-content-p '(:block ("foo")) "foo" "bar" "qux"))
  (assert (dodgy-content-p '(:block ("bar")) "foo" "bar" "qux"))
  (assert (dodgy-content-p '(:block ("qux")) "foo" "bar" "qux"))
  (assert (dodgy-content-p '(:block ("bar")) "foobarqux" "" ""))
  (assert (dodgy-content-p '(:block ("bar")) "" "foobarqux" ""))
  (assert (dodgy-content-p '(:block ("bar")) "" "" "foobarqux"))
  (assert (dodgy-content-p '(:block ("bar")) "" "" "foobarqux"))
  (assert (dodgy-content-p '(:block ("foo" "bar" "baz")) "foo" "" ""))
  (assert (dodgy-content-p '(:block ("foo" "bar" "baz")) "" "bar" ""))
  (assert (dodgy-content-p '(:block ("foo" "bar" "baz")) "" "" "baz"))
  (assert (dodgy-content-p '(:block ("foo" "bar" "baz")) "foobarbaz" "" ""))
  (assert (dodgy-content-p '(:block ("foo" "bar" "baz")) "" "foobarbaz" ""))
  (assert (dodgy-content-p '(:block ("foo" "bar" "baz")) "" "" "foobarbaz")))

(test-case dodgy-ip-p
  (assert (not (dodgy-ip-p nil "ip1")))
  (assert (not (dodgy-ip-p '(:ban nil) "ip1")))
  (assert (not (dodgy-ip-p '(:ban ("ip1$")) "ip12")))
  (assert (not (dodgy-ip-p '(:ban ("ip2")) "ip1")))
  (assert (not (dodgy-ip-p '(:ban ("ip2" "ip3")) "ip1")))
  (assert (not (dodgy-ip-p '(:ban ("ip1" "ip2")) "xip123")))
  (assert (string= (dodgy-ip-p '(:ban ("ip1")) "ip1") "ip1"))
  (assert (string= (dodgy-ip-p '(:ban ("ip1$")) "ip1") "ip1"))
  (assert (string= (dodgy-ip-p '(:ban ("ip1")) "ip12") "ip12"))
  (assert (string= (dodgy-ip-p '(:ban ("ip1")) "ip123") "ip123"))
  (assert (string= (dodgy-ip-p '(:ban ("ip1" "ip2" "ip3$")) "ip1") "ip1"))
  (assert (string= (dodgy-ip-p '(:ban ("ip1" "ip2" "ip3$")) "ip2") "ip2"))
  (assert (string= (dodgy-ip-p '(:ban ("ip1" "ip2" "ip3$")) "ip3") "ip3")))

(test-case client-flood-p-no-options
  (let ((table (make-hash-table :test #'equal)))
    (assert (not (client-flood-p nil "ip1" 1000 table)))))

(test-case client-flood-p-no-interval
  (let ((table (make-hash-table :test #'equal))
        (options '(:client-post-interval nil)))
    (assert (not (client-flood-p options "ip1" 1000 table)))))

(test-case client-flood-p-one-client
  (let ((table (make-hash-table :test #'equal))
        (options '(:client-post-interval 10)))
    (assert (not (client-flood-p options "ip1" 1000 table)))
    (setf (gethash "ip1" table) 1000)
    (assert (= (client-flood-p options "ip1" 1001 table) 9))
    (assert (= (client-flood-p options "ip1" 1005 table) 5))
    (assert (= (client-flood-p options "ip1" 1009 table) 1))
    (assert (not (client-flood-p options "ip1" 1010 table)))))

(test-case client-flood-p-two-clients
  (let ((table (make-hash-table :test #'equal))
        (options '(:client-post-interval 10)))
    (assert (not (client-flood-p options "ip1" 1000 table)))
    (assert (not (client-flood-p options "ip2" 1003 table)))
    (setf (gethash "ip1" table) 1000)
    (setf (gethash "ip2" table) 1003)
    (assert (= (client-flood-p options "ip1" 1001 table) 9))
    (assert (= (client-flood-p options "ip1" 1005 table) 5))
    (assert (= (client-flood-p options "ip1" 1009 table) 1))
    (assert (not (client-flood-p options "ip1" 1010 table)))
    (assert (= (client-flood-p options "ip2" 1001 table) 12))
    (assert (= (client-flood-p options "ip2" 1005 table) 8))
    (assert (= (client-flood-p options "ip2" 1009 table) 4))
    (assert (not (client-flood-p options "ip2" 1013 table)))))

(test-case reject-post-p-good
  (let ((x (write-to-string (calc-token 123))))
    (assert (not (reject-post-p nil "ip1" 0 "foo" "bar" "baz" x)))
    (assert (not (reject-post-p '(:block ("quux")) "ip1" 0 "foo" "bar" "baz" x)))))

(test-case reject-post-p-read-only
  (let ((x (write-to-string (calc-token 123))))
    (assert (string= (reject-post-p '(:read-only t) "ip1" 0 "foo" "bar" "baz" x)
                     "New posts have been disabled temporarily!"))))

(test-case reject-post-p-title-length
  (let ((x (write-to-string (calc-token 123)))
        (opt '(:min-title-length 2 :max-title-length 4)))
    (assert (not (reject-post-p nil "ip1" 0 "" "bar" "baz" x)))
    (assert (string= (reject-post-p opt "ip1" 0 "" "bar" "baz" x)
                     "Title must contain at least 2 characters!"))
    (assert (string= (reject-post-p opt "ip1" 0 "a" "bar" "baz" x)
                     "Title must contain at least 2 characters!"))
    (assert (not (reject-post-p opt "ip1" 0 "ab" "bar" "baz" x)))
    (assert (not (reject-post-p opt "ip1" 0 "abcd" "bar" "baz" x)))
    (assert (string= (reject-post-p opt "ip1" 0 "abcde" "bar" "baz" x)
                     "Title must not contain more than 4 characters!"))))

(test-case reject-post-p-name-length
  (let ((x (write-to-string (calc-token 123)))
        (opt '(:min-name-length 2 :max-name-length 4)))
    (assert (not (reject-post-p nil "ip1" 0 "foo" "" "baz" x)))
    (assert (string= (reject-post-p opt "ip1" 0 "foo" "" "baz" x)
                     "Name must contain at least 2 characters!"))
    (assert (string= (reject-post-p opt "ip1" 0 "foo" "a" "baz" x)
                     "Name must contain at least 2 characters!"))
    (assert (not (reject-post-p opt "ip1" 0 "foo" "ab" "baz" x)))
    (assert (not (reject-post-p opt "ip1" 0 "foo" "abcd" "baz" x)))
    (assert (string= (reject-post-p opt "ip1" 0 "foo" "abcde" "baz" x)
                     "Name must not contain more than 4 characters!"))))

(test-case reject-post-p-code-length
  (let ((x (write-to-string (calc-token 123)))
        (opt '(:min-code-length 2 :max-code-length 4)))
    (assert (string= (reject-post-p nil "ip1" 0 "foo" "bar" "" x)
                     "Code must contain at least 1 character!"))
    (assert (string= (reject-post-p opt "ip1" 0 "foo" "bar" "" x)
                     "Code must contain at least 2 characters!"))
    (assert (string= (reject-post-p opt "ip1" 0 "foo" "bar" "a" x)
                     "Code must contain at least 2 characters!"))
    (assert (not (reject-post-p opt "ip1" 0 "foo" "bar" "ab" x)))
    (assert (not (reject-post-p opt "ip1" 0 "foo" "bar" "abcd" x)))
    (assert (string= (reject-post-p opt "ip1" 0 "foo" "bar" "abcde" x)
                     "Code must not contain more than 4 characters!"))))

(test-case reject-post-p-title-has-line-break
  (let ((x (write-to-string (calc-token 123)))
        (err "Title must not contain newline!")
        (title))
    (setf title (format nil "foo~c" #\Return))
    (assert (string= (reject-post-p nil "ip1" 0 title "" "bar" x) err))
    (setf title (format nil "foo~c" #\Newline))
    (assert (string= (reject-post-p nil "ip1" 0 title "" "bar" x) err))))

(test-case reject-post-p-name-has-line-break
  (let ((x (write-to-string (calc-token 123)))
        (err "Name must not contain newline!")
        (name))
    (setf name (format nil "foo~c" #\Return))
    (assert (string= (reject-post-p nil "ip1" 0 "" name "bar" x) err))
    (setf name (format nil "foo~c" #\Newline))
    (assert (string= (reject-post-p nil "ip1" 0 "" name "bar" x) err))))

(test-case reject-post-p-expect
  (let ((x (write-to-string (calc-token 123))))
    (assert (string= (reject-post-p '(:expect ("foo")) "ip1" 0 "" "" "bar" x)
                     "Improper code!"))))

(test-case reject-post-p-block
  (let ((x (write-to-string (calc-token 123))))
    (assert (string= (reject-post-p '(:block ("xy")) "ip1" 0 "xy" "yz" "zx" x)
                     "Dodgy content!"))))

(test-case reject-post-p-ban
  (let ((x (write-to-string (calc-token 123))))
    (assert (string= (reject-post-p '(:ban ("ip1")) "ip1xy" 0 "xy" "yz" "zx" x)
                     "IP address ip1xy is banned!"))))

(test-case reject-post-p-client-post-interval
  (let ((options '(:client-post-interval 10))
        (x (write-to-string (calc-token 123)))
        (msg "Wait for ~a s before resubmitting!"))
    (assert (not (reject-post-p options "ip1" 1000 "foo" "bar" "baz" x)))
    (setf (gethash "ip1" *flood-table*) 1000)
    (assert (string= (reject-post-p options "ip1" 1000 "foo" "bar" "baz" x)
                     (format nil msg 10)))
    (assert (string= (reject-post-p options "ip1" 1001 "foo" "bar" "baz" x)
                     (format nil msg 9))))
  (clrhash *flood-table*))

;; End test cases.
(test-done)