loop/srv
1
0
Fork 0
Code Issues Pull requests Activity

Rewrites loop.lisp so that SBCL is happier.

Browse source
This commit is contained in:
Circling Skies 2024-12-13 13:30:59 -03:00
parent 15d69d863a
commit 23c71663a1
3 changed files with 542 additions and 708 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

903
loop.lisp
View file

@ -5,7 +5,7 @@
:filesystem-utils :ironclad/digest/sha256)
:silent t))
(clsql:enable-sql-reader-syntax)
(clsql:file-enable-sql-reader-syntax)
(defpackage #:loop
(:use :common-lisp :local-time)
@ -16,103 +16,247 @@
(in-package #:loop)
(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 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 NNTP server reading from stdout"
:short-name #\s
:long-name "server"
:key :server)
(clingon:make-option
:flag
:description "run a REPL on port 4006"
:short-name #\r
:long-name "repl"
:key :repl)
(clingon:make-option
:flag
:description "turn on debug 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 change-passwd-account))
(println "No such account ``~a''." change-passwd-account)
(multiple-value-bind (okay? problem) (change-passwd! change-passwd-account new-passwd)
(if okay?
(println "Okay, account ~a now has password ``~a''." change-passwd-account new-passwd)
(println "Sorry, could not change password: ~a." problem))))))
(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)
(defvar *debug* nil)
(defun cli/main (cmd)
(read-accounts!)
(connect-index! "message-id.db")
(create-index!)
(let ((args (clingon:command-arguments cmd))
(repl (clingon:getopt cmd :repl))
(server (clingon:getopt cmd :server))
(ca (clingon:getopt cmd :create-account))
(change-passwd-account (clingon:getopt cmd :change-passwd))
(list-accounts (clingon:getopt cmd :list-accounts))
(logging (clingon:getopt cmd :logging)))
(setf *debug* logging)
(when list-accounts
(cli/list-accounts))
(when ca
(cli/create-account ca args))
(when change-passwd-account
(cli/change-passwd change-passwd-account args))
(when repl
(stderr "Running a REPL on localhost:4006...~%"))
(when server
(server-start))))
(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")))
(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 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))))
(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 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)))
@ -185,6 +329,7 @@
#'(lambda () creation)))))
(defun inactive-from? (username months timestamp-source)
(declare (ignore username))
(timestamp<
(timestamp+
(universal-to-timestamp
@ -212,269 +357,6 @@
(setf (account-creation u) (timestamp-to-universal (loop-epoch)))
(setf (account-last-post u) (account-seen u))))
(write-accounts!))
(defvar *default-database* nil)
(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 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 plural (v suffix)
(if (> v 1) "s" ""))
(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))))
(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))
(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)))
(defstruct client group (article 1) (username "ANONYMOUS") (auth? 'no))
(defparameter *client* (make-client))
(defstruct command fn verb description)
(defparameter *commands-assoc* 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")))
(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)))))
(defstruct request verb args said)
(defstruct response code data request multi-line)
(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 main-loop ()
(let* ((bs (nntp-read-line))
(ln (bytes->string (ucs-2->ascii bs))))
(if ln
(let ((r (send-response! (dispatch-line ln))))
(when (not (response-quit? r))
(main-loop)))
(progn
(stderr "eof~%")
'eof))))
(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.")))
(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)))
@ -493,76 +375,18 @@
limit
(1+ so-far)
(+ pos (length delim))))))))
(defstruct article headers body)
(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 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 remake-index-from-fs ()
(drop-create-index!)
(index-from-fs!))
(defun dispatch (r)
(let* ((verb (request-verb r)))
(if (null verb)
@ -1099,10 +923,6 @@
(make-response :code 200 :request r
:data (fmt "Okay, account ~a created with password ``~a''."
username pass-or-error)))))))))
(defparameter *accounts* nil)
(defstruct account username seen last-post friends pass pass-locked pass-locked-why creation)
(defun read-accounts! ()
(let ((*package* (find-package '#:loop)))
(with-open-file
@ -1162,7 +982,7 @@
(username (car args)))
(cond ((not (get-account username))
(make-response :code 400 :request r
:data "No such account ~a." username))
: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)))
@ -1236,6 +1056,50 @@
(setf (account-pass u) (string->sha256 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 notify-group-created (g)
(post-notification
:subject (fmt "new group ~a by ~a" g (client-username *client*))
@ -1268,50 +1132,131 @@
("subject" . ,subject)
("newsgroups" . "local.control.news")))))
:body (data body)))
(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 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 NNTP server reading from stdout"
:short-name #\s
:long-name "server"
:key :server)
(clingon:make-option
:flag
:description "run a REPL on port 4006"
:short-name #\r
:long-name "repl"
:key :repl)
(clingon:make-option
:flag
:description "turn on debug logging on stderr"
:long-name "logging"
:key :logging)))
(defun cli/list-accounts ()
(println (str:join (crlf-string) (list-users))))
(defun 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!)
(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)))))
(connect-index! "message-id.db")
(create-index!)
(let ((args (clingon:command-arguments cmd))
(repl (clingon:getopt cmd :repl))
(server (clingon:getopt cmd :server))
(ca (clingon:getopt cmd :create-account))
(change-passwd-account (clingon:getopt cmd :change-passwd))
(list-accounts (clingon:getopt cmd :list-accounts))
(logging (clingon:getopt cmd :logging)))
(setf *debug* logging)
(when list-accounts
(cli/list-accounts))
(when ca
(cli/create-account ca args))
(when change-passwd-account
(cli/change-passwd change-passwd-account args))
(when repl
(stderr "Running a REPL on localhost:4006...~%"))
(when server
(server-start))))
(defun universal-to-human (s)
(format-timestring
nil
(universal-to-timestamp s)
:format +asctime-format+))
(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))))
(handler-case
(let ((r (send-response! (dispatch-line ln))))
(when (not (response-quit? r))
(main-loop)))
(SB-SYS:INTERACTIVE-INTERRUPT (c)
(declare (ignore c))
(stderr "^c~%")))))
(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.")))
(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))
(setq lisp-unit:*print-failures* t)
(define-test first-test-of-the-west
(assert-equal 0 0))
@ -1330,15 +1275,3 @@
(define-test dispatching
(assert-true (equalp (empty-response) (dispatch (empty-request)))))
(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!))

