Index: fabulist.scm
==================================================================
--- fabulist.scm
+++ fabulist.scm
@@ -6,10 +6,17 @@
(chicken io)
(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
desc key start)
@@ -81,12 +88,15 @@
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 (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]
[else 'unknown]))
@@ -224,11 +234,11 @@
(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)])
+ " :: ") user-header)])
(define (open)
(case kind
('html (string-append
"\n\nfabulist" header "\n"
""
@@ -258,83 +268,22 @@
(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)))))
@@ -343,36 +292,44 @@
(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.")
(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)
(define (follow-path path)
@@ -385,11 +342,11 @@
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)
@@ -401,40 +358,49 @@
(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)])
+ [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)
(define (lookup-chapter ch) (alist-ref (string-append story-key "." ch)
@@ -445,17 +411,17 @@
(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))))))))
+ (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)]
@@ -617,7 +583,7 @@
(await-connections server)
(tcp-close server)))
(serve 4056)
#;(cond-expand
- (chicken-script )
- (else))
+(chicken-script )
+(else))
Index: nkvd.c
==================================================================
--- nkvd.c
+++ nkvd.c
@@ -108,10 +108,14 @@
* too special to simply name their config file
* "~/.(argv[0])".
*
* TODO: exempt xdg dirs beginning with ~/. from proscription
* in nkvd_interdict_all=1 mode
+ *
+ * TODO: instead of function passthrough, alter environment
+ * to delete LD_PRELOAD and re-exec whitelisted apps
+ * without nkvd loading at all
*/
#include
#include
#include