keyboardan <
keyboardan@tilde.club> writes:
Patricia Ferreira <pferreira@example.com> writes:
But these social networks have a great weakness, which is the
non-physical locality. That's the major problem with the Internet when
it comes to social networks. The discussions we have here, we could
have on the USENET, say.
I think NNTP should either be the USENET or it should house the local
communities. I started one. I wrote my own NNTP server and shared the
code with the other members. I let each member invite whoever they want
and each member can crate their own groups. I think this works well
because:
1. An online community should be physically local. We get that by
requiring that every account be an invitation by another member.
2. Members should feel like they own the place. That's why they
can create new accounts and create new groups. When accounts are
created, everyone knows about it because a message is posted to
local.control.news. Similarly for new groups. (We are programmers,
so members can also get access to the UNIX system and patch the
software. Though to get access to the UNIX system, they must ask the
sysadmin for account.)
Patricia, have you put the code online? Where? :-)
I have not. It's too early. But here it goes. If you understand
Common Lisp and know how to operate SBCL, you should be fine. The
software is made of two packages, one called rename and another called
loop.
You'll need a database of friends called accounts.lisp. To build an executable, run build-exe.lisp. We have documentation of the entire
source code, but it's not in English.
(*) build-exe.lisp
(load "~/.sbclrc")
(ql:quickload :loop :silent t)
(sb-ext:save-lisp-and-die #P"loop.exe"
:toplevel #'loop:main
:executable t)
(*) accounts.lisp
(#S(LOOP::ACCOUNT
:USERNAME "ROOT"
:SEEN NIL
:FRIENDS NIL
:PASS 2654602074512631267))
(*) loop.asd
;;; -*- Mode: LISP; Syntax: COMMON-LISP; -*-
(asdf:defsystem :loop
:version "0.0.1"
:description "An NNTP server for a circle of friends."
:depends-on (:lisp-unit :str :uiop :cl-fad :cl-ppcre :rename)
:components ((:file "loop")))
(*) loop.lisp
;;; -*- mode: LISP; syntax: COMMON-LISP; package: LOOP; -*-
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload '(:lisp-unit :str :uiop :cl-fad :cl-ppcre :rename
:local-time :iterate) :silent t))
(defpackage #:loop
(:use :common-lisp)
(:import-from :lisp-unit define-test)
(:import-from :rename rename-noreplace)
(:import-from :iterate iter)
(:export :main))
(in-package #:loop)
(defun debug? () nil)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun fmt (cstr &rest args)
(apply #'format nil (list* cstr args))))
(defun stderr (&rest args)
(when (debug?)
(apply #'format (cons *error-output* args))))
(defun enumerate (list &optional (first-index 0))
(loop for elt in list and idx from first-index
collect (cons idx elt)))
(defun ucs-2->ascii (bs)
;; I'm a Windows user. Lol. What can I do? I gotta
;; deal with things like UCS-2 because I work very close
;; to the Windows API, you see? Such is life on Windows.
#-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")))
(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 main ()
(send-banner!)
(set-up-tables!)
(read-accounts!)
(main-loop))
(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)))
(defun split-vector-helper (delim v len acc limit so-far start)
(if (zerop len)
acc
(let ((pos (search delim v :start2 start :end2 len)))
(cond ((or (not pos) (and limit (= so-far limit)))
(nreverse (cons (subseq v start len) acc)))
(t (split-vector-helper
delim
v
len
(cons (subseq v start (or pos len)) acc)
limit
(1+ so-far)
(+ pos (length delim))))))))
(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))))
(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)
(let* ((size (sb-posix:stat-size (sb-posix:stat path)))
(a (make-array size)))
(with-open-file (in path :element-type '(unsigned-byte 8))
(read-sequence a in)
a)))
(defun fetch-body (g i)
(article-body (parse-article (fetch-article g i))))
(defun encode-body (a) a)
(defun extract-mid (a)
(lookup "message-id" (parse-headers (article-headers (parse-article a))))) (defun lookup (key table)
(cdr (assoc key table :test #'string=)))
(defun dispatch (r)
(let* ((verb (request-verb r)))
(if (null verb)
(empty-response)
(funcall (command-fn (get-command verb)) r))))
(defun dispatch-line (ln)
(dispatch (parse-request (make-request :said ln))))
(defun cmd-authinfo (r)
(let* ((args (mapcar #'str:upcase (request-args r))))
(cond
((not (= (length args) 2))
(bad-input r "No, no: I take exactly two arguments."))
(t
(multiple-value-bind (cmd arg) (apply #'values args)
(cond
((string= cmd "USER")
(setf (client-username *client*) arg)
(make-response :code 381 :request r
:data (format nil "Hey, ~a, please tell us your password." arg)))
((string= cmd "PASS")
(if (authinfo-check (client-username *client*) arg)
(progn
(log-user-in!)
(make-response
:code 281 :request r
:data (fmt "Welcome, ~a." (client-username *client*))))
(make-response :code 400 :request r :data "Sorry. Wrong password.")))
(t (make-response :code 400 :request r :data "Syntax error. Say ``authinfo USER /your-name/'' then ``authinfo PASS /your-pass/''."))))))))
(defun authinfo-check (username passwd)
(pass? username passwd))
(defun auth? ()
(eq 'yes (client-auth? *client*)))
(defun log-user-in! ()
(setf (client-auth? *client*) 'yes)
(let ((u (get-account (client-username *client*))))
(setf (account-seen u) (get-universal-time)))
(write-accounts!))
(defun cmd-mode (r) ;; Whatever.
(make-response :code 200 :request r :data "Sure thing."))
(defun typical-cmd-head-body-article (r fn-name)
(with-auth
(with-group-set
(let ((args (request-args r)))
(cond ((null args)
(funcall fn-name r (client-group *client*) (client-article *client*)))
((= 1 (length args))
(let* ((n-or-mid (car args)))
(cond ((string-integer? n-or-mid)
(funcall fn-name r (client-group *client*) n-or-mid))
(t (bad-input r "Sorry: we don't support that yet.")))))
(t (bad-input r "No, no: it takes at most two arguments.")))))))
(defun cmd-head (r)
(typical-cmd-head-body-article r #'head-response))
(defun cmd-body (r)
(typical-cmd-head-body-article r #'body-response))
(defun cmd-article (r)
(typical-cmd-head-body-article r #'article-response))
(defun article-response (r g i)
(typical-cmd-response 220 r g i #'(lambda (a) (encode-body a))))
(defun head-response (r g i)
(typical-cmd-response 221 r g i #'(lambda (a) (article-headers (parse-article a)))))
(defun body-response (r g i)
(typical-cmd-response 222 r g i #'(lambda (a) (encode-body (article-body (parse-article a))))))
(defun typical-cmd-response (code r g i get-data)
(let ((a (handler-case (fetch-article g i)
(sb-posix:syscall-error (c)
(make-response :code 400 :request r
:data (format nil "article ~a/~a: ~a" g i c)))
(sb-ext:file-does-not-exist (c)
(declare (ignore c))
(make-response :code 400 :request r
:data (format nil "article ~a/~a does not exist" g i))))))
(cond ((typep a 'response) a)
(t (prepend-response-with
(format nil "~a ~a" i (extract-mid a))
(make-response :multi-line 'yes :code code
:request r :data (funcall get-data a)))))))
(defun cmd-next (r)
(with-auth
(let ((g (client-group *client*))
(n-cur (client-article *client*)))
(cond
((not g) (bad-input :code 412 r "must say GROUP first"))
(t (multiple-value-bind (low high len) (group-high-low g)
(declare (ignore low len))
(cond ((= n-cur high) (bad-input r "you are at the last article already"))
(t (article-next! r g)))))))))
(defun article-next! (r g)
(setf (client-article *client*) (1+ (client-article *client*)))
(let ((cur (client-article *client*)))
(make-response :code 223
:request r
:data (format nil "~a ~a" cur (mid-by-name g cur)))))
(defun mid-by-name (g name)
(extract-mid (fetch-article g name)))
(defun cmd-xover (r)
(with-auth
(with-group-set
(let ((args (request-args r)))
(cond ((null args)
(xover r (client-article *client*) (client-article *client*)))
((= 1 (length args))
(multiple-value-bind (s v)
(cl-ppcre:scan-to-strings "([0-9]+)([-]?)([0-9]*)" (car args))
(cond
((not s) (make-response :code 502 :request r :data "bad syntax"))
(t (let ((fr (parse-integer (aref v 0)))
(hifen (aref v 1))
(to (ignore-errors (parse-integer (aref v 2)))))
(when (not (string= hifen "-"))
(setq to fr))
(xover r fr to))))))
(t (make-response :code 502 :request r :data "bad syntax")))))))
(defun xover (r from to)
(assert (client-group *client*))
(let* ((g (client-group *client*))
(ls (get-articles g from to)))
(cond ((= 0 (length ls))
(make-response :code 420 :request r :data "no articles in the range"))
(t
(prepend-response-with
"Okay, your overview follows..."
(make-response
:code 224 :request r :multi-line 'yes
:data (str:join
(crlf-string)
(loop for i in ls
collect (xover-format-line
i
(remove-if-not
#'(lambda (h)
(member (car h) (xover-headers)
:test #'string=))
(fetch-headers g i)))))))))))
(defun xover-format-line (i hs)
(str:concat (format nil "~a~a" i #\tab)
(str:join #\tab
(mapcar #'(lambda (h) (get-header h hs))
(xover-headers)))))
(defun xover-headers ()
'("subject" "from" "date" "message-id" "references" "line-count" "byte-count"))
(defun cmd-group (r)
(with-auth
(with-n-args 1 r
(let ((g (car (request-args r))))
(with-group g r
(set-group! g)
(multiple-value-bind (low high len) (group-high-low g)
(let ((ln (format nil "~a ~a ~a ~a" len low high g)))
(setf (client-article *client*) low)
(make-response :code 211 :request r :data ln))))))))
(defun group? (g)
(in-groups
(cl-fad:directory-exists-p g)))
(defun xgroup? (g)
(cl-fad:directory-exists-p g))
(defun set-group! (g)
(setf (client-group *client*) g))
(defstruct group name high low)
(defun cmd-list (r)
(prepend-response-with
"Get in the loop! Lots to choose from."
(make-response :code 215 :multi-line 'yes
:data (str:join (crlf-string) (build-groups-lines (build-groups-structs)))
:request r)))
(defun build-groups-lines (ls)
(reverse
(mapcar
#'(lambda (g)
(format nil "~a ~a ~a y" (group-name g) (group-high g) (group-low g)))
ls)))
(defun build-groups-structs ()
(let ((ret-ls nil))
(dolist (g (list-groups) ret-ls)
(multiple-value-bind (low high len) (group-high-low g)
(declare (ignore len))
(setf ret-ls (cons (make-group :name g :high high :low low) ret-ls))))))
(defun get-articles (g &optional from to)
(in-groups ;; We might want to optimize this some day. Most likely,
;; though, we'll not be using directories. That's a
;; problem to be studied.
(let ((as (articles->integers (cl-fad:list-directory g))))
(sort (remove-if-not ;; Should we write a between? procedure?
#'(lambda (x)
(<= (or from x) x (or to x)))
as)
#'<))))
(defun group-high-low (g)
(let* ((articles (get-articles g))
(sorted-ints (sort articles #'<)))
(values (or (car sorted-ints) 0)
(or (car (last sorted-ints)) 0)
(length sorted-ints))))
(defun articles->integers (ls)
(remove-if #'null
(mapcar #'(lambda (g)
(ignore-errors
(parse-integer (basename (uiop:unix-namestring g)))))
ls)))
(defun list-groups ()
(let ((groups (in-groups (cl-fad:list-directory "."))))
(sort (mapcar #'(lambda (g) (basename (uiop:unix-namestring g))) groups)
#'string-lessp)))
(defun last-char (s) (char s (1- (length s))))
(defun basename (path)
(let ((s (str:collapse-whitespaces path)))
(if (char= #\/ (last-char s))
(car (last (pathname-directory s)))
(file-namestring s))))
(defun cmd-help (r)
(let ((lines (menu *commands-assoc*)))
(prepend-response-with
"What's on the menu today?"
(make-response :code 200 :multi-line 'yes
:request r
:data (data (str:join (crlf-string) lines))))))
(defun menu (ls)
(if (null ls)
nil
(cons (display-fn (car ls)) (menu (cdr ls)))))
(defun display-fn (cmd-pair)
(let ((cmd (cdr cmd-pair)))
(format nil "~A ~A"
(command-verb cmd)
(command-description cmd))))
(defun cmd-quit (r)
(make-response :code 205 :data "Good-bye." :request r))
(defun conforms? (bs)
(catch 'article-syntax-error ;; parse-headers might throw
(let ((headers (parse-headers (article-headers (parse-article bs)))))
(let ((result (dolist (h (headers-required-from-clients))
(when (not (lookup h headers))
(return (format nil "missing the /~a/ header." h)))))
(content-type (get-header "content-type" headers)))
(cond
((stringp result) (values nil result))
((not (text/plain? content-type))
(values nil (format nil "content-type must be plain/text, but it's ~a" content-type)))
(t (values t nil)))))))
(defun text/plain? (header-s)
;; I say T when S begins with "text/plain" or when S is "".
(let* ((s (str:collapse-whitespaces header-s))
(needle "text/plain")
(len (min (length needle) (length s))))
(or (zerop len)
(and (<= (length needle) (length s))
(string= needle s :end1 len :end2 len)))))
(defun headers-required-from-clients ()
'("from" "newsgroups" "subject"))
(defun suggest-message-id (&optional (n 20))
(format nil "<~a@loop>" (random-string n)))
(defun random-string (size)
(let* ((universe "abcdefghijklmnopqrstuvwxyz")
(len (length universe))
(state (make-random-state t))
mid)
(dotimes (c size)
(setq mid (cons (char universe (random len state)) mid)))
(coerce mid 'string)))
(defun unparse-article (parsed)
(data
(let ((ls))
(dolist (h (parse-headers (article-headers parsed)))
(setq ls (cons (data (str:capitalize (car h)) ": " (cdr h) (crlf)) ls)))
(nreverse ls))
(crlf)
(article-body parsed)))
(defun ensure-header (h fn bs)
(let* ((headers (parse-headers (article-headers (parse-article bs)))))
(if (lookup h headers)
bs
(unparse-article
(make-article
:headers
(str:join (crlf-string)
(mapcar (lambda (h)
(format nil "~a: ~a" (car h) (cdr h)))
(cons (cons h (funcall fn)) headers)))
:body (article-body (parse-article bs)))))))
(defun get-date ()
(multiple-value-bind (s m h day mon year dow dst-p tz)
(get-decoded-time)
(declare (ignore dow dst-p))
(format nil "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d GMT~a"
year mon day h m s (- tz))))
(defun ensure-mid (bs)
(ensure-header "message-id" #'suggest-message-id bs))
(defun ensure-date (bs)
(ensure-header "date" #'get-date bs))
(defun newsgroups-header->list (s)
(mapcar (lambda (n) (str:trim (string-downcase n))) (str:split "," s)))
(defun cmd-post (r)
(send-response!
(make-response :code 340
:data (format nil "Okay, go ahead. Suggested message-id ~a."
(suggest-message-id))))
(let* ((bs (nntp-read-article)))
(multiple-value-bind (okay? error) (conforms? bs)
(if (not okay?)
(make-response :code 400 :request r
:data (format nil "Sorry. Your article doesn't conform: ~a." error))
(multiple-value-bind (code reply) (post bs)
(make-response :code code :request r :data reply))))))
(defun post (bs)
(let ((ngs (newsgroups-header->list
(get-header "newsgroups" (parse-headers
(article-headers
(parse-article bs))))))
ngs-dont-exist)
(dolist (ng ngs)
(if (and (group-name-conforms? ng)
(group? ng))
(save-article-insist ng (get-next-article-id ng) (ensure-date (ensure-mid bs)))
(push ng ngs-dont-exist)))
(if (zerop (- (length ngs) (length ngs-dont-exist)))
(values 400 "Sorry. There was not a single valid newsgroup specified.")
(values 240 (data "Thank you! Your article has been saved."
(when ngs-dont-exist
(data " However, the groups "
(str:join ", " (sort ngs-dont-exist #'string<))
" just don't exist.")))))))
(defun save-article-try (name-try bs)
;; Returns T if the article was successfully written.
(let ((name (format nil "~a" name-try))
(tmp (format nil "~a.tmp" name-try)))
(and (not (probe-file name))
(with-open-file
(s tmp
:direction :output
:if-exists :error
:if-does-not-exist :create
:element-type '(unsigned-byte 8))
(write-sequence bs s))
(rename-noreplace tmp name)
(values name tmp))))
(defun save-article-insist (g name-try a)
;; Write the article using NAME-TRY. If that doesn't work, insist
;; with (1+ NAME-TRY). But I mean---insist.
(or (in-dir (format nil "groups/~a/" g)
(save-article-try name-try a))
(save-article-insist g (1+ name-try) a)))
(defun get-next-article-name (g)
(format nil "~a" (get-next-article-id g)))
(defun get-next-article-id (g)
(multiple-value-bind (low high len) (group-high-low g)
(declare (ignore low len))
(1+ high)))
(defun nntp-read-article (&optional acc)
;; Returns List-of Byte.
(let* ((ls (ucs-2->ascii (nntp-read-line))))
(cond ;; 46 == (byte #\.)
((equal (list 46) ls) (flatten (add-crlf-between acc)))
(t (nntp-read-article (append acc (list ls)))))))
(defun nntp-read-line (&optional (s *standard-input*) acc)
;; Returns List-of Byte.
(let ((x (read-byte s)))
(cond ((or (null x) (= x 10))
(let ((bs (and acc (nreverse (if (= (car acc) 13) (cdr acc) acc)))))
(stderr "<<< ~a~%" (bytes->string (ucs-2->ascii bs)))
bs))
(t (nntp-read-line s (cons x acc))))))
(defun list->bytes (ls)
(mapcar #'data->bytes ls))
(defun vector->bytes (v)
(mapcar #'data->bytes (coerce v 'list)))
(defun data->bytes (d)
(cond ((null d) nil)
((integerp d) (list d))
((stringp d) (string->bytes d))
((consp d) (list->bytes d))
((vectorp d) (vector->bytes d))
(t (error (format nil "type ~a is not supported" (type-of d))))))
(defun add-crlf-between (ls-of-ls)
;; Add \r\n to each ``line''. Returns List-of Byte.
(mapcar (lambda (ls) (append ls (list 13 10))) ls-of-ls))
(defun string->bytes (s)
(map 'list #'char-code s))
(defun bytes->string (ls)
(map 'string #'code-char ls))
(defun cmd-create-group (r)
(with-n-args 1 r
(let ((g (string-downcase (car (request-args r)))))
(multiple-value-bind (okay? reason)
(group-name-conforms? g)
(if (not okay?)
(make-response :code 580 :request r
:data (format nil "group name does not conform: ~a" reason))
(progn
(multiple-value-bind (path created?)
(in-groups (ensure-directories-exist (concatenate 'string g "/")))
(declare (ignore created?))
(if (not path)
(make-response :code 581 :request r
:data (format nil "could not create group ~a"
(if (group? g)
"because it already exists"
"but we don't know why---sorry!")))
(progn
(notify-group-created g)
(make-response :code 280 :request r
:data (format nil "group ~a created" g)))))))))))
(defun group-name-conforms? (g)
(let ((okay? (cl-ppcre:scan-to-strings "^([a-z0-9]+)(\\.)([a-z0-9]+)" g)))
(if okay?
(values t nil)
(values nil "must match ^([a-z0-9]+)(\\.)([a-z0-9]+)"))))
(defun cmd-create-account (r)
(with-auth
(with-n-args 1 r
(let* ((args (mapcar #'str:upcase (request-args r)))
(username (car args)))
(multiple-value-bind (username pass-or-error) (new-account! username)
(if (not username)
(make-response :code 400 :request r
:data (fmt "~a. Choose a new name." pass-or-error))
(progn
(notify-user-created username)
(make-response :code 200 :request r
:data (fmt "Okay, account ~a created with password ``~a''."
username pass-or-error)))))))))
(defparameter *accounts* nil)
(defstruct account username seen friends pass)
(defun read-accounts! ()
(let ((*package* (find-package '#:loop)))
(with-open-file
(s "accounts.lisp"
:direction :input)
(setq *accounts* (read s))))
*accounts*)
(defun new-account! (username)
(let* ((u (str:upcase username))
(p (random-string 6))
(a (make-account :username u
:pass (sxhash (str:upcase p)))))
(if (get-account u)
(values nil (fmt "account ~a already exists" u))
(let ((c (get-account (client-username *client*))))
(push u (account-friends c))
(push a *accounts*)
(write-accounts!)
(values (str:upcase username) p)))))
(defun write-accounts! ()
(let ((name
(loop
(let* ((tmp (random-string 10))
(name (format nil "~a.tmp" tmp)))
(when
(ignore-errors
(with-open-file
(s name
:direction :output
:if-exists :error
:if-does-not-exist :create)
(write *accounts* :stream s)))
(return name))))))
(if (ignore-errors (rename-file name "accounts.lisp"))
(values t *accounts*)
(values nil (format nil "could not rename ~a to accounts.lisp" name)))))
(defun get-account (username)
(loop for u in *accounts*
do (when (string= (str:upcase username) (account-username u))
(return u))))
(defun cmd-login (r)
(let* ((args (mapcar #'str:upcase (request-args r))))
(cond
((not (= (length args) 2))
(bad-input r "Usage: login your-username your-password"))
(t
(multiple-value-bind (name pass) (apply #'values args)
(cond
((pass? name pass)
(log-user-in-as! name)
(make-response :code 200 :request r
:data (fmt "Welcome, ~a." name)))
(t (make-response :code 400 :request r
:data (fmt "Wrong password.")))))))))
(defun log-user-in-as! (name)
(setf (client-username *client*) name)
(log-user-in!))
(defun cmd-passwd (r)
(with-auth
(let* ((args (mapcar #'str:upcase (request-args r))))
(cond
((not (= (length args) 2))
(bad-input r "Usage: passwd current-password new-password"))
(t
(multiple-value-bind (cur new) (apply #'values args)
(cond
((pass? (client-username *client*) cur)
(multiple-value-bind (okay? problem) (change-passwd! (client-username *client*) new)
(if okay?
(make-response :code 200 :request r
:data "You got it. Password changed.")
(make-response :code 500 :request r
:data (fmt "Sorry: ~a" problem)))))
(t (make-response :code 400 :request r
:data (fmt "Sorry. Wrong password."))))))))))
(defun pass? (username pass)
(let ((u (get-account username)))
(and u
(eq (sxhash pass) (account-pass u)))))
(defun change-passwd! (username newpass)
(let ((u (get-account username)))
(when (not u)
(error "I could not find account ~a." username))
(setf (account-pass u) (sxhash newpass))
(write-accounts!)))
(defun notify-group-created (g)
(post-notification
:subject (fmt "New group ~a by ~a" g (client-username *client*))
:body (fmt "Blame ~a for the group ~a just created." (client-username *client*) g)))
(defun notify-user-created (u)
(post-notification
:subject (fmt "New account ~a by ~a" u (client-username *client*))
:body (fmt "Blame ~a for inviting ~a." (client-username *client*) u)))
(defun post-notification (&key subject body)
(in-groups (ensure-directories-exist "local.control.news/"))
(when (group? "local.control.news")
(let ((a (make-news :subject subject :body body)))
(post (concatenate 'vector (article-headers a) (crlf) (article-body a) (crlf))))))
(defun make-news (&key subject body)
(make-article
:headers (data
(add-crlf-between
(mapcar
(lambda (p) (data (format nil "~a: ~a" (car p) (cdr p))))
`(("from" . "Loop")
("subject" . ,subject)
("newsgroups" . "local.control.news")))))
:body (data body)))
(defun 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!)
(sort
(loop for u in *accounts*
collect (fmt "~v@a, last seen on ~a, invited ~a"
(size-of-longest-username)
(account-username u)
(last-time-seen (account-username u))
(or (account-friends u) "nobody")))
#'string<=))
(defun universal-to-human (ustamp)
(local-time:format-timestring
nil
(local-time:universal-to-timestamp ustamp)
:format local-time:+asctime-format+))
(defun last-time-seen (username)
(let ((u (get-account username)))
(and u (let ((s (account-seen u)))
(and 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))
(define-test requests
(let ((nil-request-1 (make-request))
(nil-request-2 (make-request :said " ")))
(assert-true (request=? nil-request-1 (parse-request nil-request-1)))
(assert-true (request=? nil-request-2 (parse-request nil-request-2)))
(assert-true (request=? nil-request-1 nil-request-2))))
(define-test commands
(let ((ht (make-hash-table))
(c1 (make-command :fn #'cons :verb 'c1 :description "cons cmd"))
(c2 (make-command :fn #'list :verb 'c2 :description "list cmd")))))
(define-test dispatching
(assert-true (equalp (empty-response) (dispatch (empty-request)))))
(*) rename.asd
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RENAME; -*-
(asdf:defsystem :rename
:version "0.1"
:description "An interface to Linux's renameat2 and Win32's MoveFileExA."
:depends-on (:cffi)
:components ((:file "rename")))
(*) rename.lisp
;;; -*- mode: LISP; syntax: COMMON-LISP; package: RENAME; -*-
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload '(:cffi) :silent t))
(defpackage :rename
(:use :common-lisp :cffi :sb-alien)
(:export :rename-noreplace))
(in-package :rename)
(define-foreign-library libc
(:unix (:or "libc.so.6" "libc.so"))
(:win32 "kernel32.dll"))
(use-foreign-library libc)
(defcfun "rename" :int (oldpath :string) (newpath :string))
(defcfun "renameat2" :int
(olddirfd :int) (oldpath :string)
(newdirfd :int) (newpath :string) (flags :int))
(defcfun "MoveFileExA" :int
(lpexistingfilename :string)
(lpnewfilename :string)
(dwflags :int))
(defconstant at-fdcwd -100 "See rename(2) in the Linux Programmer's Manual.") (defconstant flag-noreplace 1 "See rename(2) in the Linux Programmer's Manual.")
#+linux
(defun rename-noreplace (old new)
;; Returns T if okay; NIL otherwise.
(= 0 (renameat2 at-fdcwd old at-fdcwd new flag-noreplace)))
#+win32
(defun rename-noreplace (old new)
;; Returns T if okay; NIL otherwise.
;; (format t "cwd: ~a~%" (uiop:getcwd))
;; (format t "def: ~a~%" *default-pathname-defaults*)
;; (format t "~a --> ~a~%" old new)
(= 1 (MoveFileExA old new 0)))
#-(or win32 linux)
(defun rename-noreplace (old new)
;; Unfortunately, we cannot guarantee atomicity. Returns pathnames
;; if okay. NIL otherwise.
(rename-file old new))
--- Synchronet 3.19a-Linux NewsLink 1.113