ADDED   fabulist.scm
Index: fabulist.scm
==================================================================
--- fabulist.scm
+++ fabulist.scm
@@ -0,0 +1,623 @@
+; [ʞ] fabulist.scm - write your own adventure server
+;  ~ lexi hale <lexi@hale.su>
+
+(import (chicken tcp)
+		(chicken pretty-print)
+		(chicken io)
+		(chicken string)
+		(chicken bitwise)
+		(chicken random))
+
+(tcp-read-timeout 300)
+
+(define-record db (setter stories) (setter pages))
+(define-record story title genre
+			   desc key start)
+(define-record page link story body choices)
+(define *database* (make-db '() '()))
+(define (serialize-story s)
+  `((title . ,(story-title s))
+	(genre . ,(story-genre s))
+	(desc . ,(story-desc s))
+	(key . ,(story-key s))
+	(start . ,(story-start s))))
+
+(define (fill ct fn)
+  (if (= 0 ct) '()
+	  (cons (fn) (fill (- ct 1) fn))))
+
+(define (generate-key len)
+  (define (random-char)
+	(let* ([r (pseudo-random-integer 36)]
+		   [cv (+ #x30 (if (>= r 10) (+ r 39) r))])
+	  (integer->char cv)))
+  (apply string (fill len random-char)))
+		 
+(define (string-last s x)
+  (substring s (max 0 (- (string-length s) x))
+			 (string-length s)))
+(define (hex-sum str)
+  (define (loop val p)
+	(if (equal? "" p) val
+		(let* ([ch (string-ref p 0)]
+			   [chv (char->integer ch)]
+			   [num (cond [(and (>= chv #x30)
+								(<= chv #x39)) (- chv #x30)]
+						  [(and (>= chv #x41)
+								(<= chv #x46)) (+ 10 (- chv #x41))]
+						  [(and (>= chv #x61)
+								(<= chv #x66)) (+ 10 (- chv #x61))]
+						  [else #f])])
+		  (if (eq? #f num) #f
+			  (loop (+ num (* 16 val))
+					(substring p 1))))))
+  (if (string? str) (loop 0 str)
+	  #f))
+
+(define (url-decode field)
+  (define (loop acc str)
+	(if (equal? str "") acc
+		(let ([hd (string-ref str 0)])
+		  (case hd
+			[(#\+) (loop (string-append acc " ")
+						 (substring str 1))]
+			[(#\%) (let* ([num (if (< (string-length str) 3) #f
+								   (substring str 1 3))]
+						  [sum (hex-sum num)])
+					 (if (or (eq? #f num) (eq? #f sum) (= sum 0))
+						 (loop (string-append acc "%")
+							   (substring str 1))
+						 (loop (string-append acc 
+											  (string (integer->char sum)))
+							   (substring str (min (string-length str) 3)))))]
+
+			[else (loop (string-append acc (string hd))
+						(substring str 1))]
+			))))
+  (loop "" field))
+
+(define-record netstr sz val rest)
+(define-record netreq body method path
+			   query origin accept
+			   ref ua)
+
+(define (netreq-post-params req) (map (cut string-split <> "=")
+								 (string-split (netreq-body req) "&")))
+(define (post-field arr p) (let ((v (assoc p arr)))
+							 (if (eq? #f v) "" (url-decode (cadr v)))))
+(define (alist->netreq al body)
+  (define (method->symbol m) (cond [(equal? m "GET") 'get]
+								   [(equal? m "POST") 'post]
+								   [(equal? m "PUT") 'put]
+								   [else 'unknown]))
+  (define (field key) 
+	(let ((result (assoc key al)))
+	  (if (eq? result #f) #f
+		  (cdr result))))
+
+  (make-netreq body
+			   (method->symbol (field "method"))
+			   (string-split (field "docuri") "/")
+			   (field "query")
+			   (field "remote")
+			   (field "HTTP_ACCEPT")
+			   (field "HTTP_REFERER")
+			   (field "HTTP_USER_AGENT")))
+
+(define-record netresp
+			   status ; error symbol, later resolved to int
+			   headers ; alist of string pairs
+			   body) ; raw text to return
+
+(define (netresp->string resp)
+  (define (netstatus->string sym)
+	(case sym
+	  ['ok "200 OK"]
+	  ['redir "302 Found"]
+	  ['nofile "404 Not Found"]
+	  ['badreq "400 Bad Request"]
+	  ['noauth "401 Unauthorized"]
+	  ['forbidden "403 Forbidden"]
+	  ['badmeth "405 Method Not Allowed"]
+	  ['noaccept "406 Not Acceptable"]
+	  ['error "500 Internal Server Error"]))
+  (define (http-header pair)
+	(string-append (car pair) ": " (cdr pair) "\r\n"))
+  (string-append 
+	"HTTP/1.1 " (netstatus->string (netresp-status resp)) "\r\n"
+	(foldl string-append "" (map http-header (netresp-headers resp)))
+	"\r\n"
+	(netresp-body resp)))
+
+(define mime-types
+  '((html . "text/html")
+	(text . "text/plain")))
+
+(define (search-list pred lst)
+  (cond [(null? lst) #f]
+		[(pred (car lst)) (car lst)]
+		[else (search-list pred (cdr lst))]))
+
+(define (alist-val-search pred val lst)
+  (search-list (lambda (x) (pred (cdr x) val)) lst))
+
+(define (determine-response-kind accept ua)
+  (define (split-type t) (string-split t ";"))
+  (define (mime->symbol m) (car (alist-val-search equal? m mime-types)))
+  (define (symbol->mime m) (cdr (assq m mime-types)))
+  (let* ([fmts (string-split accept ",")]
+		 [fmt-pairs (map split-type fmts)]
+		 [fmt-map (map (lambda(x) (alist-val-search equal? (car x) mime-types)) fmt-pairs)]
+		 [fmt-comp (compress fmt-map fmt-map)])
+	(if (null? fmt-comp) '(html . "text/html")
+		(car fmt-comp))))
+
+(define (emit-para kind text)
+  (case kind
+	('html (string-append "<p>" text "</p>\n"))
+	('text (string-append text "\n\n"))))
+
+(define (emit-inline-link kind l)
+  (case kind
+	('html (string-append "<a href=\"" (cdr l) "\">" (eval-text kind (car l)) "</a>"))
+	('text (string-append " [" (eval-text kind (car l)) "](" (cdr l) ")"))))
+
+(define (emit-list-link kind l)
+  (case kind
+	('html (string-append "<li><a href=\"" (cdr l) "\">" (eval-text kind (car l)) "</a></li>\n"))
+	('text (string-append " * " (eval-text kind (car l)) " → " (cdr l) "\n"))))
+
+(define (emit-form kind f)
+  (let ([method (list-ref f 0)]
+		[dest (list-ref f 1)]
+		[body (foldl string-append ""
+					 (map (cut eval-text kind <>) (list-tail f 2)))])
+	(case kind
+	  ('html (string-append "<form method=\"" method "\" action=\"" dest "\">\n" body "<div><input type=\"submit\" value=\"commit\"></div>\n</form>\n"))
+	  ('text body))))
+
+(define (emit-form-field kind f)
+  (let ([label (list-ref f 0)]
+		[name (list-ref f 1)]
+		[type (list-ref f 2)])
+	(case kind
+	  ('html (cond
+			   ((equal? "textarea" type)
+				( string-append
+				  "<div><label for=\"" name "\">" (eval-text kind label) "</label></div>\n"
+				  "<div><textarea  name=\"" name "\"></textarea></div>\n"))
+			   (else (string-append
+					   "<div><label for=\"" name "\">" (eval-text kind label) ":</label> <input type=\"" type "\" name=\"" name "\"></div>\n"))))
+	  ('text "<FORM>\n"))))
+
+(define (emit-inline-tag tag kind text)
+  (case kind
+	('html (string-append "<"tag">" text "</"tag">"))
+	('text (string-append "*" text "*"))))
+
+(define (eval-text kind body)
+  (define (eval-node n)
+	(if (null? n) ""
+		(let ()
+		  (define (get-inner)
+			(foldl string-append "" (map (cut eval-text kind <>) (cdr n))))
+		  (case (car n)
+			('p (emit-para kind (get-inner)))
+			('text (get-inner))
+			('b (emit-inline-tag "strong" kind (get-inner)))
+			('i (emit-inline-tag "em" kind (get-inner)))
+			('tt (emit-inline-tag "code" kind (get-inner)))
+			('a (emit-inline-link kind (cdr n)))
+			('field (emit-form-field kind (cdr n)))
+			('form (emit-form kind (cdr n)))
+			(else (error "unrecognized text node" (car n)))))))
+  (cond [(string? body) body]
+		[(pair? body) (eval-node body)]
+		[else (error "unparseable text object")]))
+
+(define (redirect dest)
+  (make-netresp 'redir
+				(list '("Server" . "fabulist")
+					  (cons "Location" dest)) ""))
+
+(define (respond req code user-header text links)
+  (let* ([kind-pair (determine-response-kind (netreq-accept req)
+											 (netreq-ua req))]
+		 [kind (car kind-pair)]
+		 [mime (cdr kind-pair)]
+		 [header (string-append (if (equal? user-header "") ""
+									 " :: ") user-header)])
+	(define (open)
+	  (case kind
+		('html (string-append
+				 "<!doctype html>\n<head>\n<title>fabulist" header "</title>\n"
+				 "<link rel=\"stylesheet\" href=\"/style\" type=\"text/css\">"
+				 "</head>\n<body>\n<h1>								<a href=\"/\">fabulist</a>" header "</h1>\n"))
+		('text (string-append "# " header "\n\n"))))
+	(define (close)
+	  (case kind
+		('html (string-append "</body>\n</html>\n"))
+		('text "")))
+	(let* ([opener (open)]
+		   [closer (close)]
+		   [body-text (map (cut eval-text kind <>) text)]
+		   [choices (map (cut emit-list-link kind <>) links)]
+		   [final-text (string-append opener
+									  (foldl string-append "" body-text)
+									  "<ol>\n"
+									  (foldl string-append "" choices)
+									  "</ol>\n"
+									  closer)]
+		   [content-length (number->string(string-length final-text))]
+		   [response (make-netresp code
+								   (list (cons "Server" "fabulist")
+										 (cons "Content-Type" mime)
+										 (cons "Content-Length" content-length))
+								   final-text)])
+	  response)))
+
+
+(define (get-new-story req) 0)
+
+(define (get-stylesheet req)
+  (define style #<<_END_
+	body {
+	background: #370017;
+	color: #FFE1ED;
+	max-width: 35em;
+	padding: 1em;
+	margin: auto;
+	font-family: Alegreya, Junicode, GaramondNo8, "Garamond Premier Pro", "Adobe Garamond", Garamond, serif;
+	font-size: 15pt;
+	}
+	input, textarea {
+	font-family: Alegreya, Junicode, GaramondNo8, "Garamond Premier Pro", "Adobe Garamond", Garamond, serif;
+	font-size: 14pt;
+	border: 1px solid #FF4C96;
+	background: #610028;
+	color: white;
+	padding: 0.3em;
+	flex-grow: 2;
+	text-shadow: 0 0 10px #E84B8C;
+	}
+	code {
+	font-family: Inconsolata, Monaco, monocode;
+	padding: 0.2em 0.3em;
+	background: #740C38;
+	border: 1px solid #260010;
+	}
+	textarea {
+	height: 6em;
+	}
+	input[type=submit] {
+	position: absolute;
+	flex-grow: 0;
+	width: 30%;
+	right: 0;
+	top: 1em;
+	text-shadow: 0 0 10px #E84B8C;
+	}
+	form > div {
+	position: relative;
+	display: flex;
+	width: 100%;
+	align-items: center;
+	}
+	form label {
+	margin-right: 0.5em;
+	margin-bottom: 0.5em;
+	margin-top: 0.5em;
+	font-weight: bold;
+	}
+	a[href] {
+	color: #FF2E84;
+	}
+	h1 {
+		font-weight: 100;
+		margin-bottom: 0.0em;
+	}
+	h1 a[href] {
+	color: #FF7AB1;
+	text-decoration: none;
+	}
+_END_
+	)
+  (make-netresp 'ok (list (cons "Server" "")
+						  (cons "Content-Type" "text/css")
+						  (cons "Content-Length" (number->string
+												   (string-length style))))
+				style))
+
+(define (get-new-chapter req)
+  (let* ([path (netreq-path req)]
+		 [place (follow-path (cdr path))]
+		 [params (netreq-post-params req)])
+	(if (eq? #f place) (error-not-found req)
+		(let* ([story-key (text-path-story-key place)]
+			   [story (text-path-story-rec place)]
+			   [chapter-key (text-path-chapter-key place)])
+		  (new-chapter-page req story-key story chapter-key)))))
+
+(define (get-flag-chapter req) 0)
+(define (post-flag-chapter req) 0)
+
+(define (error-not-found req)
+  (respond req 'nofile "error"
+		   '((p "the path you have entered is not meaningful."))
+		   '(("start over" . "/"))))
+
+(define (display-index-page req)
+  (respond req 'ok ""
+		   '((p "welcome to this " (b "fabulist" ) " instance.")
+			 (p "fabulist is a server for hosting collaborative interactive fiction." )
+			 (p "select one of the links below."))
+		   '(("start a new story" . "/init")
+			 ("play an existing story" . "/find")
+			 ("start a random story" . "/rand"))))
+
+(define (new-chapter-page req key story last-page)
+  (let ([new-url (string-append "/new/" key (if (eq? #f last-page) ""
+												(string-append "/" last-page)))])
+	(respond req 'ok (string-append (story-title story) " :: new chapter")
+		   (list
+			 '(p "write your chapter and hit " (b "commit") " to add it to the story")
+			 `(form "POST" ,new-url
+					,(if (eq? #f last-page) '(text "")
+						(list 'field "choice that leads here" "choice-link" "text"))
+					(field "chapter body" "chapter-body" "textarea")))
+			 (if (eq? last-page #f) '()
+			   (list
+				 (cons "abandon chapter"
+					   (string-append "/p/" key "/" last-page))
+				 (cons "link to existing chapter"
+					   (string-append "/link/" key "/" last-page)))))))
+
+(define-record text-path
+			   story-key story-rec chapter-key)
+
+(define (follow-path path)
+  (let* ([pathlen (length path)])
+	(cond [(or (< pathlen 1)
+			   (> pathlen 2)) #f]
+		  [else (let* ([story-key (car path)]
+					   [story-ent (alist-ref story-key
+											 (db-stories *database*)
+											 equal?)]
+					   [chapter-key (cond [(= pathlen 2) (cadr path)]
+										  [(eq? #f story-ent) #f]
+										  [else (story-start story-ent)])])
+				  (make-text-path story-key story-ent chapter-key))])))
+  
+(define (format-user-text str)
+  (map (cut list 'p <>)
+	   (string-split str "\n")))
+
+(define (post-new-chapter req)
+  (define (save-chapter key ch)
+	(set! (db-pages *database*)
+	  (alist-update key ch (db-pages *database*))))
+  (define (save-to-start story chap)
+	(story-start-set! story chap))
+  (define (add-to-page story-key dest new-key)
+	(let* ([destkey (string-append story-key "." dest)]
+		   [dest-pg (alist-ref destkey (db-pages *database*) equal?)]
+		   [old-choices (page-choices dest-pg)])
+	  (page-choices-set! dest-pg (append old-choices (list new-key)))))
+	  
+  (let* ([path (netreq-path req)]
+		 [place (follow-path (cdr path))]
+		 [params (netreq-post-params req)])
+	(if (eq? #f place) (error-not-found req)
+		(let* ([story-key (text-path-story-key place)]
+			   [story (text-path-story-rec place)]
+			   [chapter-key (text-path-chapter-key place)]
+			   [choice-link (post-field params "choice-link")]
+			   [chapter-body (post-field params "chapter-body")])
+			  (let* ([new-key (generate-key 4)]
+					 [full-key (string-append story-key "." new-key)]
+					 [new-page
+					   (make-page choice-link
+								  story-key
+								  (format-user-text chapter-body)
+								  '())])
+				(if (= (length path) 2)
+					(if (eq? #f (story-start story))
+						(begin (save-chapter full-key new-page)
+							   (save-to-start story new-key)
+							   (redirect (string-append "/p/" story-key "/" new-key)))
+						(error-not-found req))
+					; FIXME: insert error checking to make sure [chapter-key]
+					; really exists; right now this will crash the program!
+					(begin (save-chapter full-key new-page)
+						   (add-to-page story-key chapter-key new-key)
+						   (redirect (string-append "/p/" story-key "/" chapter-key))))
+
+		  )))))
+
+
+(define (get-story-chapter req)
+  (define (render-chapter story-key story chapter)
+	(define (lookup-chapter ch) (alist-ref (string-append story-key "." ch)
+										   (db-pages *database*) equal?))
+	(define (format-choice ch)
+	  (let ([dest (lookup-chapter ch)])
+		(cons (page-link dest)
+			  (string-append "/p/" story-key "/" ch))))
+
+	(let ([chap (lookup-chapter chapter)])
+	  (if (eq? #f chap) (error-not-found req)
+		  (respond req 'ok (story-title story)
+					(page-body chap)
+					(append
+					  (map format-choice (page-choices chap))
+					  (list (cons '(i "[branch]")
+								  (string-append
+									"/new/" story-key
+									"/" chapter))))))))
+
+  (let* ([path (netreq-path req)]
+		 [place (follow-path (cdr path))])
+	(if (eq? #f place) (error-not-found req)
+		(let* ([story-key (text-path-story-key place)]
+			   [story-ent (text-path-story-rec place)]
+			   [chapter-key (text-path-chapter-key place)])
+
+		  (cond [(eq? #f story-ent) (error-not-found req)]
+				[(and (= (length path) 2) ; no chkey passed
+					  (eq? chapter-key #f)) ; and start is empty
+				 (new-chapter-page req story-key story-ent #f)]
+				[else (render-chapter story-key story-ent chapter-key)])))))
+
+(define (get-init-story req)
+  (respond req 'ok "new story"
+		   '((p "what kind of story do you want to create?")
+			 (form "POST" "/init"
+				   (field "name" "story-name" "text")
+				   (field "genre" "story-genre" "text")
+				   (field "synopsis" "story-desc" "textarea")))
+		   '(("never mind" . "/"))))
+
+(define (post-init-story req)
+  (define (try msg expr) (if (eq? expr #f) #f msg))
+  (let* ([params (netreq-post-params req)]
+		 [name (post-field params "story-name")]
+		 [genre (post-field params "story-genre")]
+		 [desc (post-field params "story-desc")]
+		 [story-key (generate-key 4)]
+		 [author-key (generate-key 8)]
+		 [failure (or (try "name" (< (string-length name) 4))
+					  (try "genre" (< (string-length genre) 4))
+					  (try "synopsis" (< (string-length desc) 16)))]
+		 [body (cond [(string? failure)
+					  (list
+						(list 'p (string-append
+								   "the " failure " you entered isn't long enough!")))]
+					 [else (list 
+							 (list 'p "your story has been created!")
+							 (list 'p (list 'text
+											"your author key is " (list 'tt author-key) "; make sure to copy it down somewhere if you want to be able to exercise editorial control.")))])]
+		 [link (cond [(eq? failure #f)
+					  (list (cons (list 'text "starting writing " (list 'b name))
+								  (string-append "/p/" story-key)))]
+					 [else (list '("try again" . "/init")
+								 '("give up" . "/"))])])
+
+	(unless (string? failure) (begin
+								(let* ([new-story (make-story name genre desc author-key #f)]
+									   [db-entry (cons story-key new-story)])
+								  (set! (db-stories *database*)
+									(cons db-entry (db-stories *database*))))))
+	(respond req 'ok "new story" body link)))
+
+(define route-table (list
+					  (cons '(get  . ("style"))  get-stylesheet)
+
+					  (cons '(get  . ("p"))   get-story-chapter)
+
+					  (cons '(get  . ("init"))  get-init-story)
+					  (cons '(post . ("init"))  post-init-story)
+
+					  (cons '(get  . ("new"))  get-new-chapter)
+					  (cons '(post . ("new"))  post-new-chapter)
+
+					  (cons '(get  . ("flag")) get-flag-chapter)
+					  (cons '(post . ("flag")) post-flag-chapter)))
+
+(define (find-route method path)
+  (define (search table path)
+	(cond [(null? table) #f]
+		  [(equal? (cons method path) (caar table)) (cdar table)]
+		  [else (search (cdr table) path)]))
+  (if (null? path) #f
+	  (let ((rs (search route-table path)))
+		(if (not (eq? rs #f)) rs
+			(find-route method (butlast path))))))
+
+(define (route req)
+  (let* ([path   (netreq-path req)]
+		 [method (netreq-method req)]
+		 [pagefn (if (null? path) display-index-page
+					 (or (find-route method path)
+						 error-not-found))])
+	(pagefn req)))
+
+(define (read-ahead skip ct . args)
+  (define (loop buf skip ct)
+	(if (eq? ct 0) buf
+		(let ([nextchar (apply read-char args)])
+		  (if (eq? #!eof nextchar) buf
+			  (loop (if (> skip 0) buf
+						(string-append buf (string nextchar)))
+					(max 0 (- skip 1))
+					(- ct 1))))))
+  (loop "" skip (+ skip ct)))
+
+(define (characterize input)
+  (define (loop len ptr)
+	(if (equal? "" ptr) (if (> 0 len) 'invalid 'incomplete)
+		(let* ([char (string-ref ptr 0)]
+			   [val (char->integer char)])
+		  (cond [(and (>= val #x30) ;is ascii digit?
+					  (<= val #x39))
+				 (loop (+ (- val #x30) (* len 10))
+					   (substring ptr 1))]
+				[(eqv? char #\:) (if (< (string-length ptr) len) 'incomplete
+									 (make-netstr len
+												  (substring ptr 1 len)
+												  (substring ptr len)))]
+				[else 'invalid]))))
+  (loop 0 input))
+
+(define (parse-header str)
+  (define (pairup a b . rst)
+	(let ([p (cons a b)])
+	  (if (null? rst) (cons p '())
+		  (cons p (apply pairup rst)))))
+  (let ([lst (string-split str "\x00" #t)])
+	(apply pairup lst)))
+
+(define (connect in out)
+  (define (shutdown)
+	(close-input-port in)
+	(close-output-port out))
+  (define (accumulate buf)
+	(let ([state (characterize buf)])
+	  (cond
+		[(eq? state 'invalid) #f]
+		[(eq? state 'incomplete) (accumulate
+								   (string-append buf (string (read-char in))))]
+		[else state])))
+  (let ([req (accumulate "")])
+	(if (not (netstr? req)) (write-string "bad scgi request" #f out)
+
+		(let* ([header (parse-header (netstr-val req))]
+			   [bodysz (string->number
+						 (cdr (assoc "CONTENT_LENGTH" header)))]
+			   [body (string-append
+					   (netstr-rest req)
+					   (read-ahead 2 bodysz in))])
+		  ; pass the structured data on to the router function, which
+		  ; will generate the appropriate page text for the request
+		  ; and pass it back as a netresp struct
+		  (write-string 
+			(netresp->string
+			  (route (alist->netreq header body))) #f out)
+		  ))
+	(shutdown)))
+
+
+(define (serve port)
+  (define (await-connections s)
+	(let-values ([{in out} (tcp-accept s)])
+	  (connect in out)
+	  #;(condition-case (connect in out)
+	  (v () (v)))
+	(await-connections s)))
+(let ([server (tcp-listen port 100 "127.0.0.1")])
+  (await-connections server)
+  (tcp-close server)))
+
+(serve 4056)
+#;(cond-expand
+  (chicken-script )
+  (else))

Index: sexpc/sexpc.scm
==================================================================
--- sexpc/sexpc.scm
+++ sexpc/sexpc.scm
@@ -20,14 +20,14 @@
 ;    (as i'm sure you immediately guessed)
 ;    
 ;  → no dependencies besides the lisp-macro.scm file
 ;    bundled with it, and the chicken stdlib.
 
-(import (chicken process-context))
-(import (chicken condition))
-(import (chicken pretty-print))
-(import (chicken io))
+(import (chicken process-context)
+        (chicken condition)
+        (chicken pretty-print)
+        (chicken io))
 (include "../scmlib/lisp-macro.scm")
 
 (define (first fst . lst) fst)
 
 (: string-reduce (list --> string))