@@ -7,8 +7,15 @@ (chicken string) (chicken bitwise) (chicken random)) +(begin-for-syntax (import (chicken io))) +(include "scmlib/lisp-macro.scm") +(define-macro (static-import-string . body) + (call-with-input-file (car body) + (cut read-string #f <>))) +(define *stylesheet* (static-import-string "fabulist.css")) + (tcp-read-timeout 300) (define-record db (setter stories) (setter pages)) (define-record story title genre @@ -82,10 +89,13 @@ 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 (post-field arr p) + (let ((v (assoc p arr))) (if (or (null? v) + (eq? #f v) + (null? (cdr 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] @@ -225,9 +235,9 @@ (netreq-ua req))] [kind (car kind-pair)] [mime (cdr kind-pair)] [header (string-append (if (equal? user-header "") "" - " :: ") user-header)]) + " :: ") user-header)]) (define (open) (case kind ('html (string-append "\n\nfabulist" header "\n" @@ -259,81 +269,20 @@ (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" "") + (make-netresp 'ok (list (cons "Server" "fabulist") (cons "Content-Type" "text/css") (cons "Content-Length" (number->string - (string-length style)))) - style)) + (string-length *stylesheet*)))) + *stylesheet*)) (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) + (if (or (eq? #f place) + (eq? #f (text-path-story-rec 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))))) @@ -344,8 +293,14 @@ (define (error-not-found req) (respond req 'nofile "error" '((p "the path you have entered is not meaningful.")) '(("start over" . "/")))) + +(define (error-bad-request req back) + (respond req 'badreq "error" + '((p "the data you have supplied is not valid.")) + `(("return to story" . ,back) + ("start over" . "/")))) (define (display-index-page req) (respond req 'ok "" '((p "welcome to this " (b "fabulist" ) " instance.") @@ -352,26 +307,28 @@ (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")))) + ("start a random story" . "/rand") + ("set your author details" . "/auth") + ))) (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"))) + (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))))))) + (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) @@ -386,9 +343,9 @@ [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"))) @@ -402,38 +359,47 @@ (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)]) + [params (netreq-post-params req)] + [raw-path (foldl string-append "" (intersperse (cdr path) "/"))]) (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)] + [chapter-full-key (if (eq? #f chapter-key) #f + (string-append story-key "." chapter-key))] [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)))) - - ))))) + (cond [(or (equal? chapter-body "") + (and (equal? choice-link "") + (not (eq? chapter-key #f)))) + (error-bad-request req (string-append "/p/" raw-path))] + [else + (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); new story or new branch? + (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! + (if (eq? #f (alist-ref chapter-full-key (db-pages *database*) equal?)) + (error-not-found req) + (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) @@ -446,15 +412,15 @@ (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)))))))) + (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) @@ -618,6 +584,6 @@ (tcp-close server))) (serve 4056) #;(cond-expand - (chicken-script ) - (else)) +(chicken-script ) +(else))