345
loop.nw
View file

@ -3,6 +3,8 @@
\usepackage[text={6.75in,10in},centering]{geometry}
\usepackage{graphicx}
\usepackage{microtype}
\DisableLigatures[-]{family=tt*}
\usepackage[T1]{fontenc}
\usepackage[utf8]{inputenc}
@ -34,7 +36,7 @@
\let\nwdocspar=\par
%% Popular words.
\newcommand{\lxxp}{{\em loop}}
\newcommand{\lxxp}{{\tt loop}}
\newcommand{\Lp}{{\tt LOOP}}
\newcommand{\lp}{\Lp}
\newcommand{\bug}{{\em bug}}
@ -398,10 +400,12 @@ commands, which is essentially what the user sees when ask for
\verb|HELP|. (Be aware that some clients use the output of
\verb|HELP|. For example, Gnus v5.13.)
<<Table of commands>>=
<<Representation of commands>>=
(defstruct command fn verb description)
(defparameter *commands-assoc* nil)
@
<<Table of commands>>=
(defun table-of-commands ()
`(("GROUP" ,#'cmd-group "sets the current group")
("NEXT" ,#'cmd-next "increments the article pointer")
@ -442,12 +446,14 @@ commands, which is essentially what the user sees when ask for
(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")))
(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)))))
@ %def *commands-assoc* set-up-tables! get-command
@ -468,7 +474,9 @@ mark such responses with [[multi-line]].
<<Representation of requests and responses>>=
(defstruct request verb args said)
(defstruct response code data request multi-line)
@
<<Procedures for requests and responses>>=
(defun empty-response () (make-response :code 400 :data "I beg your pardon?"))
(defun prepend-response-with (message r)
(make-response
@ -480,7 +488,7 @@ mark such responses with [[multi-line]].
Here's how to send a [[response]] to a client.
<<Representation of requests and responses>>=
<<Procedures for requests and responses>>=
(defun append-crlf-if-needed (seq)
(cond
((stringp seq)
@ -519,7 +527,7 @@ It is not fine, however, when it's running in production. But, in
production, {\tt (interactive-stream-p s)} will always be false. How
else should we handle this?
<<Representation of requests and responses>>=
<<Procedures for requests and responses>>=
(defun my-write (ls-of-bytes s)
(if (interactive-stream-p s)
(write-sequence (mapcar #'code-char ls-of-bytes) s)
@ -532,7 +540,7 @@ The commands themselves we call {\tt verbs} and everything else the
user types we call {\tt args}. Observe that upper and lower case
letters are equivalent in request verbs.
<<Representation of requests and responses>>=
<<Procedures for requests and responses>>=
(defun parse-request (r)
(let* ((collapsed-s (str:collapse-whitespaces (request-said r)))
(ls (str:split " " collapsed-s :omit-nulls 'please)))
@ -550,7 +558,7 @@ letters are equivalent in request verbs.
Every command consumes a [[request]] and produces a [[response]]. If
any procedure always produces a [[response]], then delivering a
[[response]] to the user is a matter of sending a string composed of
the [[response]] code contacated with the [[response]] data.
the [[response]] code concatenated with the [[response]] data.
What does \lp\ do? It repetitively reads a line from the user,
processes that line and always replies something back. Then \lp\ is
@ -563,13 +571,13 @@ itself---so we can cascade actions based on a user's request.
(defun main-loop ()
(let* ((bs (nntp-read-line))
(ln (bytes->string (ucs-2->ascii bs))))
(if ln
(handler-case
(let ((r (send-response! (dispatch-line ln))))
(when (not (response-quit? r))
(main-loop)))
(progn
(stderr "eof~%")
'eof))))
(SB-SYS:INTERACTIVE-INTERRUPT (c)
(declare (ignore c))
(stderr "^c~%")))))
(defun request-quit? (r) (and r (string= 'quit (request-verb r))))
(defun response-quit? (r) (and r (request-quit? (response-request r))))
@ -597,16 +605,6 @@ notice I don't know how to support a two-argument option, so I hacked
a solution away.
<<Command-line parsing>>=
(defun cli/command ()
(clingon:make-command
:name "loop"
:description "<<Description>>"
:version "<<Version>>"
:authors '("Circling Skies <loop@antartida.xyz>")
:license "GPL v3"
:options (cli/options)
:handler #'cli/main))
(defun cli/options ()
(list
(clingon:make-option
@ -675,18 +673,17 @@ to do that yet.
(let* ((random-passwd (random-string 6))
(given-passwd (car args))
(new-passwd (or given-passwd random-passwd)))
(if (not (get-account change-passwd-account))
(println "No such account ``~a''." change-passwd-account)
(multiple-value-bind (okay? problem) (change-passwd! change-passwd-account new-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''." change-passwd-account new-passwd)
(println "Okay, account ~a now has password ``~a''." username new-passwd)
(println "Sorry, could not change password: ~a." problem))))))
@
@ %def cli/change-passwd cli/list-accounts cli/create-account
Now let's write the main procedure in command-line parsing.
<<Command-line parsing>>=
(defvar *debug* nil)
(defun cli/main (cmd)
(read-accounts!)
(connect-index! "message-id.db")
@ -709,6 +706,16 @@ Now let's write the main procedure in command-line parsing.
(stderr "Running a REPL on localhost:4006...~%"))
(when server
(server-start))))
(defun cli/command ()
(clingon:make-command
:name "loop"
:description "<<Description>>"
:version "<<Version>>"
:authors '("Circling Skies <loop@antartida.xyz>")
:license "GPL v3"
:options (cli/options)
:handler #'cli/main))
@ %def cli/options cli/command
\section{The request dispatching mechanism}
@ -752,9 +759,11 @@ I should've called the member [[headers]] as [[head]] and not
suggest a list of parsed headers. We're going to rename this in due
time. %% TODO
<<Representation and parsing of articles>>=
<<Representation of articles>>=
(defstruct article headers body)
@
<<How to parse articles>>=
(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))))
@ -787,7 +796,7 @@ time. %% TODO
We now write some procedures that we use when we're build the {\em
overview} of the command \verb|XOVER|.
<<Representation and parsing of articles>>=
<<How to parse articles>>=
(defun get-header-from-article (h a)
(get-header h (parse-headers (article-headers (parse-article a)))))
@ -816,7 +825,7 @@ We just read the article bytes and handle them to the client. It's
the article viewer's---the NNTP client's, that is---responsibility of
interpreting such bytes. That's why we call [[read-sequence]] here.
<<Representation and parsing of articles>>=
<<How to parse articles>>=
(defun fetch-article (g i)
(in-groups
(read-file-raw (format nil "~a/~a" g i))))
@ -842,7 +851,7 @@ article. Since ``\verb|.\r\n|'' is part of the NNTP protocol, we must
handle this gracefully---but notice we have not done anything about
that so far. So we are essentially writing a bug right here.
<<Representation and parsing of articles>>=
<<How to parse articles>>=
(defun encode-body (a) a)
@ %def encode-body
@ -852,7 +861,7 @@ merge with [[extract-mid]]. I think I also wrote more
redundancies---perhaps in the implementatio nof [[xover]]---for not
using [[lookup]]. I need to seek out all such places and organize. %% TODO
<<Representation and parsing of articles>>=
<<How to parse articles>>=
(defun extract-mid (a)
(lookup "message-id" (parse-headers (article-headers (parse-article a)))))
(defun lookup (key table)
@ -876,7 +885,7 @@ use of [[labels]] is when the procedure is so trivial that we have no
reason to think we're doing to debug it.} XXX: replace menu with
[[loop]].
<<Help command>>=
<<Command help>>=
(defun cmd-help (r)
(let ((lines (menu *commands-assoc*)))
(prepend-response-with
@ -911,7 +920,7 @@ procedure [[pass?]] that's defined in the implementation of {\tt
Syntax error. Say ``authinfo USER /your-name/'' then ``authinfo PASS /your-pass/''.
@
<<Authinfo command>>=
<<Command authinfo>>=
(defun cmd-authinfo (r)
(let* ((args (mapcar #'str:upcase (request-args r))))
(cond
@ -969,10 +978,14 @@ same check here.
(make-response :code 200 :request r
:data (fmt "Okay, account ~a created with password ``~a''."
username pass-or-error)))))))))
@
(defparameter *accounts* nil)
<<Representation of accounts>>=
(defstruct account username seen last-post friends pass pass-locked pass-locked-why creation)
(defparameter *accounts* nil)
@ %def *accounts*
<<Command create-account>>=
(defun read-accounts! ()
(let ((*package* (find-package '#:loop)))
(with-open-file
@ -1052,7 +1065,7 @@ unlock it.
(username (car args)))
(cond ((not (get-account username))
(make-response :code 400 :request r
:data "No such account ~a." username))
: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)))
@ -1181,7 +1194,6 @@ invited who.
(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)))))
@ -2391,6 +2403,7 @@ Now we write the procedures that discover what accounts are inactive.
#'(lambda () creation)))))
(defun inactive-from? (username months timestamp-source)
(declare (ignore username))
(timestamp<
(timestamp+
(universal-to-timestamp
@ -2476,7 +2489,7 @@ means 2 bytes. So our conversion is just removing the first byte.
<<Little procedures>>=
(defun plural (v suffix)
(if (> v 1) "s" ""))
(if (> v 1) suffix ""))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun fmt (cstr &rest args)
@ -2573,110 +2586,80 @@ Just say {\tt make loop} to your shell.
(user-homedir-pathname))))
(when (probe-file quicklisp-init)
(load quicklisp-init)))
(ql:quickload :loop :silent t)
(ql:quickload :loop)
(sb-ext:save-lisp-and-die #P"loop"
:toplevel #'loop:main
:executable t
:save-runtime-options t)
@
\section{How to update the remote server}\label{sec:live}
\section{How to get a log of \lp's communication}
XXX: notice we don't include such targets in the [[Makefile]]
anymore. Now we use a [[Makefile.personal]] that we don't release
anymore. We may still keep this section as instruction, but we need
to update it to reflect the facts.
We automate here the process of updating and compilation of a new
version of \lp. It's certain that what we document here is specific
to a single UNIX system, but what's important is that you (dear
reader) see exactly what must be done to go live with the system.
The system is composed of the Lisp package [[loop]].
The first thing to do is copy the files of each package to their
destinations in the remote server. The system depends on
[[quicklisp]] and we use the directory called [[local-projects]] as
the repository of our packages. So we just need ask {\tt ssh} to copy
the files. We begin with [[make]] to extract all source files from
[[loop.nw]], which is the master source code of \lp.
If you invoke \lxxp\ with option [[--logging]], you get logging on
[[stderr]]:
%
\begin{verbatim}
%scp loop.asd loop.lisp me@remote:quicklisp/local-projects/loop
loop.asd | 0 kB | 0.2 kB/s | ETA: 00:00:00 | 100%
loop.lisp | 37 kB | 37.5 kB/s | ETA: 00:00:00 | 100%
$ ./loop -s --logging > /dev/null
@>>> 200 Welcome! Say ``help'' for a menu.
quit
@<<< quit
@>>> 205 Good-bye.
\end{verbatim}
Files copied. Now it's time to produce the executabler from the newly
installed source code. To produce the executable, we run
[[build-exe.lisp]]. I'm going to demonstrate how to run this from my
own development machine. Since I'm running Windows, I use [[plink]]
and not [[ssh]].
But remember that \lp\ runs various processes in parallel, so the
question now is how to unify all processes' logs into a single one.
We can't use
\href{https://cr.yp.to/daemontools/multilog.html}{multilog}, for
instance. The easiest solution now is to send all messages to {\tt
syslog}. FreeBSD and GNU systems come with a program called {\tt
logger}, which is able to write messages to {\tt syslog}. If you're
using \href{https://cr.yp.to/daemontools/svscan.html}{{\tt svscan}},
then you can use a program such as
%
\begin{verbatim}
%scp build-exe.lisp me@remote:loop/
build-exe.lisp | 0 kB | 0.2 kB/s | ETA: 00:00:00 | 100%
%plink -ssh me@remote cd loop/ && sbcl --script loop/build-exe.lisp \
echo "Executable built."
$ cat log/run
#!/bin/sh
exec /usr/bin/logger -i -t loop
\end{verbatim}
Produce the executable is sufficient because we're using Daniel
J. Bernstein's [[tcpserver]]. After replacing the executable in the
file system, new TCP connections will invoke the new executable while
older connections still alive will keep using the older executable
already loaded in memory. There's nothing to restart, in other
words.
The target [[live]] in the [[Makefile]] automates the steps that we
have just described. Have a look at the [[Makefile]], which is not
included here in this literate document. With this automation, we
update the remote system with:
%
\begin{verbatim}
%make live
scp loop.asd loop.lisp \
dbastos@antartida.xyz:quicklisp/local-projects/loop
loop.asd | 0 kB | 0.2 kB/s | ETA: 00:00:00 | 100%
loop.lisp | 37 kB | 37.5 kB/s | ETA: 00:00:00 | 100%
scp build-exe.lisp \
dbastos@antartida.xyz:loop/
build-exe.lisp | 0 kB | 0.2 kB/s | ETA: 00:00:00 | 100%
plink -ssh dbastos@antartida.xyz cd loop/ && \
sbcl --script build-exe.lisp && \
echo "Executable built."
Executable built.
\end{verbatim}
Yes, we could parameterize the command with the address of the remote
server and remote path to the installation. But perhaps we will
always be the ones using this system, so we will delay this task until
further notice. %% TODO
as your {\tt log/run} script. See {\tt logger(1)} for more
information. Using {\tt logger(1)} means you need to set up {\tt
syslog}, too. By the default, {\tt logger(1)} will use the {\em
facility} {\tt user} and the {\em level} {\tt notice}. So you can
specify in {\tt syslog.conf} the selector {\tt user.notice} and
specify a log file such as {\tt /var/log/loop.log}. See {\tt
syslog.conf(5)} and {\tt newsyslog(1)} for more information.
\section{The package {\tt loop.lisp} as the compiler needs it}
We now put together all source code chunks in the order the compiler
needs to read it. By the way, you see this call to
[[enable-sql-reader-syntax]]? We need it at the top-level of any file
that uses the SQL syntax from [[clsql]]. You can see an illustration
of the syntax in, for example, [[lookup-index]].
One thing to keep in mind here is---I wonder if people that might read
this source code would read the literate programming \LaTeX\ output or
would they read [[loop.lisp]] directly. For literate programmers, it
doesn't matter how [[loop.lisp]] turns out because only the compiler
reads [[loop.lisp]]. But if we care about anyone who might read
[[loop.lisp]], then we should perhaps tell our literate programming
tools to generate a nice-looking file. For instance, I declare global
variables in the chunks where it's used. But for someone reading
[[loop.lisp]] directly, it is perhaps better if they would see all
global variables at the top of the file. That's something to think
about.
needs to read it. One thing to keep in mind here is---I wonder if
people that might read this source code would read the literate
programming \LaTeX\ output or would they read [[loop.lisp]] directly.
For literate programmers, it doesn't matter how [[loop.lisp]] turns
out because only the compiler reads [[loop.lisp]]. But if we care
about anyone who might read [[loop.lisp]], then we should perhaps tell
our literate programming tools to generate a nice-looking file. For
instance, I declare global variables in the chunks where it's used.
But for someone reading [[loop.lisp]] directly, it is perhaps better
if they would see all global variables at the top of the file. That's
something to think about.
<<List of packages to be loaded>>=
:lisp-unit :str :uiop :cl-ppcre :local-time :clsql-sqlite3 :clingon
:filesystem-utils :ironclad/digest/sha256
@
<<Global variables>>=
<<Representation of accounts>>
<<Representation of a client>>
<<Representation of requests and responses>>
<<Reference to the database>>
<<Representation of commands>>
<<Representation of articles>>
(defvar *debug* nil)
@
<<loop.lisp>>=
;;; -*- mode: LISP; syntax: COMMON-LISP; package: LOOP; -*-
(eval-when (:compile-toplevel :load-toplevel :execute)
@ -2684,7 +2667,7 @@ about.
'(<<List of packages to be loaded>>)
:silent t))
(clsql:enable-sql-reader-syntax)
(clsql:file-enable-sql-reader-syntax)
(defpackage #:loop
(:use :common-lisp :local-time)
@ -2695,29 +2678,26 @@ about.
(in-package #:loop)
<<Command-line parsing>>
<<Global variables>>
<<Table of commands>>
<<Macros>>
<<Little procedures>>
<<Procedures for requests and responses>>
<<Essential operations relative to the index>>
<<How to create and connect to the index>>
<<How to remove inactive users>>
<<How to enumerate inactive accounts>>
<<How to migrate accounts without a creation date>>
<<Reference to the database>>
<<How to create and connect to the index>>
<<Essential operations relative to the index>>
<<Little procedures>>
<<Macros>>
<<Representation of a client>>
<<Table of commands>>
<<Representation of requests and responses>>
<<Main loop>>
<<How to split a stream into lines>>
<<Representation and parsing of articles>>
<<How to create an index from the file system>>
<<Dispatching of commands>>
<<Authinfo command>>
<<Command authinfo>>
<<Command mode reader>>
<<Commands head, body, article>>
<<Command xover>>
<<Command group>>
<<Command list>>
<<Help command>>
<<Command help>>
<<Command quit>>
<<Command date>>
<<Command post>>
@ -2725,11 +2705,16 @@ about.
<<Command create-account>>
<<Command login>>
<<Command passwd>>
<<Broadcasting>>
<<Command users>>
<<Command dd>>
<<Broadcasting>>
<<Command-line parsing>>
<<Main loop>>
<<Test procedures>>
<<How to create an index from the file system>>
@ %def
<<*>>=
@ -2748,90 +2733,6 @@ about.
:components ((:file "loop")))
@ %def :loop loop.asd
\section{The UNIX service}
XXX: this section should be informative only. We're going to suggest
users how to run the system. We may provide a [[make install]] target
that runs things the way we do, but this should be optional. Idea:
instead of hard coding a path to the service, make it {\tt conf-home}
or {\tt conf-service}.
The installation is as follows. You clone the repo to your
local-projects, then run make build. This builds the executable. You
edit conf-home to choose your install directory. Then you say make
install which copies loop, accounts.lisp, the scripts and the service
directory. It is now the syadmin duty to do ln -s ./svc to
/service/loop, which runs it. Let's see if we can pull that off.
We use the {\tt tcpserver} program by Daniel J. Bernstein from the
package \href{https://cr.yp.to/ucspi-tcp.html}{\tt ucspi-tcp}.
<<port number>>=
119
@ %def
<<run>>=
#!/bin/sh
home=`head -1 conf-home`
cd $home
exec 2>1&
echo loop
exec "$home"/tcpserver -HR 0.0.0.0 <<port number>> "$home"/loop
@ %def
<<log-run>>=
#!/bin/sh
echo loop
exec /usr/bin/logger -i -t loop
@
\section{The writing process}
XXX: note to self. Targets [[make build]] and [[make install]] must
be completely non-dependent on noweb. Also, most users will not run
any web at all---they'll run noweb, so releasing {\tt any} use in the
Makefile makes no sense to users. I think we'll need to set up a
virtual machine to practice the use of real-world noweb for other
users. (Lots of work!)
The program {\tt latexmk} is iseful when I'm writing \LaTeX\ in
general, but to get the attention of {\tt latexmk} we need to rewrite
{\tt loop.tex}. So what I do while writing \lp\ is to have a
program---called \href{https://github.com/sjl/peat}{[[peat]]} by Steve
Losh---monitor the NOWEB source code {\tt loop.nw} effectively
invoking [[latexmk]] whenever {\tt loop.nw} is modified. Have a look
at the target [[livedoc]] in the [[Makefile]].
\section{Why isn't {\tt Makefile} in {\tt loop.nw}}
I don't include {\tt Makefile} in the literate source code because I
use [[make]] to drive the literate programming tools. It is true that
we could include the {\tt Makefile}, then run {\tt noweb} once to
extract the {\tt Makefile} from {\tt loop.nw} and then use [[make]]
after that. However, I prefer to build a package that's totally
independent from the literate programming tools because, more often
than not, literate programming tools are usually unavailable in the
typical UNIX system out there. This way, the package we offer the
public can be considered a typical UNIX source code package and
programmers need only worry about literate programming tools if they
decide to modify the source code.
The way I particularly run {\tt noweb} is always by asking for
specific chunks to be extracted. So the command line I'd usually
write is, for example,
%
\begin{verbatim}
build-exe.lisp: loop.nw
(any tangle -Rbuild-exe.lisp < loop.nw > build-exe.tmp || \
(rm build-exe.tmp && exit 1)) && \
mv build-exe.tmp build-exe.lisp
\end{verbatim}
%
In other words, I dump the chunk into a temporary file so that I don't
destroy the previous version of the source code unless the extraction
produces no error. This is too long of a command line and should be
issued by [[make]] itself.
\section*{Index of chunks}
\nowebchunks

2
scripts/build-exe.lisp
View file

@ -3,7 +3,7 @@
(user-homedir-pathname))))
(when (probe-file quicklisp-init)
(load quicklisp-init)))
(ql:quickload :loop :silent t)
(ql:quickload :loop)
(sb-ext:save-lisp-and-die #P"loop"
:toplevel #'loop:main
:executable t