Compare commits
1 commit
eb2bd3cb36
...
f0a54bf1f9
Author | SHA1 | Date | |
---|---|---|---|
f0a54bf1f9 |
6 changed files with 232 additions and 38 deletions
67
Anyfile
Normal file
67
Anyfile
Normal file
|
@ -0,0 +1,67 @@
|
|||
# -*- mode: makefile -*-
|
||||
include Makefile
|
||||
|
||||
default: all
|
||||
|
||||
all: loop.exe loop.lisp loop.asd scripts/build-exe.lisp \
|
||||
scripts/build-index-from-fs.lisp \
|
||||
scripts/cron-remove-inactive-users.lisp \
|
||||
scripts/migrate-add-creation-date.lisp
|
||||
|
||||
loop.exe: scripts/build-exe.lisp loop.lisp loop.asd
|
||||
sbcl --script scripts/build-exe.lisp
|
||||
(test -f loop.exe && cmp loop loop.exe) || cp loop loop.exe
|
||||
|
||||
loop.lisp: loop.nw
|
||||
./make-release $$(git log --oneline | head -1 | awk '{print $$1}') \
|
||||
loop.nw > loop.tmp && mv loop.tmp loop.nw
|
||||
(any tangle -Rloop.lisp < loop.nw | sh format-def | \
|
||||
dos2unix > loop.tmp || \
|
||||
(rm loop.tmp && exit 1)) && \
|
||||
mv loop.tmp loop.lisp
|
||||
|
||||
loop.asd: loop.nw
|
||||
(any tangle -Rloop.asd < loop.nw | dos2unix > loop-asd.tmp || \
|
||||
(rm loop-asd.tmp && exit 1)) && \
|
||||
mv loop-asd.tmp loop.asd
|
||||
|
||||
scripts/build-exe.lisp: loop.asd loop.lisp loop.nw
|
||||
(any tangle -Rbuild-exe.lisp < loop.nw | dos2unix > build-exe.tmp || \
|
||||
(rm build-exe.tmp && exit 1)) && \
|
||||
mv build-exe.tmp scripts/build-exe.lisp
|
||||
|
||||
scripts/build-index-from-fs.lisp: loop.nw
|
||||
(any tangle -Rbuild-index-from-fs.lisp < loop.nw | dos2unix > \
|
||||
build-index-from-fs.tmp || \
|
||||
(rm build-index-from-fs.tmp && exit 1)) && \
|
||||
mv build-index-from-fs.tmp scripts/build-index-from-fs.lisp
|
||||
|
||||
scripts/cron-remove-inactive-users.lisp: loop.nw
|
||||
(any tangle -Rcron-remove-inactive-users.lisp < loop.nw | dos2unix > \
|
||||
cron-remove-inactive-users.tmp || \
|
||||
(rm cron-remove-inactive-users.tmp && exit 1)) && \
|
||||
mv cron-remove-inactive-users.tmp \
|
||||
scripts/cron-remove-inactive-users.lisp
|
||||
|
||||
scripts/migrate-add-creation-date.lisp: loop.nw
|
||||
(any tangle -Rmigrate-add-creation-date.lisp < loop.nw | dos2unix > \
|
||||
migrate-add-creation-date.tmp || \
|
||||
(rm migrate-add-creation-date.tmp && exit 1)) && \
|
||||
mv migrate-add-creation-date.tmp \
|
||||
scripts/migrate-add-creation-date.lisp
|
||||
|
||||
run: loop.nw
|
||||
(any tangle -Rrun < loop.nw | dos2unix > run.tmp || \
|
||||
(rm run.tmp && exit 1)) && \
|
||||
mv run.tmp run && \
|
||||
chmod 0755 run
|
||||
|
||||
loop.tex: loop.nw
|
||||
any weave -delay -index loop.nw | dos2unix > loop.tex
|
||||
|
||||
loop.pdf: loop.tex
|
||||
latexmk -pdf loop
|
||||
|
||||
clean:
|
||||
rm -f loop loop.exe loop.asd loop.lisp loop.tex loop.pdf \
|
||||
*.fasl *.db .*~ *~ *.out *.aux *.log *.fls *.fdb_latexmk
|
27
format-def
Normal file
27
format-def
Normal file
|
@ -0,0 +1,27 @@
|
|||
#!/bin/sh
|
||||
usage()
|
||||
{
|
||||
printf 'usage: %s [file.lisp]\n' $0
|
||||
exit 1
|
||||
}
|
||||
## The first program finds certain definitions and inserts a new blank
|
||||
## line *before* the definition. Such action makes function
|
||||
## definitions separated by two blank lines in some cases. We then
|
||||
## remove the excess with the second program. Notice we need the -E
|
||||
## option because we're using the | metacharacter that is only
|
||||
## supported by popular sed programs with the -E option. This
|
||||
## violates POSIX sed, but keep in mind that we only run this when
|
||||
## releasing the package. This is a building tool, not part of the
|
||||
## service.
|
||||
sed -E '/^\(defun |\(defmacro /{
|
||||
i\
|
||||
|
||||
}' $* | sed '/^[ \t]*$/{
|
||||
N
|
||||
/^[ \t]*\n$/D
|
||||
}'
|
||||
## We first find a blank line. Then we say N to expand the pattern
|
||||
## space to include the next line. Then we delete the *first* blank
|
||||
## line and not the second---that's what the D command does. This
|
||||
## strategy is explained by Dale Dougherty and Arnold Robbins in ``sed
|
||||
## & awk'' second edition, pages 112--114.
|
4
loop.asd
4
loop.asd
|
@ -1,6 +1,6 @@
|
|||
;;; -*- Mode: LISP; Syntax: COMMON-LISP; -*-
|
||||
(asdf:defsystem :loop
|
||||
:version "0.1"
|
||||
(asdf:defsystem :LOOP
|
||||
:version "9575ac2"
|
||||
:description "An NNTP server for a circle of friends."
|
||||
:depends-on (:lisp-unit :str :uiop :cl-ppcre :local-time :clsql-sqlite3 :clingon
|
||||
:filesystem-utils :ironclad/digest/sha256)
|
||||
|
|
72
loop.lisp
72
loop.lisp
|
@ -30,6 +30,7 @@
|
|||
(defparameter *months-inactive-allowed* 3)
|
||||
(defparameter *months-never-logged-in* 1)
|
||||
(defvar *debug* nil)
|
||||
|
||||
(defun table-of-commands ()
|
||||
`(("GROUP" ,#'cmd-group "sets the current group")
|
||||
("NEXT" ,#'cmd-next "increments the article pointer")
|
||||
|
@ -80,6 +81,7 @@
|
|||
: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)
|
||||
|
@ -187,6 +189,7 @@
|
|||
|
||||
(defmacro mac (&rest body)
|
||||
`(macroexpand-1 ,@body))
|
||||
|
||||
(defun repl (r)
|
||||
(in-package :loop)
|
||||
(loop
|
||||
|
@ -216,13 +219,16 @@
|
|||
"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 (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)
|
||||
|
@ -244,10 +250,12 @@
|
|||
(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)))
|
||||
|
@ -258,6 +266,7 @@
|
|||
(make-request :said (request-said r)
|
||||
:verb (str:upcase verb)
|
||||
:args args))))))
|
||||
|
||||
(defun insert-index (m g i)
|
||||
(handler-case
|
||||
(clsql:insert-records
|
||||
|
@ -283,6 +292,7 @@
|
|||
(art (second article)))
|
||||
(when found
|
||||
(values grp art))))
|
||||
|
||||
(defun connect-index! (filename)
|
||||
(setq *default-database* (clsql:connect (list filename) :database-type :sqlite3)))
|
||||
|
||||
|
@ -295,6 +305,7 @@
|
|||
(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)))
|
||||
|
@ -319,6 +330,7 @@
|
|||
(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)
|
||||
|
@ -332,6 +344,7 @@
|
|||
(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)))
|
||||
|
@ -382,6 +395,7 @@
|
|||
(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))
|
||||
|
||||
|
@ -392,6 +406,7 @@
|
|||
(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)))
|
||||
|
@ -410,6 +425,7 @@
|
|||
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)))))
|
||||
|
@ -422,6 +438,7 @@
|
|||
(defun remake-index-from-fs ()
|
||||
(drop-create-index!)
|
||||
(index-from-fs!))
|
||||
|
||||
(defun parse-article (v)
|
||||
(let ((parts (split-vector (vector 13 10 13 10) v nil :limit 2)))
|
||||
(make-article :headers (map 'string #'code-char (car parts)) :body (cadr parts))))
|
||||
|
@ -449,6 +466,7 @@
|
|||
(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)))))
|
||||
|
||||
|
@ -468,6 +486,7 @@
|
|||
("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))))
|
||||
|
@ -485,11 +504,15 @@
|
|||
|
||||
(defun fetch-body (g i)
|
||||
(article-body (parse-article (fetch-article g i))))
|
||||
|
||||
(defun encode-body (a) a)
|
||||
|
||||
(defun extract-mid (a)
|
||||
(lookup "message-id" (parse-headers (article-headers (parse-article a)))))
|
||||
|
||||
(defun lookup (key table)
|
||||
(cdr (assoc key table :test #'string=)))
|
||||
|
||||
(defun dispatch (r)
|
||||
(let* ((verb (request-verb r)))
|
||||
(if (null verb)
|
||||
|
@ -498,6 +521,7 @@
|
|||
|
||||
(defun dispatch-line (ln)
|
||||
(dispatch (parse-request (make-request :said ln))))
|
||||
|
||||
(defun cmd-authinfo (r)
|
||||
(let* ((args (mapcar #'str:upcase (request-args r))))
|
||||
(cond
|
||||
|
@ -531,8 +555,10 @@
|
|||
(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
|
||||
|
@ -551,17 +577,22 @@
|
|||
|
||||
(defun cmd-head (r)
|
||||
(typical-cmd-head-body-article r #'head-response))
|
||||
|
||||
(defun cmd-body (r)
|
||||
(typical-cmd-head-body-article r #'body-response))
|
||||
|
||||
(defun cmd-article (r)
|
||||
(typical-cmd-head-body-article r #'article-response))
|
||||
|
||||
(defun article-response (r g i)
|
||||
(typical-cmd-response 220 r g i #'(lambda (a) (encode-body a))))
|
||||
|
||||
(defun head-response (r g i)
|
||||
(typical-cmd-response 221 r g i #'(lambda (a) (article-headers (parse-article a)))))
|
||||
|
||||
(defun body-response (r g i)
|
||||
(typical-cmd-response 222 r g i #'(lambda (a) (encode-body (article-body (parse-article a))))))
|
||||
|
||||
(defun typical-cmd-response (code r g i get-data)
|
||||
(handler-case
|
||||
(let ((a (fetch-article g i)))
|
||||
|
@ -578,6 +609,7 @@
|
|||
(make-response
|
||||
:code 400 :request r
|
||||
:data (format nil "article ~a/~a: ~a" g i c)))))
|
||||
|
||||
(defun cmd-next (r)
|
||||
(with-auth
|
||||
(let ((g (client-group *client*))
|
||||
|
@ -598,6 +630,7 @@
|
|||
|
||||
(defun mid-by-name (g name)
|
||||
(extract-mid (fetch-article g name)))
|
||||
|
||||
(defun cmd-xover (r)
|
||||
(with-auth
|
||||
(with-group-set
|
||||
|
@ -638,13 +671,16 @@
|
|||
(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
|
||||
|
@ -715,7 +751,7 @@
|
|||
#+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))
|
||||
|
@ -776,11 +812,13 @@
|
|||
#'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
|
||||
|
@ -788,6 +826,7 @@
|
|||
(make-response :code 200 :multi-line 'yes
|
||||
:request r
|
||||
:data (str:join (crlf-string) lines)))))
|
||||
|
||||
(defun menu (ls)
|
||||
(if (null ls)
|
||||
nil
|
||||
|
@ -798,13 +837,16 @@
|
|||
(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)))))
|
||||
|
@ -829,6 +871,7 @@
|
|||
|
||||
(defun headers-required-from-clients ()
|
||||
'("from" "newsgroups" "subject"))
|
||||
|
||||
(defun suggest-message-id (&optional (n 20))
|
||||
(format nil "<~a@loop>" (random-string n)))
|
||||
|
||||
|
@ -840,6 +883,7 @@
|
|||
(dotimes (c size)
|
||||
(setq mid (cons (char universe (random len state)) mid)))
|
||||
(coerce mid 'string)))
|
||||
|
||||
(defun unparse-article (parsed)
|
||||
(data
|
||||
(let ((ls))
|
||||
|
@ -848,6 +892,7 @@
|
|||
(nreverse ls))
|
||||
(crlf)
|
||||
(article-body parsed)))
|
||||
|
||||
(defun ensure-header (h fn bs)
|
||||
(let* ((headers (parse-headers (article-headers (parse-article bs)))))
|
||||
(if (lookup h headers)
|
||||
|
@ -870,8 +915,10 @@
|
|||
|
||||
(defun ensure-mid (bs)
|
||||
(ensure-header "message-id" #'suggest-message-id bs))
|
||||
|
||||
(defun ensure-date (bs)
|
||||
(ensure-header "date" #'get-date bs))
|
||||
|
||||
(defun newsgroups-header->list (s)
|
||||
(mapcar (lambda (n) (str:trim (string-downcase n))) (str:split "," s)))
|
||||
|
||||
|
@ -910,9 +957,11 @@
|
|||
(data " However, the groups "
|
||||
(str:join ", " (sort ngs-dont-exist #'string<))
|
||||
" just don't exist.")))))))
|
||||
|
||||
(defun update-last-post-date! (username)
|
||||
(let ((u (get-account username)))
|
||||
(setf (account-last-post u) (get-universal-time))))
|
||||
|
||||
(defun rename-no-extension (old new)
|
||||
(rename-file old (make-pathname :name new :type :unspecific)))
|
||||
|
||||
|
@ -936,6 +985,7 @@
|
|||
: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)
|
||||
|
@ -946,12 +996,14 @@
|
|||
(multiple-value-bind (low high len) (group-high-low g)
|
||||
(declare (ignore low len))
|
||||
(1+ high)))
|
||||
|
||||
(defun nntp-read-article (&optional acc)
|
||||
;; Returns List-of Byte.
|
||||
(let* ((ls (ucs-2->ascii (nntp-read-line))))
|
||||
(cond ;; 46 == (byte #\.)
|
||||
((equal (list 46) ls) (flatten (add-crlf-between acc)))
|
||||
(t (nntp-read-article (append acc (list ls)))))))
|
||||
|
||||
(defun nntp-read-line (&optional (s *standard-input*) acc)
|
||||
;; Returns List-of Byte.
|
||||
(let ((x (read-byte s)))
|
||||
|
@ -984,6 +1036,7 @@
|
|||
|
||||
(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)))))
|
||||
|
@ -1012,6 +1065,7 @@
|
|||
(if okay?
|
||||
(values t nil)
|
||||
(values nil "must match ^([a-z0-9]+)"))))
|
||||
|
||||
(defun cmd-create-account (r)
|
||||
(with-auth
|
||||
(with-n-args 1 r
|
||||
|
@ -1026,6 +1080,7 @@
|
|||
(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
|
||||
|
@ -1056,6 +1111,7 @@
|
|||
(push a *accounts*)
|
||||
(write-accounts!)
|
||||
(values (str:upcase username) p)))))
|
||||
|
||||
(defun write-accounts! ()
|
||||
(let ((name
|
||||
(loop
|
||||
|
@ -1078,6 +1134,7 @@
|
|||
(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
|
||||
|
@ -1105,6 +1162,7 @@
|
|||
(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
|
||||
|
@ -1123,6 +1181,7 @@
|
|||
(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))))
|
||||
|
@ -1200,8 +1259,10 @@
|
|||
(let ((u (get-account username)))
|
||||
(if u (let ((s (account-seen u)))
|
||||
(if s (universal-to-human s))))))
|
||||
|
||||
(defun cmd-dd (r)
|
||||
(make-response :code 200 :data (format nil "state: ~a" *client*) :request r))
|
||||
|
||||
(defun cmd-repl (r)
|
||||
(with-auth
|
||||
(repl r)))
|
||||
|
@ -1268,6 +1329,7 @@
|
|||
:description "logging (on stderr)"
|
||||
:long-name "logging"
|
||||
:key :logging)))
|
||||
|
||||
(defun cli/list-accounts ()
|
||||
(println (str:join (crlf-string) (list-users))))
|
||||
|
||||
|
@ -1297,6 +1359,7 @@
|
|||
(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)
|
||||
|
@ -1333,7 +1396,7 @@
|
|||
(clingon:make-command
|
||||
:name "loop"
|
||||
:description "An NNTP server for a circle of friends."
|
||||
:version "0.1"
|
||||
:version "9575ac2"
|
||||
:license "GPL v3"
|
||||
:options (cli/options)
|
||||
:handler #'cli/main-with-handlers))
|
||||
|
@ -1347,6 +1410,7 @@
|
|||
(return))))))
|
||||
|
||||
(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 ()
|
||||
|
@ -1360,7 +1424,9 @@
|
|||
|
||||
(defun send-banner! ()
|
||||
(send-response!
|
||||
(make-response :code 200 :data "Welcome! Say ``help'' for a menu.")))
|
||||
(make-response
|
||||
:code 200
|
||||
:data "Welcome! I am LOOP 9575ac2. Say ``help'' for a menu.")))
|
||||
|
||||
(setq lisp-unit:*print-failures* t)
|
||||
(define-test first-test-of-the-west
|
||||
|
|
86
loop.nw
86
loop.nw
|
@ -323,6 +323,7 @@ Section~\ref{sec:repl}. Commands such as [[CREATE-ACCOUNT]],
|
|||
users need to know how to use {\tt nc} or {\tt telnet} to take
|
||||
advantage of all of \lp's capabilities.
|
||||
|
||||
|
||||
\section{NNTP protocol}
|
||||
|
||||
An Internet protocol is usually defined by a document whose tradition
|
||||
|
@ -432,18 +433,6 @@ line, which is what causes that 400 response.
|
|||
(str:replace-all (string #\linefeed) " " (fmt "~a" c))))))))
|
||||
@ %def repl
|
||||
|
||||
\section{Description of the package}
|
||||
|
||||
<<Description>>=
|
||||
An NNTP server for a circle of friends.
|
||||
@
|
||||
|
||||
<<Version>>=
|
||||
0.1
|
||||
@
|
||||
|
||||
These chunks are used in [[loop.asd]].
|
||||
|
||||
\section{Representation of a client}
|
||||
|
||||
How do we represent a client? A client is typically reading a group
|
||||
|
@ -601,25 +590,6 @@ else should we handle this?
|
|||
(write-sequence ls-of-bytes s)))
|
||||
@ %def my-write
|
||||
|
||||
\section{Parsing of requests}
|
||||
|
||||
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.
|
||||
|
||||
<<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)))
|
||||
;; 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))))))
|
||||
@ %def parse-request
|
||||
|
||||
\section{Main loop}
|
||||
|
||||
Every command consumes a [[request]] and produces a [[response]]. If
|
||||
|
@ -657,9 +627,59 @@ itself---so we can cascade actions based on a user's request.
|
|||
|
||||
(defun send-banner! ()
|
||||
(send-response!
|
||||
(make-response :code 200 :data "Welcome! Say ``help'' for a menu.")))
|
||||
(make-response
|
||||
:code 200
|
||||
:data "<<Welcome message>>")))
|
||||
@ %def main main-loop
|
||||
|
||||
\noindent It's always useful to know which version exactly we're
|
||||
dealing with:
|
||||
%
|
||||
\begin{verbatim}
|
||||
%./loop.exe
|
||||
200 Welcome! I am LOOP 9575ac2. Say ``help'' for a menu.
|
||||
\end{verbatim}
|
||||
%
|
||||
So we put a release tag on \lp's banner.
|
||||
|
||||
<<Welcome message>>=
|
||||
Welcome! I am <<Name>> <<Version>>. Say ``help'' for a menu.
|
||||
@
|
||||
|
||||
\noindent We take the opportunity and describe \lp's package,
|
||||
information which we also use in [[loop.asd]].
|
||||
|
||||
<<Name>>=
|
||||
LOOP
|
||||
@
|
||||
|
||||
<<Description>>=
|
||||
An NNTP server for a circle of friends.
|
||||
@
|
||||
|
||||
<<Version>>=
|
||||
9575ac2
|
||||
@
|
||||
|
||||
\section{Parsing of requests}
|
||||
|
||||
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.
|
||||
|
||||
<<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)))
|
||||
;; 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))))))
|
||||
@ %def parse-request
|
||||
|
||||
\section{Parsing of command-line arguments}
|
||||
|
||||
We're using the clingon library as per Vincent Dardel suggestion in
|
||||
|
@ -2804,7 +2824,7 @@ The \lp\ system definition:
|
|||
|
||||
<<loop.asd>>=
|
||||
;;; -*- Mode: LISP; Syntax: COMMON-LISP; -*-
|
||||
(asdf:defsystem :loop
|
||||
(asdf:defsystem :<<Name>>
|
||||
:version "<<Version>>"
|
||||
:description "<<Description>>"
|
||||
:depends-on (<<List of packages to be loaded>>)
|
||||
|
|
14
make-release
Normal file
14
make-release
Normal file
|
@ -0,0 +1,14 @@
|
|||
#!/bin/sh
|
||||
usage()
|
||||
{
|
||||
printf 'usage: %s tag file\n' $0
|
||||
exit 1
|
||||
}
|
||||
test $# '<' 2 && usage
|
||||
tag="$1"
|
||||
shift
|
||||
sed "/<<Version>>=/ {
|
||||
n;
|
||||
c\\
|
||||
$tag
|
||||
}" $*
|
Loading…
Reference in a new issue