util  Check-in [9259bf507d]

Overview
Comment:add fabulist collaborative interaction fiction server (keeping it here until it gets its own repo)
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA3-256: 9259bf507d2a7f9c10105e20a6c118244c88c20317af19a24f854d585ce3f925
User & Date: lexi on 2019-07-28 12:40:46
Other Links: manifest | tags
Context
2019-07-29
06:11
updates check-in: e82124aeb7 user: lexi tags: trunk
2019-07-28
12:40
add fabulist collaborative interaction fiction server (keeping it here until it gets its own repo) check-in: 9259bf507d user: lexi tags: trunk
2019-07-25
23:59
fix make instructions check-in: 352d72f9c6 user: lexi tags: trunk
Changes

Added fabulist.scm version [e734573397].































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
; [ʞ] 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))

Modified sexpc/sexpc.scm from [46b6c9a575] to [7c5e1b9792].

18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
;      _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))







|
|
|
|







18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
;      _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))