srv/loop.lisp

;;; -*- mode: LISP; syntax: COMMON-LISP; package: LOOP; -*-
(eval-when (:compile-toplevel :load-toplevel :execute)
  (ql:quickload 
   '(:lisp-unit :str :uiop :cl-ppcre :local-time :clsql-sqlite3 :clingon
     :filesystem-utils :ironclad/digest/sha256)
   :silent t))

(clsql:file-enable-sql-reader-syntax)

(defpackage #:loop
  (:use :common-lisp :local-time)
  (:import-from :lisp-unit define-test)
  (:import-from :org.shirakumo.filesystem-utils 
                directory-p list-directories list-files)
  (:export :main))

(in-package #:loop)

(defstruct account username seen last-post friends pass pass-locked pass-locked-why creation)
(defparameter *accounts* nil)
(defstruct client group (article 1) (username "ANONYMOUS") (auth? 'no))
(defparameter *client* (make-client))
(defstruct request verb args said)
(defstruct response code data request multi-line)
(defvar *default-database* nil)
(defstruct command fn verb description)
(defparameter *commands-assoc* nil)
(defstruct article headers body)
(defparameter *months-inactive-allowed* 3)
(defparameter *months-never-logged-in* 1)
(defvar *debug* nil)
(defun table-of-commands ()
  `(("GROUP" ,#'cmd-group "sets the current group") 
    ("NEXT" ,#'cmd-next "increments the article pointer")
    ("HELP" ,#'cmd-help "displays this menu")
    ("LIST" ,#'cmd-list "lists all groups")
    ("AUTHINFO" ,#'cmd-authinfo "makes me trust you")
    ("LOGIN" ,#'cmd-login "shorter interface to AUTHINFO")
    ("HEAD" ,#'cmd-head "fetches article headers")
    ("MODE" ,#'cmd-mode "handles the mode request from clients")
    ("BODY" ,#'cmd-body "fetches an article body")
    ("POST" ,#'cmd-post "posts your article")
    ("ARTICLE" ,#'cmd-article "fetches full articles")
    ("XOVER" ,#'cmd-xover "fetches the overview database of a group")
    ("CREATE-GROUP" ,#'cmd-create-group 
                    "creates a new group so you can discuss your favorite topic")
    ("CREATE-ACCOUNT",#'cmd-create-account 
                     "creates an account so you can invite a friend")
    ("PASSWD" ,#'cmd-passwd "changes your password")
    ("USERS" ,#'cmd-list-users "lists all users")
    ("DD" ,#'cmd-dd "[d]isplays [d]ata: your state of affairs")
    ("QUIT" ,#'cmd-quit "politely says good-bye")
    ("DATE" ,#'cmd-date "displays the current date at this server")
    ("UNLOCK-ACCOUNT" ,#'cmd-unlock-account "unlocks an account")
    ("REPL" ,#'cmd-repl "lets you hack away")))

(defun set-up-tables! ()
  (labels ((build-commands-assoc (ls)
             (if (null ls) 
                 nil
                 (cons (apply #'make-command-pair (car ls)) 
                       (build-commands-assoc (cdr ls)))))
           (make-command-pair (name fn desc)
             (cons name (make-command :fn fn :verb name :description desc))))
    (setf *commands-assoc* 
          (sort 
           (build-commands-assoc (table-of-commands)) 
           #'string-lessp :key #'car))))

(defun get-command (key)
  (let ((cmd (assoc key *commands-assoc* :test #'string=)))
    (labels ((unrecognized-command ()
               (make-command 
                :fn #'(lambda (r)
                        (make-response
                         :code 400
                         :data "unrecognized command"
                         :request r))
                :verb 'unrecognized
                :description "a command for all commands typed wrong")))
      (or (cdr cmd) (unrecognized-command)))))
(defmacro in-dir (dir &rest body)
  `(let ((*default-pathname-defaults* (truename ,dir)))
     (uiop:with-current-directory (,dir)
       ,@body)))

(defmacro in-groups (&rest body) `(in-dir "groups/" ,@body))

(defun in-group-lambda (g fn) (in-dir g (funcall fn)))

(defmacro in-group (g &rest body)
  `(in-group-lambda ,(fmt "groups/~a/" g) (lambda () ,@body)))

(defmacro with-group (g r &rest body)
  (let ((g-var (gensym))
        (r-var (gensym)))
    `(let ((,g-var ,g)
           (,r-var ,r))
       (if (not (group? ,g-var))
           (make-response :code 411 :request ,r-var
                          :data (format nil "no such group ``~a''" ,g-var))
           (progn ,@body)))))

(defmacro with-n-args (n r &rest body)
  (let ((args-var (gensym))
        (message-var (gensym))
        (n-var n))
    `(let ((,args-var (request-args r))
           (,message-var ,(fmt "bad arguments: needs exactly ~a" n-var)))
       (if (not (= ,n-var (length ,args-var)))
           (make-response :code 400 :request ,r :data ,message-var)
           (progn ,@body)))))

(defmacro with-group-set (&rest body)
  (let ((g-var (gensym)))
    `(let ((,g-var (client-group *client*)))
       (if (not ,g-var) 
           (bad-input r "must say GROUP first")
           ,@body))))

(defmacro with-auth (&rest body)
  `(if (not (auth?))
       (make-response :code 400 :data "You must authenticate first.")
       (progn ,@body)))

(defun print/finish (&rest args)
  (apply #'format (cons t args))
  (finish-output))

(defun plural (v suffix)
  (if (> v 1) suffix ""))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun fmt (cstr &rest args)
    (apply #'format nil (list* cstr args))))

(defun out (stream &rest args)
  (apply #'format (cons stream args)))

(defun stderr (&rest args)
  (when *debug*
    (apply #'out (cons *error-output* args))
    (finish-output *error-output*)))

(defun stdout (&rest args)
  (apply #'out (list* *standard-output* args)))

(defun println (&rest args)
  (apply #'out (list* *standard-output* (str:concat (car args) "~%") (cdr args))))

(defun enumerate (ls &optional (first-index 0))
  (loop for e in ls and i from first-index
    collect (cons i e)))

(defun ucs-2->ascii (bs) 
  ;; I'm a Windows user.
  #-win32 bs #+win32 (remove-if #'zerop bs))

(defun bad-input (r msg &key code) 
  (make-response :code (or code 400) :data msg :request r))

(defun integer->string (n)
  (format nil "~a" n))

(defun mkstr (&rest args) ;; a utility
  (with-output-to-string (s)
    (dolist (a args) (princ a s))))

(defun data (&rest args) ;; a utility
  (flatten (map 'list #'data->bytes args)))

(defun crlf ()
  (vector 13 10))

(defun crlf-string ()
  (format nil "~c~c" #\return #\linefeed))

(defun flatten (obj)
  (do* ((result (list obj))
        (node result))
       ((null node) (delete nil result))
    (cond ((consp (car node))
           (when (cdar node) (push (cdar node) (cdr node)))
           (setf (car node) (caar node)))
          (t (setf node (cdr node))))))

(defmacro mac (&rest body)
  `(macroexpand-1 ,@body))
(defun repl (r)
  (in-package :loop)
  (loop
    (print/finish "LOOP> ")
    (let ((expr (read)))
      (if (eq 'quit expr)
          (return 
            (make-response 
             :code 200 :request r 
             :data "Okay, no more REPL hacking."))
          (println "~a" (eval expr))))))
(defun empty-response () (make-response :code 400 :data "I beg your pardon?"))
(defun prepend-response-with (message r)
  (make-response 
   :code (response-code r) 
   :data (data message (crlf) (response-data r))
   :multi-line (response-multi-line r)
   :request (response-request r)))
(defun append-crlf-if-needed (seq)
  (cond 
    ((stringp seq)
     (append-crlf-if-needed (string->bytes seq)))
    ((listp seq)
     (append seq 
             (when (not (= (car (last seq)) 10))
               (list 13 10))))
    (t (error (format nil "append-crlf-if-needed: unsupported type: ~a" (type-of seq))))))

(defun send-response! (r)
  (let ((bs (data (integer->string (response-code r)) " " 
                  (append-crlf-if-needed (response-data r)))))
    (my-write bs *standard-output*)
    (stderr ">>> ~a" (bytes->string (ucs-2->ascii bs))))
  (when (response-multi-line r) 
    (let ((bs (data "." (crlf))))
      (my-write bs *standard-output*)
      (stderr ">>> ~a" (bytes->string (ucs-2->ascii bs)))))
  (force-output)
  r)
(defun my-write (ls-of-bytes s)
  (if (interactive-stream-p s)
      (write-sequence (mapcar #'code-char ls-of-bytes) s)
      (write-sequence ls-of-bytes s)))
(defun parse-request (r)
  (let* ((collapsed-s (str:collapse-whitespaces (request-said r)))
         (ls (str:split " " collapsed-s :omit-nulls 'please)))
    ;; What are we going to do with a null request?
    (cond ((null ls) (make-request :said (request-said r)))
          (t (let ((verb (car ls))
                   (args (cdr ls)))
               (make-request :said (request-said r)
                             :verb (str:upcase verb)
                             :args args))))))
(defun insert-index (m g i)
  (handler-case
      (clsql:insert-records 
       :into "indices"
       :attributes '(id grp article) 
       :values (list (str:trim m) (str:trim g) (str:trim i)))
    (clsql-sys:sql-database-data-error (c)
      (cond ((= (slot-value c 'clsql-sys::error-id) 19)
             'already-indexed)
            (t
             ; We should log this error.
             ;(format t "other error: ~a" (slot-value c 'clsql-sys::database-message))
             'sql-error)))
    (:no-error () 
      nil)))

(defun lookup-index (mid)
  (let* ((found (clsql:select [grp] [article] 
                              :from [indices] 
                              :where [= [id] (str:trim mid)]))
         (article (first found))
         (grp (first article))
         (art (second article)))
    (when found
      (values grp art))))
(defun connect-index! (filename)
  (setq *default-database* (clsql:connect (list filename) :database-type :sqlite3)))

(defun create-index! ()
  (clsql:execute-command "create table if not exists indices 
     (id varchar(1000), grp varchar(1000), article varchar(300))")
  (clsql:execute-command "create unique index if not exists idx_id_1 
    on indices (id)"))

(defun drop-create-index! ()
  (clsql:execute-command "drop table if exists indices")
  (create-index!))
(defun remove-inactive-users! ()
  (loop for u in *accounts* do
    (let ((username (account-username u)))
      (format t "Username: ~a~%" username)
      (cond ((and (not (locked? username))
                  (inactive-from-never-logged-in? username))
             (post-notification 
              :subject (fmt "account ~a removed by Loop" username)
              :body (fmt "~a didn't log in a first time (for ~a month~a) since account creation."
                         username *months-never-logged-in*
                         (plural *months-never-logged-in* "s")))
             (remove-account! username)
             (format t "Removed ~a due to never logging in.~%" username))
            ((and (not (locked? username))
                  (inactive-from-last-seen? username))
             (post-notification 
              :subject (fmt "account ~a locked by Loop" username)
              :body (fmt "~a disappeared for over ~a month~a."
                         username *months-inactive-allowed*
                         (plural *months-inactive-allowed* "s")))
             (lock-account! username 
                            (fmt "disappeared for over ~a months" 
                                 *months-inactive-allowed*))
             (format t "Locked ~a due to long-time-no-see.~%" username))))))
(defun remove-account! (username)
  (loop for u in *accounts* do
        (setf (account-friends u)
              (delete username (account-friends u) :test #'equal)))
  (setf *accounts*
        (delete-if #'(lambda (a) (equal (account-username a) username))
                   *accounts*)))

(defun lock-account! (username why)
  (let ((u (get-account username)))
    (setf (account-pass-locked u) (account-pass u))
    (setf (account-pass u) "locked")
    (setf (account-pass-locked-why u) why)))
(defun user-inactive? (username)
  (or (inactive-from-never-logged-in? username)
      (inactive-from-last-seen? username)))

(defun inactive-from-never-logged-in? (username)
  (let ((u (get-account username)))
    (if (ever-logged-in? username)
        NIL
        (inactive-from? username *months-never-logged-in*
                        #'(lambda () (account-creation u))))))

(defun locked? (username)
    (equal "locked" (account-pass (get-account username))))

(defun inactive-from-last-post? (username)
  (let ((last-post (account-last-post (get-account username)))
        (creation (account-creation (get-account username))))
    (inactive-from? username *months-inactive-allowed*
                    (if last-post 
                        #'(lambda () last-post)
                        #'(lambda () creation)))))

(defun inactive-from-last-seen? (username)
  (let* ((u (get-account username))
         (last-seen (account-seen u))
         (creation (account-creation u)))
    (inactive-from? username *months-inactive-allowed*
                    (if last-seen 
                        #'(lambda () last-seen)
                        #'(lambda () creation)))))

(defun inactive-from? (username months timestamp-source)
  (declare (ignore username))
  (timestamp< 
   (timestamp+ 
    (universal-to-timestamp 
     (funcall timestamp-source)) months :month)
   (now)))

(defun ever-logged-in? (username)
  (account-seen (get-account username)))

(defun never-logged-in? (username)
  (not (ever-logged-in? username)))

(defun list-inactive-users ()
  (loop for u in *accounts* do
        (format t "Username ~a is inactive? ~a~%" 
                (account-username u)
                (user-inactive? (account-username u)))))
(defun loop-epoch ()
  (encode-timestamp 0 0 0 0 1 1 2024))

(defun migrate-add-creation-and-post-date! ()
  (read-accounts!)
  (loop for u in *accounts*
        do (if (not (account-creation u))
               (setf (account-creation u) (timestamp-to-universal (loop-epoch)))
               (setf (account-last-post u) (account-seen u))))
  (write-accounts!))
(defun split-vector (delim v acc &key limit (so-far 1))
  (let ((len (length v)))
    (split-vector-helper delim v len acc limit so-far 0)))

(defun split-vector-helper (delim v len acc limit so-far start)
  (if (zerop len)
      acc
      (let ((pos (search delim v :start2 start :end2 len)))
        (cond ((or (not pos) (and limit (= so-far limit))) 
               (nreverse (cons (subseq v start len) acc)))
              (t (split-vector-helper
                  delim 
                  v
                  len
                  (cons (subseq v start (or pos len)) acc)
                  limit
                  (1+ so-far)
                  (+ pos (length delim))))))))
(defun index-from-fs! ()
  (loop for path in (in-groups (directory "**/*"))
        do (let* ((g (str:trim (first (last (pathname-directory path)))))
                  (i (str:trim (pathname-name path)))
                  (m (str:trim (extract-mid (fetch-article g i)))))
             (when (> (length m) 0)
               (format t "article ~a/~a indexed by ~a~%" g i m)
               (insert-index m g i)))))

(defun remake-index-from-fs ()
  (drop-create-index!)
  (index-from-fs!))
(defun parse-article (v)
  (let ((parts (split-vector (vector 13 10 13 10) v nil :limit 2)))
    (make-article :headers (map 'string #'code-char (car parts)) :body (cadr parts))))

(defun hs-space-collapsed (hs) 
  (cl-ppcre:regex-replace-all (format nil "~a[ ~a]+" (crlf-string) #\tab) hs " "))

(defun hs-lines (lines) (str:split (crlf-string) lines))

(defun parse-header (header)
  (let* ((h (str:collapse-whitespaces header))
         (pos (search ":" h)))
    (when (null pos)
      (throw 'article-syntax-error 
        (values nil (format nil "missing colon in header |~a|" h))))
    (when (<= (length h) (+ 2 pos))
      (throw 'article-syntax-error
        (values nil (format nil "empty header ~a" h))))
    (multiple-value-bind (key val) 
        (values (subseq h 0 pos) (subseq h (+ 2 pos)))
      (cons (str:downcase key) val))))

(defun parse-headers (hs)
  (let ((ls (hs-lines (hs-space-collapsed hs))))
    (mapcar #'(lambda (h) (parse-header h)) ls)))

(defun string-integer? (s) (ignore-errors (parse-integer s)))
(defun get-header-from-article (h a)
  (get-header h (parse-headers (article-headers (parse-article a)))))

(defun get-header (key hs) 
  (let ((pair (assoc key hs :test #'string=)))
    (if pair (cdr pair) "")))

(defun fetch-headers (g i)
  (let* ((a-string (fetch-article g i))
         (a-parsed (parse-article a-string))
         (headers (parse-headers (article-headers a-parsed))))
    (enrich-headers headers a-string)))

(defun enrich-headers (hs a)
  (append hs
    `(("line-count" . ,(format nil "~a" (nlines (article-body (parse-article a)))))
     ("byte-count" . ,(format nil "~a" (length a))))))

(defun nlines (v) (length (split-vector (crlf) v nil)))
(defun fetch-article (g i)
  (in-groups
   (read-file-raw (format nil "~a/~a" g i))))

(defun read-file-raw (path)
  (with-open-file 
      (in path 
          :element-type '(unsigned-byte 8)
          :if-does-not-exist nil)
    (when in
      (let* ((size (sb-posix:stat-size (sb-posix:stat path)))
             (a (make-array size)))
        (read-sequence a in)
        a))))

(defun fetch-body (g i)
  (article-body (parse-article (fetch-article g i))))
(defun encode-body (a) a)
(defun extract-mid (a)
  (lookup "message-id" (parse-headers (article-headers (parse-article a)))))
(defun lookup (key table)
  (cdr (assoc key table :test #'string=)))
(defun dispatch (r)
  (let* ((verb (request-verb r)))
    (if (null verb)
        (empty-response)
        (funcall (command-fn (get-command verb)) r))))

(defun dispatch-line (ln)
  (dispatch (parse-request (make-request :said ln))))
(defun cmd-authinfo (r) 
  (let* ((args (mapcar #'str:upcase (request-args r))))
    (cond 
      ((not (= (length args) 2)) 
       (bad-input r "No, no: I take exactly two arguments."))
      (t 
       (multiple-value-bind (cmd arg) (apply #'values args)
         (cond 
           ((string= cmd "USER")
            (setf (client-username *client*) arg)
            (make-response :code 381 :request r 
                           :data (format nil "Hey, ~a, please tell us your password." arg)))
           ((string= cmd "PASS")
            (if (authinfo-check (client-username *client*) arg)
                (progn 
                  (log-user-in!)
                  (make-response 
                   :code 281 :request r 
                   :data (fmt "Welcome, ~a." (client-username *client*))))
                (make-response :code 400 :request r :data "Sorry. Wrong password.")))
           (t (make-response :code 400 :request r :data "Syntax error. Say ``authinfo USER /your-name/'' then ``authinfo PASS /your-pass/''."))))))))

(defun authinfo-check (username passwd) 
  (pass? username passwd))

(defun auth? ()
  (eq 'yes (client-auth? *client*)))

(defun log-user-in! ()
  (setf (client-auth? *client*) 'yes)
  (let ((u (get-account (client-username *client*))))
    (setf (account-seen u) (get-universal-time)))
  (write-accounts!))
(defun cmd-mode (r) ;; Whatever.
  (make-response :code 200 :request r :data "Sure thing."))
(defun typical-cmd-head-body-article (r fn-name)
  (with-auth
      (with-group-set
          (let ((args (request-args r)))
            (cond ((null args)
                   (funcall fn-name r (client-group *client*) (client-article *client*)))
                  ((= 1 (length args))
                   (let* ((n-or-mid (car args)))
                     (cond ((string-integer? n-or-mid) 
                            (funcall fn-name r (client-group *client*) n-or-mid))
                           (t (multiple-value-bind (group n-str) (lookup-index n-or-mid)
                                (if (and group n-str)
                                    (funcall fn-name r group n-str)
                                    (bad-input r (format nil "Unknown article ~a." n-or-mid))))))))
                  (t (bad-input r "No, no: it takes at most two arguments.")))))))

(defun cmd-head (r)
  (typical-cmd-head-body-article r #'head-response))
(defun cmd-body (r)
  (typical-cmd-head-body-article r #'body-response))
(defun cmd-article (r)
  (typical-cmd-head-body-article r #'article-response))

(defun article-response (r g i)
  (typical-cmd-response 220 r g i #'(lambda (a) (encode-body a))))
(defun head-response (r g i)
  (typical-cmd-response 221 r g i #'(lambda (a) (article-headers (parse-article a)))))
(defun body-response (r g i)
  (typical-cmd-response 222 r g i #'(lambda (a) (encode-body (article-body (parse-article a))))))
(defun typical-cmd-response (code r g i get-data)
  (handler-case 
      (let ((a (fetch-article g i)))
        (cond ((null a) 
               (make-response 
                :code 400 :request r 
                :data (format nil "article ~a/~a does not exist" g i)))
              (t 
               (prepend-response-with
                  (format nil "~a ~a" i (extract-mid a))
                  (make-response :multi-line 'yes :code code 
                                 :request r :data (funcall get-data a))))))
    (sb-posix:syscall-error (c)
      (make-response 
       :code 400 :request r 
       :data (format nil "article ~a/~a: ~a" g i c)))))
(defun cmd-next (r)
  (with-auth
      (let ((g (client-group *client*))
            (n-cur (client-article *client*)))
        (cond
          ((not g) (bad-input :code 412 r "must say GROUP first"))
          (t (multiple-value-bind (low high len) (group-high-low g)
               (declare (ignore low len))
               (cond ((= n-cur high) (bad-input r "you are at the last article already"))
                     (t (article-next! r g)))))))))

(defun article-next! (r g)
  (setf (client-article *client*) (1+ (client-article *client*)))
  (let ((cur (client-article *client*)))
    (make-response :code 223
                   :request r
                   :data (format nil "~a ~a" cur (mid-by-name g cur)))))

(defun mid-by-name (g name)
  (extract-mid (fetch-article g name)))
(defun cmd-xover (r)
  (with-auth
      (with-group-set
          (let ((args (request-args r)))
            (cond ((null args)
                   (xover r (client-article *client*) (client-article *client*)))
                  ((= 1 (length args))
                   (multiple-value-bind (s v) 
                       (cl-ppcre:scan-to-strings "([0-9]+)([-]?)([0-9]*)" (car args))
                     (cond 
                       ((not s) (make-response :code 502 :request r :data "bad syntax"))
                       (t (let ((fr (parse-integer (aref v 0))) 
                                (hifen (aref v 1))
                                (to (ignore-errors (parse-integer (aref v 2)))))
                            (when (not (string= hifen "-"))
                              (setq to fr))                        
                            (xover r fr to))))))
                  (t (make-response :code 502 :request r :data "bad syntax")))))))

(defun xover (r from to)
  (assert (client-group *client*))
  (let* ((g (client-group *client*))
         (ls (get-articles g from to)))
    (cond ((= 0 (length ls)) 
           (make-response :code 420 :request r :data "no articles in the range"))
          (t
           (prepend-response-with 
            "Okay, your overview follows..."
            (make-response 
             :code 224 :request r :multi-line 'yes
             :data (str:join 
                    (crlf-string) 
                    (loop for i in ls
                          collect (xover-format-line 
                                   i
                                   (remove-if-not 
                                    #'(lambda (h) 
                                        (member (car h) (xover-headers) 
                                                :test #'string=))
                                    (fetch-headers g i)))))))))))
(defun xover-format-line (i hs)
  (str:concat (format nil "~a~a" i #\tab)
              (str:join #\tab 
                        (mapcar #'(lambda (h) (get-header h hs))
                                (xover-headers)))))
(defun xover-headers ()
  '("subject" "from" "date" "message-id" "references" "line-count" "byte-count"))
(defun cmd-group (r)
  (with-auth
      (with-n-args 1 r
        (let ((g (car (request-args r))))
          (with-group g r
            (set-group! g)
            (multiple-value-bind (low high len) (group-high-low g)
              (let ((ln (format nil "~a ~a ~a ~a" len low high g)))
                (setf (client-article *client*) low)
                (make-response :code 211 :request r :data ln))))))))

(defun group? (g) 
  (in-groups
   (directory-p g)))

(defun xgroup? (g) 
  (directory-p g))

(defun set-group! (g)
  (setf (client-group *client*) g))
(defstruct group name high low)

(defun cmd-list (r)
  (prepend-response-with 
   "Get in the loop! Lots to choose from."
   (make-response :code 215 :multi-line 'yes
                  :data (str:join (crlf-string) (build-groups-lines (build-groups-structs)))
                  :request r)))

(defun build-groups-lines (ls)
  (reverse
   (mapcar 
    #'(lambda (g) 
        (format nil "~a ~a ~a y" (group-name g) (group-high g) (group-low g))) 
    ls)))

(defun build-groups-structs ()
  (let ((ret-ls nil))
    (dolist (g (list-groups) ret-ls) 
      (multiple-value-bind (low high len) (group-high-low g)
        (declare (ignore len))
        (setf ret-ls (cons (make-group :name g :high high :low low) ret-ls))))))

(defun between? (x from to)
  (<= from x to))
(declaim (inline between?))

(defun filesize (path)
  (sb-posix:stat-size
   (sb-posix:stat path)))

(defun zero-file? (path)
  (= (filesize path) 0))

(defun temporary-article? (path)
  (or (zero-file? path)
      (cl-ppcre:scan "\.tmp$" (namestring path))))

(defun article-ready? (path)
  (not (temporary-article? path)))

(defun loop-directory* (directory &rest args &key &allow-other-keys)
  #+allegro (apply #'directory directory :directories-are-files NIL :follow-symbolic-links NIL args)
  #+(or clozure digitool) (apply #'directory directory :follow-links NIL args)
  #+clisp (apply #'directory directory :circle T :if-does-not-exist :ignore args)
  #+(or cmucl scl) (apply #'directory directory :follow-links NIL :truenamep NIL args)
  #+lispworks (apply #'directory directory :link-transparency NIL args)
  #+sbcl (apply #'directory directory :resolve-symlinks NIL args)
  #-(or allegro clozure digitool clisp cmucl scl lispworks sbcl)
  (apply #'directory directory args))
  
(defun loop-list-files (directory)
  (let ((directory (pathname-utils:to-directory directory)))
    (let* ((directory (pathname-utils:pathname* directory))
           (entries 
             (ignore-errors
              (loop-directory* 
               (merge-pathnames pathname-utils:*wild-file* directory)))))
      (remove-if #'directory-p entries))))

(defun loop-list-directories (directory)
  (let ((directory (pathname-utils:to-directory directory)))
    (let* (#-(or abcl cormanlisp genera xcl)
           (wild (merge-pathnames
                  #-(or abcl allegro cmucl lispworks sbcl scl xcl)
                  pathname-utils:*wild-directory*
                  #+(or abcl allegro cmucl lispworks sbcl scl xcl) "*.*"
                  directory))
           (dirs
             #+(or abcl xcl) (system:list-directory directory)
             #+cormanlisp (cl::directory-subdirs directory)
             #+genera (handler-case (loop for (p . k) in (fs:directory-list directory)
                                          when (eql :directory k) collect p)
                        (fs:directory-not-found () nil))
             #+clozure (ignore-errors (directory* wild :directories T :files NIL))
             #+mcl (ignore-errors (directory* wild :directories T))
             #-(or abcl xcl cormanlisp genera clozure mcl) (loop-directory* wild)))
      (loop for path in dirs
            when (directory-p path)
            collect (pathname-utils:force-directory path)))))

(defun get-articles (g &optional from to)
  (in-groups ;; We might want to optimize this some day.  That's a 
             ;; problem to be studied.
   (let ((as (articles->integers
              (remove-if #'temporary-article? (loop-list-files (truename g))))))
     (sort (remove-if-not
            #'(lambda (x) (between? x (or from x) (or to x))) 
            as)
           #'<))))

(defun group-high-low (g)
  (let* ((articles (get-articles g))
         (sorted-ints (sort articles #'<)))
    (values (or (car sorted-ints) 0) 
            (or (car (last sorted-ints)) 0) 
            (length sorted-ints))))

(defun articles->integers (ls) 
  (remove-if #'null
             (mapcar #'(lambda (g) 
                         (ignore-errors 
                          (parse-integer (basename (uiop:unix-namestring g)))))
                     ls)))

(defun list-groups ()
  (let ((groups (in-groups (loop-list-directories (truename ".")))))
    (sort (mapcar #'(lambda (g) (basename (uiop:unix-namestring g))) groups)
          #'string-lessp)))

(defun last-char (s) (char s (1- (length s))))
(defun basename (path)
  (let ((s (str:collapse-whitespaces path)))
    (if (char= #\/ (last-char s))
        (car (last (pathname-directory s)))
        (file-namestring s))))
(defun cmd-help (r)
  (let ((lines (menu *commands-assoc*)))
    (prepend-response-with 
     "What's on the menu today?"
     (make-response :code 200 :multi-line 'yes
                    :request r 
                    :data (str:join (crlf-string) lines)))))
(defun menu (ls)
  (if (null ls)
      nil
      (cons (display-fn (car ls)) (menu (cdr ls)))))

(defun display-fn (cmd-pair)
  (let ((cmd (cdr cmd-pair)))
    (format nil "~A ~A" 
            (command-verb cmd) 
            (command-description cmd))))
(defun cmd-quit (r)
  (make-response :code 205 :data "Good-bye." :request r))
(defun cmd-date (r)
  (make-response :code 201
                 :request r
                 :data 
                 (format-timestring nil (now))))
(defun conforms? (bs)
  (catch 'article-syntax-error ;; parse-headers might throw
    (let ((headers (parse-headers (article-headers (parse-article bs)))))
      (let ((result (dolist (h (headers-required-from-clients))
                      (when (not (lookup h headers))
                        (return (format nil "missing the /~a/ header" h)))))
            (content-type (get-header "content-type" headers)))
        (cond 
          ((stringp result) (values nil result))
          ((not (text/plain? content-type))
           (values nil (format nil "content-type must be plain/text, but it's ~a" content-type)))
          (t (values t nil)))))))

(defun text/plain? (header-s)
  ;; I say T when S begins with "text/plain" or when S is "".
  (let* ((s (str:collapse-whitespaces header-s))
         (needle "text/plain")
         (len (min (length needle) (length s))))
    (or (zerop len)
        (and (<= (length needle) (length s))
             (string= needle s :end1 len :end2 len)))))

(defun headers-required-from-clients ()
  '("from" "newsgroups" "subject"))
(defun suggest-message-id (&optional (n 20))
  (format nil "<~a@loop>" (random-string n)))

(defun random-string (size)
  (let* ((universe "abcdefghijklmnopqrstuvwxyz")
         (len (length universe))
         (state (make-random-state t))
         mid)
    (dotimes (c size)
      (setq mid (cons (char universe (random len state)) mid)))
    (coerce mid 'string)))
(defun unparse-article (parsed)
  (data
   (let ((ls))
     (dolist (h (parse-headers (article-headers parsed)))
       (setq ls (cons (data (str:capitalize (car h)) ": " (cdr h) (crlf)) ls)))
     (nreverse ls))
   (crlf)
   (article-body parsed)))
(defun ensure-header (h fn bs)
  (let* ((headers (parse-headers (article-headers (parse-article bs)))))
    (if (lookup h headers)
        bs
        (unparse-article
         (make-article 
          :headers 
          (str:join (crlf-string) 
                    (mapcar (lambda (h)
                              (format nil "~a: ~a" (car h) (cdr h))) 
                            (cons (cons h (funcall fn)) headers)))
          :body (article-body (parse-article bs)))))))

(defun get-date ()
  (multiple-value-bind (s m h day mon year dow dst-p tz)
      (get-decoded-time)
    (declare (ignore dow dst-p))
    (format nil "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d GMT~a"
            year mon day h m s (- tz))))

(defun ensure-mid (bs)
  (ensure-header "message-id" #'suggest-message-id bs))
(defun ensure-date (bs)
  (ensure-header "date" #'get-date bs))
(defun newsgroups-header->list (s)
  (mapcar (lambda (n) (str:trim (string-downcase n))) (str:split "," s)))

(defun cmd-post (r)
  (with-auth 
      (send-response! 
       (make-response :code 340 
                      :data (format nil "Okay, go ahead. Suggested message-id ~a."
                                    (suggest-message-id))))
    (let* ((bs (nntp-read-article)))
      (multiple-value-bind (okay? error) (conforms? bs)
        (if (not okay?)
            (make-response :code 400 :request r
                           :data (format nil "Sorry. Your article doesn't conform: ~a." error))
            (multiple-value-bind (code reply) (post bs)
              (make-response :code code :request r :data reply)))))))

(defun post (bs)
  (let ((ngs (newsgroups-header->list 
              (get-header "newsgroups" (parse-headers
                                        (article-headers
                                         (parse-article bs))))))
        ngs-dont-exist)
    (dolist (ng ngs)
      (if (and (group-name-conforms? ng)
               (group? ng))
          (progn 
            (let ((a (ensure-date (ensure-mid bs))))
              (save-article-insist ng (get-next-article-id ng) a (extract-mid a))
              (update-last-post-date! (client-username *client*))))
          (push ng ngs-dont-exist)))
    (if (zerop (- (length ngs) (length ngs-dont-exist)))
        (values 400 "Sorry. There was not a single valid newsgroup specified.")
        (values 240 (data "Thank you! Your article has been saved."
                          (when ngs-dont-exist
                            (data " However, the groups "
                                  (str:join ", " (sort ngs-dont-exist #'string<))
                                  " just don't exist.")))))))
(defun update-last-post-date! (username)
  (let ((u (get-account username)))
    (setf (account-last-post u) (get-universal-time))))
(defun rename-no-extension (old new)
  (rename-file old (make-pathname :name new :type :unspecific)))

(defun save-article-try (name-try bs)
  (let ((name (format nil "~a" name-try))
        (tmp (format nil "~a.tmp" name-try)))
    (with-open-file 
        (s name 
           :direction :output
           :if-exists nil ;; an atomic operation
           :if-does-not-exist :create)
      (when (null s)
          (progn
            (stderr "warning: save-article-try: ~a exists~%" name)
            (return-from save-article-try 'name-exists))))
    (with-open-file 
        (s tmp
           :direction :output
           :if-exists :error
           :if-does-not-exist :create
           :element-type '(unsigned-byte 8))
      (write-sequence bs s))
    (rename-no-extension tmp name)))
(defun save-article-insist (g name a message-id)
  (loop for name from name do
    (in-dir (format nil "groups/~a/" g)
            (when (not (eql 'name-exists (save-article-try name a)))
              (return (values name (insert-index message-id g (fmt "~a" name))))))))

(defun get-next-article-id (g)
  (multiple-value-bind (low high len) (group-high-low g)
    (declare (ignore low len))
    (1+ high)))
(defun nntp-read-article (&optional acc)
  ;; Returns List-of Byte.
  (let* ((ls (ucs-2->ascii (nntp-read-line))))
    (cond ;; 46 == (byte #\.)
      ((equal (list 46) ls) (flatten (add-crlf-between acc))) 
      (t (nntp-read-article (append acc (list ls)))))))
(defun nntp-read-line (&optional (s *standard-input*) acc)
  ;; Returns List-of Byte.
  (let ((x (read-byte s)))
    (cond ((or (null x) (= x 10)) 
           (let ((bs (and acc (nreverse (if (= (car acc) 13) (cdr acc) acc)))))
             (stderr "<<< ~a~%" (bytes->string (ucs-2->ascii bs)))
             bs))
          (t (nntp-read-line s (cons x acc))))))

(defun list->bytes (ls)
  (mapcar #'data->bytes ls))

(defun vector->bytes (v)
  (mapcar #'data->bytes (coerce v 'list)))

(defun data->bytes (d)
  (cond ((null d) nil)
        ((integerp d) (list d))
        ((stringp d) (string->bytes d))
        ((consp d) (list->bytes d))
        ((vectorp d) (vector->bytes d))
        (t (error (format nil "type ~a is not supported" (type-of d))))))

(defun add-crlf-between (ls-of-ls)
  ;; Add \r\n to each ``line''. Returns List-of Byte.
  (mapcar (lambda (ls) (append ls (list 13 10))) ls-of-ls))

(defun string->bytes (s)
  (map 'list #'char-code s))

(defun bytes->string (ls)
  (map 'string #'code-char ls))
(defun cmd-create-group (r)
  (with-n-args 1 r
    (let ((g (string-downcase (car (request-args r)))))
      (multiple-value-bind (okay? reason) 
          (group-name-conforms? g)
        (if (not okay?)
            (make-response :code 580 :request r 
                           :data (format nil "group name does not conform: ~a" reason))
            (progn
              (multiple-value-bind (path created?) 
                  (in-groups (ensure-directories-exist (concatenate 'string g "/")))
                (declare (ignore created?))
                (if (not path)
                    (make-response :code 581 :request r
                                   :data (format nil "could not create group ~a" 
                                                 (if (group? g) 
                                                     "because it already exists" 
                                                     "but we don't know why---sorry!")))
                    (progn
                      (notify-group-created g)
                      (make-response :code 280 :request r
                                     :data (format nil "group ~a created" g)))))))))))

(defun group-name-conforms? (g)
  (let ((okay? (cl-ppcre:scan-to-strings "^([a-z0-9]+)" g)))
    (if okay? 
        (values t nil)
        (values nil "must match ^([a-z0-9]+)"))))
(defun cmd-create-account (r)
  (with-auth 
      (with-n-args 1 r
        (let* ((args (mapcar #'str:upcase (request-args r)))
               (username (car args)))
          (multiple-value-bind (username pass-or-error) (new-account! username (client-username *client*))
            (if (not username)
                (make-response :code 400 :request r
                               :data (fmt "~a. Choose a new name." pass-or-error))
                (progn
                  (notify-user-created username)
                  (make-response :code 200 :request r
                                 :data (fmt "Okay, account ~a created with password ``~a''."
                                            username pass-or-error)))))))))
(defun read-accounts! ()
  (let ((*package* (find-package '#:loop)))
    (with-open-file 
        (s "accounts.lisp"
           :direction :input)
      (setq *accounts* (read s))))
  *accounts*)

(defun string->array (s)
  (make-array (length s) 
              :element-type '(unsigned-byte 8)
              :initial-contents (map 'vector #'char-code s)))

(defun string->sha256 (s)
  (let ((d (ironclad:make-digest :sha256)))
    (ironclad:produce-digest (ironclad:update-digest d (string->array s)))))

(defun new-account! (username invited-by)
  (let* ((u (str:upcase username))
         (p (random-string 6))
         (a (make-account :username u
                          :pass (string->sha256 (str:upcase p))
                          :creation (get-universal-time)))) 
    (if (get-account u)
        (values nil (fmt "account ~a already exists" u))
        (progn
          (push u (account-friends (get-account invited-by)))
          (push a *accounts*)
          (write-accounts!)
          (values (str:upcase username) p)))))
(defun write-accounts! ()
  (let ((name
          (loop 
            (let* ((tmp (random-string 10))
                   (name (format nil "~a.tmp" tmp)))
              (when 
                  (ignore-errors 
                   (with-open-file 
                       (s name
                          :direction :output
                          :if-exists :error
                          :if-does-not-exist :create)
                     (write *accounts* :stream s)))
                (return name))))))
    (if (ignore-errors (rename-file name "accounts.lisp"))
        (values t *accounts*)
        (values nil (format nil "could not rename ~a to accounts.lisp" name)))))

(defun get-account (username)
  (loop for u in *accounts*
        do (when (string= (str:upcase username) (account-username u))
             (return u))))
(defun cmd-unlock-account (r)
  (with-auth 
      (with-n-args 1 r
        (let* ((args (mapcar #'str:upcase (request-args r)))
               (username (car args)))
          (cond ((not (get-account username))
                 (make-response :code 400 :request r
                                :data (fmt "No such account ~a." username)))
                ((not (locked? username))
                 (make-response :code 400 :request r
                                :data (fmt "Can't unlock ~a because it's not locked." username)))
                (t
                 (unlock-account! username)
                 (notify-user-unlocked username)
                 (make-response :code 200 :request r
                                :data (fmt "Okay, account ~a unlocked." username))))))))

(defun unlock-account! (username)
  (let ((u (get-account username)))
    (cond ((not u)
           (values nil "no such account"))
          ((not (locked? username))
           (values nil "account isn't locked"))
          (t
           (setf (account-pass u) (account-pass-locked u))
           (setf (account-pass-locked u) nil)
           (setf (account-pass-locked-why u) nil)))))
(defun cmd-login (r) 
  (let* ((args (mapcar #'str:upcase (request-args r))))
    (cond 
      ((not (= (length args) 2)) 
       (bad-input r "Usage: login your-username your-password"))
      (t 
       (multiple-value-bind (name pass) (apply #'values args)
         (cond 
           ((pass? name pass)
            (log-user-in-as! name)
            (make-response :code 200 :request r
                           :data (fmt "Welcome, ~a." name)))
           (t (make-response :code 400 :request r
                             :data (fmt "Wrong password.")))))))))

(defun log-user-in-as! (name)
  (setf (client-username *client*) name)
  (log-user-in!))
(defun cmd-passwd (r) 
  (with-auth
      (let* ((args (mapcar #'str:upcase (request-args r))))
        (cond 
          ((not (= (length args) 2)) 
           (bad-input r "Usage: passwd current-password new-password"))
          (t 
           (multiple-value-bind (cur new) (apply #'values args)
             (cond 
               ((pass? (client-username *client*) cur)
                (multiple-value-bind (okay? problem) (change-passwd! (client-username *client*) new)
                  (if okay?
                      (make-response :code 200 :request r
                                     :data "You got it. Password changed.")
                      (make-response :code 500 :request r
                                     :data (fmt "Sorry: ~a" problem)))))
               (t (make-response :code 400 :request r
                                 :data (fmt "Sorry. Wrong password."))))))))))

(defun pass? (username pass)
  (let ((u (get-account username)))
    (and 
     u
     (cond ((integerp (account-pass u))
            (eq (sxhash pass) (account-pass u)))
           ((arrayp (account-pass u))
            (equalp (string->sha256 pass) (account-pass u)))
           (t (error "pass? expected to find INTEGERP or ARRAYP but found ~a" (type-of (account-pass u))))))))

(defun change-passwd! (username newpass)
  (let ((u (get-account username)))
    (when (not u)
      (error "I could not find account ~a." username))
    (setf (account-pass u) (string->sha256 (str:upcase newpass)))
    (write-accounts!)))

(defun cmd-list-users (r)
  (with-auth
      (prepend-response-with 
       "List of current users:"
       (make-response 
        :code 200 :request r :multi-line 'yes
        :data (str:join (crlf-string) (list-users))))))

(defun size-of-longest-username ()
  (loop for u in *accounts*
        maximizing (length (account-username u))))

(defun list-users ()
  (read-accounts!)
  (mapcar (lambda (row) (cadr row))
          (sort
           (loop for u in *accounts* 
                 collect (list (account-username u) 
                               (fmt "~v@a~a, ~a, invited ~a" 
                                    (size-of-longest-username)
                                    (account-username u)
                                    (if (locked? (account-username u))
                                        (fmt " (account locked: ~a)"
                                             (account-pass-locked-why u))
                                        "")
                                    (if (last-time-seen (account-username u))
                                        (fmt "last seen on ~a" (last-time-seen (account-username u)))
                                        "never logged in")
                                    (or (account-friends u) "nobody"))))
           #'string<= :key (lambda (row) (car row)))))

(defun universal-to-human (s)
  (format-timestring
   nil
   (universal-to-timestamp s)
   :format +asctime-format+))

(defun last-time-seen (username)
  (let ((u (get-account username)))
    (if u (let ((s (account-seen u)))
            (if s (universal-to-human s))))))
(defun cmd-dd (r) 
  (make-response :code 200 :data (format nil "state: ~a" *client*) :request r))
(defun cmd-repl (r)
  (with-auth
      (repl r)))

(defun notify-group-created (g)
  (post-notification 
   :subject (fmt "new group ~a by ~a" g (client-username *client*))
   :body (fmt "Blame ~a for the group ~a just created." (client-username *client*) g)))

(defun notify-user-created (u)
  (post-notification 
   :subject (fmt "new account ~a by ~a" u (client-username *client*))
   :body (fmt "Blame ~a for inviting ~a." (client-username *client*) u)))

(defun notify-user-unlocked (u)
  (let ((guilty (client-username *client*)))
    (post-notification 
     :subject (fmt "account ~a unlocked by ~a" u guilty)
     :body (fmt "Blame ~a for unlocking ~a." guilty u))))

(defun post-notification (&key subject body)
  (in-groups (ensure-directories-exist "local.control.news/"))
  (when (group? "local.control.news")
    (let ((a (make-news :subject subject :body body)))
        (post (concatenate 'vector (article-headers a) (crlf) (article-body a) (crlf))))))

(defun make-news (&key subject body)
  (make-article 
   :headers (data 
             (add-crlf-between 
              (mapcar 
               (lambda (p) (data (format nil "~a: ~a" (car p) (cdr p))))
               `(("from" . "Loop")
                 ("subject" . ,subject)
                 ("newsgroups" .  "local.control.news")))))
   :body (data body)))

(defun cli/options () 
  (list 
   (clingon:make-option
    :string
    :description "<username> <invited-by> creates a new account"
    :long-name "create-account"
    :key :create-account)
   (clingon:make-option
    :string
    :description "<username> <new-password> changes password"
    :long-name "change-passwd"
    :key :change-passwd)
   (clingon:make-option
    :flag
    :description "lists accounts"
    :short-name #\l
    :long-name "list-accounts"
    :key :list-accounts)
   (clingon:make-option
    :flag
    :description "runs a REPL"
    :short-name #\r
    :long-name "repl"
    :key :repl)
   (clingon:make-option
    :flag
    :description "logging (on stderr)"
    :long-name "logging"
    :key :logging)))
(defun cli/list-accounts ()
  (println (str:join (crlf-string) (list-users))))

(defun cli/create-account (username args)
  (let ((invited-by (car args)))
    (cond ((null invited-by)
           (println "Must specify who invites the new account."))
          ((get-account username)
           (println "Username account ``~a'' already exists." username))
          ((not (get-account invited-by))
           (println "Invited-by account ``~a'' doesn't exist." invited-by))
          (t 
           (multiple-value-bind (okay? pass-or-error) (new-account! username invited-by)
             (if okay?
                 (progn (println "Okay, account ``~a'' created with password ``~a''."
                                 username pass-or-error)
                        (notify-user-created username))
                 (println "Sorry, ~a." pass-or-error)))))))

(defun cli/change-passwd (username args)
  (let* ((random-passwd (random-string 6))
         (given-passwd (car args))
         (new-passwd (or given-passwd random-passwd)))
    (if (not (get-account username))
        (println "No such account ``~a''." username)
        (multiple-value-bind (okay? problem) (change-passwd! username new-passwd)
          (if okay?
              (println "Okay, account ~a now has password ``~a''." username new-passwd)
              (println "Sorry, could not change password: ~a." problem))))))
(defun cli/main (cmd)
  (read-accounts!)
  (connect-index! "message-id.db")
  (create-index!)
  (let ((args (clingon:command-arguments cmd))
        (repl (clingon:getopt cmd :repl))
        (ca (clingon:getopt cmd :create-account))
        (pa (clingon:getopt cmd :change-passwd))
        (la (clingon:getopt cmd :list-accounts))
        (logging (clingon:getopt cmd :logging)))
    (setf *debug* logging)
    (when la
      (cli/list-accounts))
    (when ca
      (cli/create-account ca args))
    (when pa
      (cli/change-passwd pa args))
    (when repl
      (repl))
    (when (and (not la) (not ca) (not pa))
      (server-start))))

(defun cli/command ()
  (clingon:make-command
   :name "loop"
   :description "An NNTP server for a circle of friends."
   :version "0.1" ;; :authors '("Circling Skies <loop@antartida.xyz>")
   :license "GPL v3"
   :options (cli/options)
   :handler #'cli/main))

(defun main-loop ()
  (let* ((bs (nntp-read-line))
         (ln (bytes->string (ucs-2->ascii bs))))
    (let ((r (send-response! (dispatch-line ln))))
      (when (not (response-quit? r))
        (main-loop)))))

(defun request-quit? (r) (and r (string= 'quit (request-verb r))))
(defun response-quit? (r) (and r (request-quit? (response-request r))))

(defun server-start ()
  (set-up-tables!)
  (send-banner!)
  (main-loop))

(defun main ()
  (let ((app (cli/command)))
    (clingon:run app)))

(defun send-banner! ()
  (send-response! 
   (make-response :code 200 :data "Welcome! Say ``help'' for a menu.")))

(setq lisp-unit:*print-failures* t)
(define-test first-test-of-the-west
  (assert-equal 0 0))

(define-test requests
  (let ((nil-request-1 (make-request))
        (nil-request-2 (make-request :said "  ")))
    (assert-true (request=? nil-request-1 (parse-request nil-request-1)))
    (assert-true (request=? nil-request-2 (parse-request nil-request-2)))
    (assert-true (request=? nil-request-1 nil-request-2))))

(define-test commands
  (let ((ht (make-hash-table))
        (c1 (make-command :fn #'cons :verb 'c1 :description "cons cmd"))
        (c2 (make-command :fn #'list :verb 'c2 :description "list cmd")))))

(define-test dispatching
  (assert-true (equalp (empty-response) (dispatch (empty-request)))))