Differences From
Artifact [e734573397]:
4 4 (import (chicken tcp)
5 5 (chicken pretty-print)
6 6 (chicken io)
7 7 (chicken string)
8 8 (chicken bitwise)
9 9 (chicken random))
10 10
11 +(begin-for-syntax (import (chicken io)))
12 +(include "scmlib/lisp-macro.scm")
13 +(define-macro (static-import-string . body)
14 + (call-with-input-file (car body)
15 + (cut read-string #f <>)))
16 +(define *stylesheet* (static-import-string "fabulist.css"))
17 +
11 18 (tcp-read-timeout 300)
12 19
13 20 (define-record db (setter stories) (setter pages))
14 21 (define-record story title genre
15 22 desc key start)
16 23 (define-record page link story body choices)
17 24 (define *database* (make-db '() '()))
................................................................................
79 86 (define-record netstr sz val rest)
80 87 (define-record netreq body method path
81 88 query origin accept
82 89 ref ua)
83 90
84 91 (define (netreq-post-params req) (map (cut string-split <> "=")
85 92 (string-split (netreq-body req) "&")))
86 -(define (post-field arr p) (let ((v (assoc p arr)))
87 - (if (eq? #f v) "" (url-decode (cadr v)))))
93 +(define (post-field arr p)
94 + (let ((v (assoc p arr))) (if (or (null? v)
95 + (eq? #f v)
96 + (null? (cdr v))) ""
97 + (url-decode (cadr v)))))
88 98 (define (alist->netreq al body)
89 99 (define (method->symbol m) (cond [(equal? m "GET") 'get]
90 100 [(equal? m "POST") 'post]
91 101 [(equal? m "PUT") 'put]
92 102 [else 'unknown]))
93 103 (define (field key)
94 104 (let ((result (assoc key al)))
................................................................................
222 232
223 233 (define (respond req code user-header text links)
224 234 (let* ([kind-pair (determine-response-kind (netreq-accept req)
225 235 (netreq-ua req))]
226 236 [kind (car kind-pair)]
227 237 [mime (cdr kind-pair)]
228 238 [header (string-append (if (equal? user-header "") ""
229 - " :: ") user-header)])
239 + " :: ") user-header)])
230 240 (define (open)
231 241 (case kind
232 242 ('html (string-append
233 243 "<!doctype html>\n<head>\n<title>fabulist" header "</title>\n"
234 244 "<link rel=\"stylesheet\" href=\"/style\" type=\"text/css\">"
235 245 "</head>\n<body>\n<h1> <a href=\"/\">fabulist</a>" header "</h1>\n"))
236 246 ('text (string-append "# " header "\n\n"))))
................................................................................
256 266 final-text)])
257 267 response)))
258 268
259 269
260 270 (define (get-new-story req) 0)
261 271
262 272 (define (get-stylesheet req)
263 - (define style #<<_END_
264 - body {
265 - background: #370017;
266 - color: #FFE1ED;
267 - max-width: 35em;
268 - padding: 1em;
269 - margin: auto;
270 - font-family: Alegreya, Junicode, GaramondNo8, "Garamond Premier Pro", "Adobe Garamond", Garamond, serif;
271 - font-size: 15pt;
272 - }
273 - input, textarea {
274 - font-family: Alegreya, Junicode, GaramondNo8, "Garamond Premier Pro", "Adobe Garamond", Garamond, serif;
275 - font-size: 14pt;
276 - border: 1px solid #FF4C96;
277 - background: #610028;
278 - color: white;
279 - padding: 0.3em;
280 - flex-grow: 2;
281 - text-shadow: 0 0 10px #E84B8C;
282 - }
283 - code {
284 - font-family: Inconsolata, Monaco, monocode;
285 - padding: 0.2em 0.3em;
286 - background: #740C38;
287 - border: 1px solid #260010;
288 - }
289 - textarea {
290 - height: 6em;
291 - }
292 - input[type=submit] {
293 - position: absolute;
294 - flex-grow: 0;
295 - width: 30%;
296 - right: 0;
297 - top: 1em;
298 - text-shadow: 0 0 10px #E84B8C;
299 - }
300 - form > div {
301 - position: relative;
302 - display: flex;
303 - width: 100%;
304 - align-items: center;
305 - }
306 - form label {
307 - margin-right: 0.5em;
308 - margin-bottom: 0.5em;
309 - margin-top: 0.5em;
310 - font-weight: bold;
311 - }
312 - a[href] {
313 - color: #FF2E84;
314 - }
315 - h1 {
316 - font-weight: 100;
317 - margin-bottom: 0.0em;
318 - }
319 - h1 a[href] {
320 - color: #FF7AB1;
321 - text-decoration: none;
322 - }
323 -_END_
324 - )
325 - (make-netresp 'ok (list (cons "Server" "")
273 + (make-netresp 'ok (list (cons "Server" "fabulist")
326 274 (cons "Content-Type" "text/css")
327 275 (cons "Content-Length" (number->string
328 - (string-length style))))
329 - style))
276 + (string-length *stylesheet*))))
277 + *stylesheet*))
330 278
331 279 (define (get-new-chapter req)
332 280 (let* ([path (netreq-path req)]
333 281 [place (follow-path (cdr path))]
334 282 [params (netreq-post-params req)])
335 - (if (eq? #f place) (error-not-found req)
283 + (if (or (eq? #f place)
284 + (eq? #f (text-path-story-rec place))) (error-not-found req)
336 285 (let* ([story-key (text-path-story-key place)]
337 286 [story (text-path-story-rec place)]
338 287 [chapter-key (text-path-chapter-key place)])
339 288 (new-chapter-page req story-key story chapter-key)))))
340 289
341 290 (define (get-flag-chapter req) 0)
342 291 (define (post-flag-chapter req) 0)
343 292
344 293 (define (error-not-found req)
345 294 (respond req 'nofile "error"
346 295 '((p "the path you have entered is not meaningful."))
347 296 '(("start over" . "/"))))
297 +
298 +(define (error-bad-request req back)
299 + (respond req 'badreq "error"
300 + '((p "the data you have supplied is not valid."))
301 + `(("return to story" . ,back)
302 + ("start over" . "/"))))
348 303
349 304 (define (display-index-page req)
350 305 (respond req 'ok ""
351 306 '((p "welcome to this " (b "fabulist" ) " instance.")
352 307 (p "fabulist is a server for hosting collaborative interactive fiction." )
353 308 (p "select one of the links below."))
354 309 '(("start a new story" . "/init")
355 310 ("play an existing story" . "/find")
356 - ("start a random story" . "/rand"))))
311 + ("start a random story" . "/rand")
312 + ("set your author details" . "/auth")
313 + )))
357 314
358 315 (define (new-chapter-page req key story last-page)
359 316 (let ([new-url (string-append "/new/" key (if (eq? #f last-page) ""
360 317 (string-append "/" last-page)))])
361 318 (respond req 'ok (string-append (story-title story) " :: new chapter")
362 - (list
363 - '(p "write your chapter and hit " (b "commit") " to add it to the story")
364 - `(form "POST" ,new-url
365 - ,(if (eq? #f last-page) '(text "")
366 - (list 'field "choice that leads here" "choice-link" "text"))
367 - (field "chapter body" "chapter-body" "textarea")))
319 + (list
320 + '(p "write your chapter and hit " (b "commit") " to add it to the story")
321 + `(form "POST" ,new-url
322 + ,(if (eq? #f last-page) '(text "")
323 + (list 'field "choice that leads here" "choice-link" "text"))
324 + (field "chapter body" "chapter-body" "textarea")))
368 325 (if (eq? last-page #f) '()
369 - (list
370 - (cons "abandon chapter"
371 - (string-append "/p/" key "/" last-page))
372 - (cons "link to existing chapter"
373 - (string-append "/link/" key "/" last-page)))))))
326 + (list
327 + (cons "abandon chapter"
328 + (string-append "/p/" key "/" last-page))
329 + (cons "link to existing chapter"
330 + (string-append "/link/" key "/" last-page)))))))
374 331
375 332 (define-record text-path
376 333 story-key story-rec chapter-key)
377 334
378 335 (define (follow-path path)
379 336 (let* ([pathlen (length path)])
380 337 (cond [(or (< pathlen 1)
................................................................................
383 340 [story-ent (alist-ref story-key
384 341 (db-stories *database*)
385 342 equal?)]
386 343 [chapter-key (cond [(= pathlen 2) (cadr path)]
387 344 [(eq? #f story-ent) #f]
388 345 [else (story-start story-ent)])])
389 346 (make-text-path story-key story-ent chapter-key))])))
390 -
347 +
391 348 (define (format-user-text str)
392 349 (map (cut list 'p <>)
393 350 (string-split str "\n")))
394 351
395 352 (define (post-new-chapter req)
396 353 (define (save-chapter key ch)
397 354 (set! (db-pages *database*)
................................................................................
399 356 (define (save-to-start story chap)
400 357 (story-start-set! story chap))
401 358 (define (add-to-page story-key dest new-key)
402 359 (let* ([destkey (string-append story-key "." dest)]
403 360 [dest-pg (alist-ref destkey (db-pages *database*) equal?)]
404 361 [old-choices (page-choices dest-pg)])
405 362 (page-choices-set! dest-pg (append old-choices (list new-key)))))
406 -
363 +
407 364 (let* ([path (netreq-path req)]
408 365 [place (follow-path (cdr path))]
409 - [params (netreq-post-params req)])
366 + [params (netreq-post-params req)]
367 + [raw-path (foldl string-append "" (intersperse (cdr path) "/"))])
410 368 (if (eq? #f place) (error-not-found req)
411 369 (let* ([story-key (text-path-story-key place)]
412 370 [story (text-path-story-rec place)]
413 371 [chapter-key (text-path-chapter-key place)]
372 + [chapter-full-key (if (eq? #f chapter-key) #f
373 + (string-append story-key "." chapter-key))]
414 374 [choice-link (post-field params "choice-link")]
415 375 [chapter-body (post-field params "chapter-body")])
416 - (let* ([new-key (generate-key 4)]
417 - [full-key (string-append story-key "." new-key)]
418 - [new-page
419 - (make-page choice-link
420 - story-key
421 - (format-user-text chapter-body)
422 - '())])
423 - (if (= (length path) 2)
424 - (if (eq? #f (story-start story))
425 - (begin (save-chapter full-key new-page)
426 - (save-to-start story new-key)
427 - (redirect (string-append "/p/" story-key "/" new-key)))
428 - (error-not-found req))
429 - ; FIXME: insert error checking to make sure [chapter-key]
430 - ; really exists; right now this will crash the program!
431 - (begin (save-chapter full-key new-page)
432 - (add-to-page story-key chapter-key new-key)
433 - (redirect (string-append "/p/" story-key "/" chapter-key))))
434 -
435 - )))))
376 + (cond [(or (equal? chapter-body "")
377 + (and (equal? choice-link "")
378 + (not (eq? chapter-key #f))))
379 + (error-bad-request req (string-append "/p/" raw-path))]
380 + [else
381 + (let* ([new-key (generate-key 4)]
382 + [full-key (string-append story-key "." new-key)]
383 + [new-page (make-page choice-link
384 + story-key
385 + (format-user-text chapter-body)
386 + '())])
387 + (if (= (length path) 2); new story or new branch?
388 + (if (eq? #f (story-start story))
389 + (begin (save-chapter full-key new-page)
390 + (save-to-start story new-key)
391 + (redirect (string-append "/p/" story-key "/" new-key)))
392 + (error-not-found req))
393 + ; FIXME: insert error checking to make sure [chapter-key]
394 + ; really exists; right now this will crash the program!
395 + (if (eq? #f (alist-ref chapter-full-key (db-pages *database*) equal?))
396 + (error-not-found req)
397 + (begin (save-chapter full-key new-page)
398 + (add-to-page story-key chapter-key new-key)
399 + (redirect (string-append "/p/" story-key "/" chapter-key))))
400 +
401 + ))])))))
436 402
437 403
438 404 (define (get-story-chapter req)
439 405 (define (render-chapter story-key story chapter)
440 406 (define (lookup-chapter ch) (alist-ref (string-append story-key "." ch)
441 407 (db-pages *database*) equal?))
442 408 (define (format-choice ch)
................................................................................
443 409 (let ([dest (lookup-chapter ch)])
444 410 (cons (page-link dest)
445 411 (string-append "/p/" story-key "/" ch))))
446 412
447 413 (let ([chap (lookup-chapter chapter)])
448 414 (if (eq? #f chap) (error-not-found req)
449 415 (respond req 'ok (story-title story)
450 - (page-body chap)
451 - (append
452 - (map format-choice (page-choices chap))
453 - (list (cons '(i "[branch]")
454 - (string-append
455 - "/new/" story-key
456 - "/" chapter))))))))
416 + (page-body chap)
417 + (append
418 + (map format-choice (page-choices chap))
419 + (list (cons '(i "[branch]")
420 + (string-append
421 + "/new/" story-key
422 + "/" chapter))))))))
457 423
458 424 (let* ([path (netreq-path req)]
459 425 [place (follow-path (cdr path))])
460 426 (if (eq? #f place) (error-not-found req)
461 427 (let* ([story-key (text-path-story-key place)]
462 428 [story-ent (text-path-story-rec place)]
463 429 [chapter-key (text-path-chapter-key place)])
................................................................................
615 581 (await-connections s)))
616 582 (let ([server (tcp-listen port 100 "127.0.0.1")])
617 583 (await-connections server)
618 584 (tcp-close server)))
619 585
620 586 (serve 4056)
621 587 #;(cond-expand
622 - (chicken-script )
623 - (else))
588 +(chicken-script )
589 +(else))