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