;;; -*- 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 assert-true)
  (:import-from :org.shirakumo.filesystem-utils 
                directory-p list-directories list-files)
  (:import-from :sb-sys interactive-interrupt)
  (:export :main))

(in-package #:loop)

(defparameter *debug* nil)
(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)
(defparameter *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)
(defparameter *enable-nntp-repl* t)
(defstruct nntp-stream-buffer
  (data (make-array 8192 :element-type '(unsigned-byte 8)))
  (head 0 :type fixnum)
  (tail 0 :type fixnum))

(defparameter *network-buffer* (make-nntp-stream-buffer))

(defun nntp-read-line (&optional (s *standard-input*))
  (nntp-read-line-buffered s *network-buffer*))

(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 conforms-to? (s re &optional error-msg)
  "Does string S conform to regular expression RE?"
  (let ((okay? (cl-ppcre:scan-to-strings re s)))
    (if okay? 
        (values t nil)
        (values nil (or error-msg (fmt "must match ~a" re))))))

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

(defun word-plural (n word)
  (let ((table '(("doesn't" . "don't")
                 ("newsgroup" . "newsgroups"))))
    (let ((w (assoc word table :test #'string=)))
      (when (not w) (error "word not found"))
      (if (< n 2) (car w) (cdr w)))))

(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> ")
    (handler-case     
        (let ((expr (read)))
          (if (eq 'quit expr)
              (progn
                ;; At this point, there's \r\n still in the stdin due
                ;; to read having returned a symbol followed by a line 
                ;; termination, so we must wipe that out or nntp-read-line
                ;; will find an empty line after this.
                (clear-input)
                (return 
                  (make-response 
                   :code 200 :request r 
                   :data "Okay, that's enough hacking for today.")))
              (println "~a" (eval expr))))
      (end-of-file () 
        (print/finish "^D~%")
        (uiop:quit 0))
      (interactive-interrupt () 
        (print/finish "^C~%")
      (uiop:quit 0))
      (t (c) 
        (print/finish 
         "Oops: ~a~%" 
         (str:collapse-whitespaces 
          (str:replace-all (string #\linefeed) " " (fmt "~a" c))))))))

(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 (list 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)
  ;; Write the response code and a space
  (send-chunk! (integer->string (response-code r)) *standard-output*)
  (send-chunk! " " *standard-output*)
  ;; Write the actual payload (status text + article body)
  (send-chunk! (response-data r) *standard-output*)
  ;; Ensure a CRLF at the end of the payload
  (send-chunk! (crlf) *standard-output*)
  (when (response-multi-line r)
    (send-chunk! "." *standard-output*)
    (send-chunk! (crlf) *standard-output*))
  (force-output)
  r)

(defun my-write (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)))
      (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 ((pos (search #(13 10 13 10) v)))
    (if pos
        (make-article 
         :headers (map 'string #'code-char (subseq v 0 pos))
         ;; Create a zero-copy window into the original byte array.
         :body (make-array (- (length v) (+ pos 4))
                           :element-type (array-element-type v)
                           :displaced-to v
                           :displaced-index-offset (+ pos 4)))
        ;; What should we do if no body is found?  Is that legal NNTP?
        (make-article 
         :headers (map 'string #'code-char v)
         :body (make-array 0 :element-type (array-element-type v))))))

(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 (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 a-parsed)))

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

(defun nlines (v) 
  (loop for b across v
        count (= b 10)))

(defun read-headers-raw (path)
  "Reads from PATH chunk by chunk until CRLF CRLF is found. 
   Returns the byte vector of the headers. Closes the file immediately."
  (with-open-file (in path :element-type '(unsigned-byte 8) :if-does-not-exist nil)
    (when in
      (let ((acc (make-array 8192 :element-type '(unsigned-byte 8) 
                                  :adjustable t :fill-pointer 0))
            (buffer (make-array 8192 :element-type '(unsigned-byte 8)))
            (delim #(13 10 13 10)))
        (loop
          (let ((n (read-sequence buffer in)))
            (when (zerop n) 
              (return acc)) ; EOF reached without body delimiter
            
            ;; Append new bytes to our accumulator
            (let ((start-search (length acc)))
              (dotimes (i n) 
                (vector-push-extend (aref buffer i) acc))
              
              ;; Search for the delimiter. We subtract 3 from our start 
              ;; index to catch delimiters that span across the chunk boundary.
              (let ((pos (search delim acc :start2 (max 0 (- start-search 3)))))
                (when pos
                  ;; Return exactly up to the end of the delimiter
                  (return (subseq acc 0 (+ pos 4))))))))))))

(defstruct file-stream-payload
  (path "" :type string)
  (start-pos 0 :type integer))

(defun fetch-article (g i)
  (in-groups
   (read-headers-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 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 :article))

(defun head-response (r g i)
  (typical-cmd-response 221 r g i :head))

(defun body-response (r g i)
  (typical-cmd-response 222 r g i :body))

(defun typical-cmd-response (code r g i requested-part)
  (handler-case
      (let* ((path (format nil "groups/~a/~a" g i))
             (headers-raw (read-headers-raw path)))
        (if (null headers-raw)
            (make-response :code 400 :request r :data (format nil "article ~a/~a does not exist" g i))
            (let* ((a (parse-article headers-raw))
                   ;; FIX: Pass the raw bytes to extract-mid, not the parsed struct
                   (mid (extract-mid headers-raw))
                   (header-length (length headers-raw))
                   (payload
                     (ecase requested-part
                       (:head (article-headers a))
                       (:body (make-file-stream-payload :path path :start-pos header-length))
                       (:article (list (article-headers a)
                                       (crlf)
                                       (make-file-stream-payload :path path :start-pos header-length))))))
              
              (prepend-response-with (format nil "~a ~a" i mid)
                                     (make-response :multi-line 'yes :code code :request r :data payload)))))
    
    (sb-posix:syscall-error (c)
      (let ((msg (format nil "article ~a/~a: ~a" g i c)))
        (stderr msg)
        (make-response :code 400 :request r :data msg)))
    (error (c)
      (let ((msg (format nil "unexpected condition when reading article ~a/~a: ~a" g i c)))
        (stderr msg)
        (make-response :code 400 :request r :data msg)))))

(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
   (ignore-errors (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)
  (loop for item in ls 
        collect (display-fn item)))

(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 
           (let ((ngs (newsgroups-header->list (get-header "newsgroups" headers)))
                 (ngs-dont-exist nil))
             (dolist (g ngs)
               (when (or (not (group-name-conforms? g))
                         (not (group? g)))
                 (push g ngs-dont-exist)))
             (if (not (zerop (length ngs-dont-exist)))
                 (values nil (format nil "the ~a ~a just ~a exist"
                                     (word-plural (length ngs-dont-exist) "newsgroup")
                                     (str:join ", " (sort ngs-dont-exist #'string<))
                                     (word-plural (length ngs-dont-exist) "doesn'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)
  ;; 1. Build the new headers as a standard string
  (let* ((headers-str (with-output-to-string (s)
                        (dolist (h (parse-headers (article-headers parsed)))
                          (format s "~a: ~a~c~c" (str:capitalize (car h)) (cdr h) #\return #\linefeed))
                        ;; Add the final \r\n separating headers from the body
                        (format s "~c~c" #\return #\linefeed)))
         ;; 2. Convert the string to a small byte array (~1 KB)
         (headers-bytes (make-array (length headers-str)
                                    :element-type '(unsigned-byte 8)
                                    :initial-contents (map 'list #'char-code headers-str)))
         ;; 3. Get the displaced, zero-copy body array
         (body-bytes (article-body parsed)))
    ;; 4. Let SBCL compile this into a fast C-level memcpy
    (concatenate '(vector (unsigned-byte 8)) headers-bytes body-bytes)))

(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 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)
        (cond ((not okay?)
               (make-response 
                :code 400 :request r
                :data (format nil "Sorry. Your article doesn't conform: ~a." error)))
              (t (multiple-value-bind (code reply) (post bs)
                   (update-last-post-date! (client-username *client*))
                   (make-response :code code :request r :data reply))))))))

(defun post (bs)
  (let* ((parsed (parse-article bs))
         (ngs (newsgroups-header->list 
               (get-header "newsgroups" (parse-headers (article-headers parsed)))))
         (a (ensure-date (ensure-mid bs)))
         (mid (extract-mid a)))
    (dolist (ng ngs)
      (save-article-insist ng (get-next-article-id ng) a mid))
    (values 240 (data "Thank you! Your article has been saved."))))

(defun newsgroups-header->list (s)
  (mapcar #'(lambda (n) (str:trim (string-downcase n))) (str:split "," s)))

(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 ()
  ;; Returns a vector of bytes: the article, CRLF between lines, up to
  ;; (excluding) the "." terminator. VECTOR-PUSH-EXTEND grows the
  ;; buffer in amortized O(1) per push, so total cost is O(size of the
  ;; article) rather than O([size of the article]^2).
  (let ((buf (make-array 8192
                         :element-type '(unsigned-byte 8)
                         :adjustable t
                         :fill-pointer 0)))
    (loop
      (let ((ls (nntp-read-line)))
        (stderr "nntp-read-line: [~A]" ls)
        (when (eq ls :eof) (error 'end-of-file :stream *standard-input*))
        (when (end-of-article? ls) (return buf))
        (map nil (lambda (b) (vector-push-extend b buf)) ls)
        (vector-push-extend 13 buf)
        (vector-push-extend 10 buf)))))

(defun end-of-article? (ls)
  ;; A line is the NNTP terminator only if it's exactly the single byte
  ;; 46 (#\.). LENGTH/ELT instead of EQUAL-against-a-list, since
  ;; NNTP-READ-LINE hands back a vector.
  (and ls (not (eq ls :eof)) (= (length ls) 1) (= (elt ls 0) 46)))

(defun nntp-read-line-buffered (stream buffer)
  (let* ((data (nntp-stream-buffer-data buffer))
         (capacity (length data)))
    (labels ((find-lf (start end)
               (position 10 data :start start :end end))
             (extract-line (lf-pos)
               (let* ((start (nntp-stream-buffer-head buffer))
                      ;; If the previous character is CR (13), strip it
                      (end-line (if (and (> lf-pos start) (= (aref data (1- lf-pos)) 13))
                                    (1- lf-pos)
                                    lf-pos))
                      (line (subseq data start end-line)))
                 (setf (nntp-stream-buffer-head buffer) (1+ lf-pos))
                 line))
             (refill-and-extract-line ()
               (let* ((head (nntp-stream-buffer-head buffer))
                      (tail (nntp-stream-buffer-tail buffer))
                      (remaining (- tail head)))
                 ;; 1. Prevent buffer saturation/overflow
                 (when (= remaining capacity)
                   (stderr "line too long in the network buffer: [~A]" (subseq data head tail))
                   (error "no space left on the network buffer for the current line"))
                 
                 ;; 2. Shift remaining bytes to the start (fast memmove)
                 (when (> remaining 0)
                   (replace data data :start1 0 :start2 head :end2 tail))
                 (setf (nntp-stream-buffer-head buffer) 0)
                 (setf (nntp-stream-buffer-tail buffer) remaining)
                 
                 ;; 3. Fetch data via the unified dispatch mechanism
                 (let* ((n (fetch-more-bytes stream data remaining (- capacity remaining)))
                        (new-tail (+ remaining n)))
                   (setf (nntp-stream-buffer-tail buffer) new-tail)
                   (let ((lf-pos (find-lf remaining new-tail)))
                     (if lf-pos
                         (extract-line lf-pos)
                         (refill-and-extract-line)))))))
      
      ;; --- Main flow ---
      (let ((lf-pos (find-lf (nntp-stream-buffer-head buffer) (nntp-stream-buffer-tail buffer))))
        (if lf-pos
            (extract-line lf-pos)
            (refill-and-extract-line))))))

(defun nntp-read-line-buffered-old (stream buffer)
  (let* ((data (nntp-stream-buffer-data buffer))
         (capacity (length data)))
    (labels
        ((find-lf (start end)
           ;; remember that LF = byte 10
           (position 10 data :start start :end end))
         (extract-line (lf-pos)
           (let* ((start (nntp-stream-buffer-head buffer))
                  (end-line (if (and (> lf-pos start)
                                     (= (aref data (1- lf-pos)) 13))
                                (1- lf-pos) ; strip the preceding cr
                                lf-pos))
                  (line (subseq data start end-line)))
             (setf (nntp-stream-buffer-head buffer) (1+ lf-pos))
             line))
         (refill-and-extract-line ()
           (let* ((head (nntp-stream-buffer-head buffer))
                  (tail (nntp-stream-buffer-tail buffer))
                  (remaining (- tail head)))
             (when (= remaining capacity)
               (stderr "line too long in the network buffer: [~A]"
                       (subseq data head tail))
               (error "no space left on the network buffer for the current line"))
             ;; There is space for more lines, but there's a
             ;; partial line waiting to be completed, so we'll
             ;; shift it to the begining of the buffer, so we can
             ;; have more space (as %unix-read might produce more
             ;; data below).
             (when (> remaining 0)
               (replace data data :start1 0 :start2 head :end2 tail))
             (setf (nntp-stream-buffer-head buffer) 0)
             (setf (nntp-stream-buffer-tail buffer) remaining)
             ;; Do the actual reading: we'll block until bytes
             ;; arrive and return whatever the kernel has for us.
             (let* ((n (%unix-read stream data remaining (- capacity remaining)))
                    (new-tail (+ remaining n)))
               (setf (nntp-stream-buffer-tail buffer) new-tail)
               (let ((lf-pos (find-lf remaining new-tail)))
                 (if lf-pos
                     (extract-line lf-pos)
                     (refill-and-extract-line))))))) ; Still no lf; keep reading.
      ;; The main program
      (let ((lf-pos (find-lf (nntp-stream-buffer-head buffer)
                             (nntp-stream-buffer-tail buffer))))
        (if lf-pos
            (extract-line lf-pos) ; line already in buffer; no i/o at all
            (refill-and-extract-line))))))

(defun fetch-more-bytes (stream buf start max-count)
  ;; Attempt the fast, native C-level POSIX read.  If `fd-stream-of`
  ;; fails to find an underlying file descriptor (e.g., SLIME REPL
  ;; streams), it signals a TYPE-ERROR. We catch it and fallback.

  ;; This is kinda silly. Let's remove %portable-read because we
  ;; really don't care about the SMILE REPL, though we use it.
  (handler-case (%unix-read stream buf start max-count)
    (type-error ()
      (%portable-read stream buf start max-count))))

(defun %portable-read (stream buf start max-count)
  ;; Blocks for the VERY FIRST byte to respect the wait-for-data contract,
  ;; preventing busy-waiting loops.
  (let ((first-byte (read-byte stream nil :eof)))
    (when (eq first-byte :eof)
      (error 'end-of-file :stream stream))
    (setf (aref buf start) first-byte)
    
    ;; Slurp any IMMEDIATELY available bytes to minimize looping overhead,
    ;; up to max-count. 'listen' returns T if a byte is ready on the wire.
    (let ((count 1))
      (loop while (and (< count max-count) (listen stream))
            do (let ((b (read-byte stream nil :eof)))
                 (when (eq b :eof) (loop-finish))
                 (setf (aref buf (+ start count)) b)
                 (incf count)))
      count)))

(defun %unix-read (stream buf start max-count)
  ;;; One POSIX read(2) on STREAM's underlying fd.
  ;;;
  ;;; Blocks until at least one byte arrives, then returns immediately with
  ;;; however many bytes the kernel has buffered (up to MAX-COUNT).
  ;;; Retries transparently on EINTR (signals can interrupt system calls).
  ;;; Signals END-OF-FILE when the peer closes the connection.
  (let ((fd (sb-sys:fd-stream-fd (fd-stream-of stream))))
    (sb-sys:with-pinned-objects (buf)
      (loop
        (multiple-value-bind (n err)
            (sb-unix:unix-read fd
                               (sb-sys:sap+ (sb-sys:vector-sap buf) start)
                               max-count)
          (cond
            ((and (null n) (= err sb-unix:eintr)))
            ((or (null n) (zerop n))
             (error 'end-of-file :stream stream))
            (t (return n))))))))

(defun fd-stream-of (stream)
  "Peel away SYNONYM-STREAM and TWO-WAY-STREAM wrappers until we reach
   the underlying FD-STREAM.  Signals a clear error if no FD-STREAM is found."
  (etypecase stream
    (sb-sys:fd-stream  stream)
    (synonym-stream    (fd-stream-of (symbol-value (synonym-stream-symbol stream))))
    (two-way-stream    (fd-stream-of (two-way-stream-input-stream stream)))))

(defun get-interactive-line (stream)
  (let ((line-bytes 
         (make-array 0 
                     :element-type '(unsigned-byte 8) 
                     :adjustable t :fill-pointer 0)))
    (loop for byte = (read-byte stream)
          while byte
          do (vector-push-extend byte line-bytes)
          (when (= byte 10) (loop-finish)) ; 10 means LF = \n
          finally 
          (return 
            (if (zerop (length line-bytes)) 
                nil
                line-bytes)))))

(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 send-chunk! (chunk s)
  "Writes chunks sequentially to the stream."
  (cond ((stringp chunk) 
         (my-write (string->bytes chunk) s))
        ((vectorp chunk) 
         (my-write chunk s))
        ((listp chunk) 
         (dolist (c chunk) 
           (send-chunk! c s)))
        ((integerp chunk) 
         (write-byte chunk s))
        ((file-stream-payload-p chunk)
         (stream-file-to-socket chunk s))))

(defun stream-file-to-socket (payload out-stream)
  "Opens the file, seeks to the start of the body, and streams to the socket 
   while applying on-the-fly NNTP dot-stuffing."
  (with-open-file (in (file-stream-payload-path payload) 
                      :element-type '(unsigned-byte 8))
    (file-position in (file-stream-payload-start-pos payload))
    (let ((buf (make-array 8192 :element-type '(unsigned-byte 8)))
          (at-line-start t)) ; The body implicitly starts at the beginning of a line
      (loop for n = (read-sequence buf in)
            while (plusp n)
            do (loop for i from 0 below n
                     for byte = (aref buf i)
                     do (when (and at-line-start (= byte 46)) ; 46 is '.'
                          (write-byte 46 out-stream))
                        (write-byte byte out-stream)
                        (setf at-line-start (= byte 10))))))) ; 10 is LF (\n)

(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)
  (conforms-to? g "^[^\\s/]+$"))

(defun user-name-conforms? (u)
  (conforms-to? u "^[^\\s]+$"))

(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))))
    (multiple-value-bind (okay? reason) (user-name-conforms? u)
      (declare (ignore reason))
      (cond ((not okay?)
             (values nil (fmt "username must conform to ^[^\\s]+$")))
            ((get-account u)
             (values nil (fmt "account ~a already exists" u)))
            (t
              (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 ((null (account-pass u)) nil)
           ((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 ()
  (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)
  (if *enable-nntp-repl*
      (with-auth
          (repl r))
      (make-response 
       :code 400
       :data "The REPL has been *explicitly* disabled by the sysadmin. :("
       :request 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 "creates a new account"
    :long-name "create-account"
    :key :create-account)
   (clingon:make-option
    :string
    :description "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 right now"
    :short-name #\r
    :long-name "repl"
    :key :repl)
   (clingon:make-option
    :flag
    :description "disables the NNTP REPL"
    :long-name "disable-nntp-repl"
    :key :disable-nntp-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-with-handlers (cmd)
  (handler-case 
      (cli/main cmd)
    (end-of-file ()
      (print/finish "^D~%")
      (uiop:quit 0))
    (interactive-interrupt ()
      (print/finish "^C~%")
      (uiop:quit 0))))

(defun cli/main (cmd)
  (read-accounts!)
  (connect-index! "message-id.db")
  (create-index!)
  (let ((args (clingon:command-arguments cmd))
        (run-server t)
        (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))
        (disable-nntp-repl (clingon:getopt cmd :disable-nntp-repl)))
    (setf *debug* logging)
    (when (or ca pa la)
        (setf run-server nil))
    (when la
      (cli/list-accounts))
    (when ca
      (cli/create-account ca args))
    (when pa
      (cli/change-passwd pa args))
    (when repl
      (repl (make-request :verb "repl" :args '(command-line))))
    (when disable-nntp-repl
      (setq *enable-nntp-repl* nil))
    (when run-server
      (server-start))))

(defun cli/command ()
  (clingon:make-command
   :name "loop"
   :description "An NNTP server for a circle of friends."
   :version "0.0.1"
   :license "GPL v3"
   :options (cli/options)
   :handler #'cli/main-with-handlers))

(defun main-loop ()
  (handler-case
      (loop
       (let* ((bs (nntp-read-line))
              (ln (bytes->string bs)))
         (let ((r (send-response! (dispatch-line ln))))
           (when (response-quit? r)
             (return)))))
    (end-of-file (c)
      (declare (ignore c))
      (stderr "a client disconnected with EOF~%"))
    (error (e)
      (stderr "fatal: ~A" e))))

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

(defun welcome-message ()
  (cl-ppcre:regex-replace-all "HASH" "Welcome! I am LOOP 0.0.1 hash HASH. Say ``help'' for a menu." *git-hash*))
(setq lisp-unit:*print-failures* t)
(define-test dispatching
  (assert-true (equalp (empty-response) (dispatch (make-request)))))

(defun unix->nntp (s) 
  "I substitute \n for \r\n"
  (str:replace-all (fmt "~a" #\linefeed) (crlf-string) s))

(defvar a-post (unix->nntp "From: root
Message-id: <pwtdldytefplntosymvo@loop>
Subject: test
Newsgroups: local.test

Quickest test of the West.
"))

(defvar a-bad-post (unix->nntp "From: root
Message-id: <pwtdldytefplntosymvp@loop>
Subject: a bad test
Newsgroups: local.test, bad.newsgroup

A bad test from the biggest mouth of the south.
"))