diff --git a/loop.lisp b/loop.lisp index 4f5c1b7..68679d8 100644 --- a/loop.lisp +++ b/loop.lisp @@ -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 ") - :license "GPL v3" - :options (cli/options) - :handler #'cli/main)) - -(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 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 " 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 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 ") + :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!)) diff --git a/loop.nw b/loop.nw index f74be5c..656c3ee 100644 --- a/loop.nw +++ b/loop.nw @@ -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.) -<>= +<>= (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") @@ -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]]. <>= (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 @@ -480,7 +488,7 @@ mark such responses with [[multi-line]]. Here's how to send a [[response]] to a client. -<>= +<>= (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? -<>= +<>= (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. -<>= +<>= (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. <>= -(defun cli/command () - (clingon:make-command - :name "loop" - :description "<>" - :version "<>" - :authors '("Circling Skies ") - :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. <>= -(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 "<>" + :version "<>" + :authors '("Circling Skies ") + :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 -<>= +<>= (defstruct article headers body) +@ +<>= (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|. -<>= +<>= (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. -<>= +<>= (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. -<>= +<>= (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 -<>= +<>= (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]]. -<>= +<>= (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/''. @ -<>= +<>= (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) +<>= (defstruct account username seen last-post friends pass pass-locked pass-locked-why creation) +(defparameter *accounts* nil) +@ %def *accounts* +<>= (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. <>= (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. <>= :lisp-unit :str :uiop :cl-ppcre :local-time :clsql-sqlite3 :clingon :filesystem-utils :ironclad/digest/sha256 @ +<>= +<> +<> +<> +<> +<> +<> +(defvar *debug* nil) +@ + <>= ;;; -*- mode: LISP; syntax: COMMON-LISP; package: LOOP; -*- (eval-when (:compile-toplevel :load-toplevel :execute) @@ -2684,7 +2667,7 @@ about. '(<>) :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) -<> +<> +<
> +<> +<> +<> +<> +<> <> <> <> -<> -<> -<> -<> -<> -<> -<
> -<> -<
> <> -<> +<> <> -<> +<> <> <> <> <> <> -<> +<> <> <> <> @@ -2725,11 +2705,16 @@ about. <> <> <> -<> <> <> + +<> + +<> + +<
> + <> -<> @ %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}. - -<>= -119 -@ %def - -<>= -#!/bin/sh -home=`head -1 conf-home` -cd $home -exec 2>1& -echo loop -exec "$home"/tcpserver -HR 0.0.0.0 <> "$home"/loop -@ %def - -<>= -#!/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 diff --git a/scripts/build-exe.lisp b/scripts/build-exe.lisp index 2d23f95..96405f2 100644 --- a/scripts/build-exe.lisp +++ b/scripts/build-exe.lisp @@ -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