util  Check-in [9259bf507d]

; [ʞ] 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))

;      _Bool (((*(*const (((v)[])))(char, unsigned
;                                  __int128_t)))[5])
;    (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))
(include "../scmlib/lisp-macro.scm")

(define (first fst . lst) fst)

(: string-reduce (list --> string))
(: words->string (list --> string))
(: separate (string list --> string))

;      _Bool (((*(*const (((v)[])))(char, unsigned
;                                  __int128_t)))[5])
;    (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)
        (chicken condition)
        (chicken pretty-print)
        (chicken io))
(include "../scmlib/lisp-macro.scm")

(define (first fst . lst) fst)

(: string-reduce (list --> string))
(: words->string (list --> string))
(: separate (string list --> string))