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: |
9259bf507d2a7f9c10105e20a6c11824 |
| 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 +; [ʞ] fabulist.scm - write your own adventure server 2 +; ~ lexi hale <lexi@hale.su> 3 + 4 +(import (chicken tcp) 5 + (chicken pretty-print) 6 + (chicken io) 7 + (chicken string) 8 + (chicken bitwise) 9 + (chicken random)) 10 + 11 +(tcp-read-timeout 300) 12 + 13 +(define-record db (setter stories) (setter pages)) 14 +(define-record story title genre 15 + desc key start) 16 +(define-record page link story body choices) 17 +(define *database* (make-db '() '())) 18 +(define (serialize-story s) 19 + `((title . ,(story-title s)) 20 + (genre . ,(story-genre s)) 21 + (desc . ,(story-desc s)) 22 + (key . ,(story-key s)) 23 + (start . ,(story-start s)))) 24 + 25 +(define (fill ct fn) 26 + (if (= 0 ct) '() 27 + (cons (fn) (fill (- ct 1) fn)))) 28 + 29 +(define (generate-key len) 30 + (define (random-char) 31 + (let* ([r (pseudo-random-integer 36)] 32 + [cv (+ #x30 (if (>= r 10) (+ r 39) r))]) 33 + (integer->char cv))) 34 + (apply string (fill len random-char))) 35 + 36 +(define (string-last s x) 37 + (substring s (max 0 (- (string-length s) x)) 38 + (string-length s))) 39 +(define (hex-sum str) 40 + (define (loop val p) 41 + (if (equal? "" p) val 42 + (let* ([ch (string-ref p 0)] 43 + [chv (char->integer ch)] 44 + [num (cond [(and (>= chv #x30) 45 + (<= chv #x39)) (- chv #x30)] 46 + [(and (>= chv #x41) 47 + (<= chv #x46)) (+ 10 (- chv #x41))] 48 + [(and (>= chv #x61) 49 + (<= chv #x66)) (+ 10 (- chv #x61))] 50 + [else #f])]) 51 + (if (eq? #f num) #f 52 + (loop (+ num (* 16 val)) 53 + (substring p 1)))))) 54 + (if (string? str) (loop 0 str) 55 + #f)) 56 + 57 +(define (url-decode field) 58 + (define (loop acc str) 59 + (if (equal? str "") acc 60 + (let ([hd (string-ref str 0)]) 61 + (case hd 62 + [(#\+) (loop (string-append acc " ") 63 + (substring str 1))] 64 + [(#\%) (let* ([num (if (< (string-length str) 3) #f 65 + (substring str 1 3))] 66 + [sum (hex-sum num)]) 67 + (if (or (eq? #f num) (eq? #f sum) (= sum 0)) 68 + (loop (string-append acc "%") 69 + (substring str 1)) 70 + (loop (string-append acc 71 + (string (integer->char sum))) 72 + (substring str (min (string-length str) 3)))))] 73 + 74 + [else (loop (string-append acc (string hd)) 75 + (substring str 1))] 76 + )))) 77 + (loop "" field)) 78 + 79 +(define-record netstr sz val rest) 80 +(define-record netreq body method path 81 + query origin accept 82 + ref ua) 83 + 84 +(define (netreq-post-params req) (map (cut string-split <> "=") 85 + (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))))) 88 +(define (alist->netreq al body) 89 + (define (method->symbol m) (cond [(equal? m "GET") 'get] 90 + [(equal? m "POST") 'post] 91 + [(equal? m "PUT") 'put] 92 + [else 'unknown])) 93 + (define (field key) 94 + (let ((result (assoc key al))) 95 + (if (eq? result #f) #f 96 + (cdr result)))) 97 + 98 + (make-netreq body 99 + (method->symbol (field "method")) 100 + (string-split (field "docuri") "/") 101 + (field "query") 102 + (field "remote") 103 + (field "HTTP_ACCEPT") 104 + (field "HTTP_REFERER") 105 + (field "HTTP_USER_AGENT"))) 106 + 107 +(define-record netresp 108 + status ; error symbol, later resolved to int 109 + headers ; alist of string pairs 110 + body) ; raw text to return 111 + 112 +(define (netresp->string resp) 113 + (define (netstatus->string sym) 114 + (case sym 115 + ['ok "200 OK"] 116 + ['redir "302 Found"] 117 + ['nofile "404 Not Found"] 118 + ['badreq "400 Bad Request"] 119 + ['noauth "401 Unauthorized"] 120 + ['forbidden "403 Forbidden"] 121 + ['badmeth "405 Method Not Allowed"] 122 + ['noaccept "406 Not Acceptable"] 123 + ['error "500 Internal Server Error"])) 124 + (define (http-header pair) 125 + (string-append (car pair) ": " (cdr pair) "\r\n")) 126 + (string-append 127 + "HTTP/1.1 " (netstatus->string (netresp-status resp)) "\r\n" 128 + (foldl string-append "" (map http-header (netresp-headers resp))) 129 + "\r\n" 130 + (netresp-body resp))) 131 + 132 +(define mime-types 133 + '((html . "text/html") 134 + (text . "text/plain"))) 135 + 136 +(define (search-list pred lst) 137 + (cond [(null? lst) #f] 138 + [(pred (car lst)) (car lst)] 139 + [else (search-list pred (cdr lst))])) 140 + 141 +(define (alist-val-search pred val lst) 142 + (search-list (lambda (x) (pred (cdr x) val)) lst)) 143 + 144 +(define (determine-response-kind accept ua) 145 + (define (split-type t) (string-split t ";")) 146 + (define (mime->symbol m) (car (alist-val-search equal? m mime-types))) 147 + (define (symbol->mime m) (cdr (assq m mime-types))) 148 + (let* ([fmts (string-split accept ",")] 149 + [fmt-pairs (map split-type fmts)] 150 + [fmt-map (map (lambda(x) (alist-val-search equal? (car x) mime-types)) fmt-pairs)] 151 + [fmt-comp (compress fmt-map fmt-map)]) 152 + (if (null? fmt-comp) '(html . "text/html") 153 + (car fmt-comp)))) 154 + 155 +(define (emit-para kind text) 156 + (case kind 157 + ('html (string-append "<p>" text "</p>\n")) 158 + ('text (string-append text "\n\n")))) 159 + 160 +(define (emit-inline-link kind l) 161 + (case kind 162 + ('html (string-append "<a href=\"" (cdr l) "\">" (eval-text kind (car l)) "</a>")) 163 + ('text (string-append " [" (eval-text kind (car l)) "](" (cdr l) ")")))) 164 + 165 +(define (emit-list-link kind l) 166 + (case kind 167 + ('html (string-append "<li><a href=\"" (cdr l) "\">" (eval-text kind (car l)) "</a></li>\n")) 168 + ('text (string-append " * " (eval-text kind (car l)) " → " (cdr l) "\n")))) 169 + 170 +(define (emit-form kind f) 171 + (let ([method (list-ref f 0)] 172 + [dest (list-ref f 1)] 173 + [body (foldl string-append "" 174 + (map (cut eval-text kind <>) (list-tail f 2)))]) 175 + (case kind 176 + ('html (string-append "<form method=\"" method "\" action=\"" dest "\">\n" body "<div><input type=\"submit\" value=\"commit\"></div>\n</form>\n")) 177 + ('text body)))) 178 + 179 +(define (emit-form-field kind f) 180 + (let ([label (list-ref f 0)] 181 + [name (list-ref f 1)] 182 + [type (list-ref f 2)]) 183 + (case kind 184 + ('html (cond 185 + ((equal? "textarea" type) 186 + ( string-append 187 + "<div><label for=\"" name "\">" (eval-text kind label) "</label></div>\n" 188 + "<div><textarea name=\"" name "\"></textarea></div>\n")) 189 + (else (string-append 190 + "<div><label for=\"" name "\">" (eval-text kind label) ":</label> <input type=\"" type "\" name=\"" name "\"></div>\n")))) 191 + ('text "<FORM>\n")))) 192 + 193 +(define (emit-inline-tag tag kind text) 194 + (case kind 195 + ('html (string-append "<"tag">" text "</"tag">")) 196 + ('text (string-append "*" text "*")))) 197 + 198 +(define (eval-text kind body) 199 + (define (eval-node n) 200 + (if (null? n) "" 201 + (let () 202 + (define (get-inner) 203 + (foldl string-append "" (map (cut eval-text kind <>) (cdr n)))) 204 + (case (car n) 205 + ('p (emit-para kind (get-inner))) 206 + ('text (get-inner)) 207 + ('b (emit-inline-tag "strong" kind (get-inner))) 208 + ('i (emit-inline-tag "em" kind (get-inner))) 209 + ('tt (emit-inline-tag "code" kind (get-inner))) 210 + ('a (emit-inline-link kind (cdr n))) 211 + ('field (emit-form-field kind (cdr n))) 212 + ('form (emit-form kind (cdr n))) 213 + (else (error "unrecognized text node" (car n))))))) 214 + (cond [(string? body) body] 215 + [(pair? body) (eval-node body)] 216 + [else (error "unparseable text object")])) 217 + 218 +(define (redirect dest) 219 + (make-netresp 'redir 220 + (list '("Server" . "fabulist") 221 + (cons "Location" dest)) "")) 222 + 223 +(define (respond req code user-header text links) 224 + (let* ([kind-pair (determine-response-kind (netreq-accept req) 225 + (netreq-ua req))] 226 + [kind (car kind-pair)] 227 + [mime (cdr kind-pair)] 228 + [header (string-append (if (equal? user-header "") "" 229 + " :: ") user-header)]) 230 + (define (open) 231 + (case kind 232 + ('html (string-append 233 + "<!doctype html>\n<head>\n<title>fabulist" header "</title>\n" 234 + "<link rel=\"stylesheet\" href=\"/style\" type=\"text/css\">" 235 + "</head>\n<body>\n<h1> <a href=\"/\">fabulist</a>" header "</h1>\n")) 236 + ('text (string-append "# " header "\n\n")))) 237 + (define (close) 238 + (case kind 239 + ('html (string-append "</body>\n</html>\n")) 240 + ('text ""))) 241 + (let* ([opener (open)] 242 + [closer (close)] 243 + [body-text (map (cut eval-text kind <>) text)] 244 + [choices (map (cut emit-list-link kind <>) links)] 245 + [final-text (string-append opener 246 + (foldl string-append "" body-text) 247 + "<ol>\n" 248 + (foldl string-append "" choices) 249 + "</ol>\n" 250 + closer)] 251 + [content-length (number->string(string-length final-text))] 252 + [response (make-netresp code 253 + (list (cons "Server" "fabulist") 254 + (cons "Content-Type" mime) 255 + (cons "Content-Length" content-length)) 256 + final-text)]) 257 + response))) 258 + 259 + 260 +(define (get-new-story req) 0) 261 + 262 +(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" "") 326 + (cons "Content-Type" "text/css") 327 + (cons "Content-Length" (number->string 328 + (string-length style)))) 329 + style)) 330 + 331 +(define (get-new-chapter req) 332 + (let* ([path (netreq-path req)] 333 + [place (follow-path (cdr path))] 334 + [params (netreq-post-params req)]) 335 + (if (eq? #f place) (error-not-found req) 336 + (let* ([story-key (text-path-story-key place)] 337 + [story (text-path-story-rec place)] 338 + [chapter-key (text-path-chapter-key place)]) 339 + (new-chapter-page req story-key story chapter-key))))) 340 + 341 +(define (get-flag-chapter req) 0) 342 +(define (post-flag-chapter req) 0) 343 + 344 +(define (error-not-found req) 345 + (respond req 'nofile "error" 346 + '((p "the path you have entered is not meaningful.")) 347 + '(("start over" . "/")))) 348 + 349 +(define (display-index-page req) 350 + (respond req 'ok "" 351 + '((p "welcome to this " (b "fabulist" ) " instance.") 352 + (p "fabulist is a server for hosting collaborative interactive fiction." ) 353 + (p "select one of the links below.")) 354 + '(("start a new story" . "/init") 355 + ("play an existing story" . "/find") 356 + ("start a random story" . "/rand")))) 357 + 358 +(define (new-chapter-page req key story last-page) 359 + (let ([new-url (string-append "/new/" key (if (eq? #f last-page) "" 360 + (string-append "/" last-page)))]) 361 + (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"))) 368 + (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))))))) 374 + 375 +(define-record text-path 376 + story-key story-rec chapter-key) 377 + 378 +(define (follow-path path) 379 + (let* ([pathlen (length path)]) 380 + (cond [(or (< pathlen 1) 381 + (> pathlen 2)) #f] 382 + [else (let* ([story-key (car path)] 383 + [story-ent (alist-ref story-key 384 + (db-stories *database*) 385 + equal?)] 386 + [chapter-key (cond [(= pathlen 2) (cadr path)] 387 + [(eq? #f story-ent) #f] 388 + [else (story-start story-ent)])]) 389 + (make-text-path story-key story-ent chapter-key))]))) 390 + 391 +(define (format-user-text str) 392 + (map (cut list 'p <>) 393 + (string-split str "\n"))) 394 + 395 +(define (post-new-chapter req) 396 + (define (save-chapter key ch) 397 + (set! (db-pages *database*) 398 + (alist-update key ch (db-pages *database*)))) 399 + (define (save-to-start story chap) 400 + (story-start-set! story chap)) 401 + (define (add-to-page story-key dest new-key) 402 + (let* ([destkey (string-append story-key "." dest)] 403 + [dest-pg (alist-ref destkey (db-pages *database*) equal?)] 404 + [old-choices (page-choices dest-pg)]) 405 + (page-choices-set! dest-pg (append old-choices (list new-key))))) 406 + 407 + (let* ([path (netreq-path req)] 408 + [place (follow-path (cdr path))] 409 + [params (netreq-post-params req)]) 410 + (if (eq? #f place) (error-not-found req) 411 + (let* ([story-key (text-path-story-key place)] 412 + [story (text-path-story-rec place)] 413 + [chapter-key (text-path-chapter-key place)] 414 + [choice-link (post-field params "choice-link")] 415 + [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 + ))))) 436 + 437 + 438 +(define (get-story-chapter req) 439 + (define (render-chapter story-key story chapter) 440 + (define (lookup-chapter ch) (alist-ref (string-append story-key "." ch) 441 + (db-pages *database*) equal?)) 442 + (define (format-choice ch) 443 + (let ([dest (lookup-chapter ch)]) 444 + (cons (page-link dest) 445 + (string-append "/p/" story-key "/" ch)))) 446 + 447 + (let ([chap (lookup-chapter chapter)]) 448 + (if (eq? #f chap) (error-not-found req) 449 + (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)))))))) 457 + 458 + (let* ([path (netreq-path req)] 459 + [place (follow-path (cdr path))]) 460 + (if (eq? #f place) (error-not-found req) 461 + (let* ([story-key (text-path-story-key place)] 462 + [story-ent (text-path-story-rec place)] 463 + [chapter-key (text-path-chapter-key place)]) 464 + 465 + (cond [(eq? #f story-ent) (error-not-found req)] 466 + [(and (= (length path) 2) ; no chkey passed 467 + (eq? chapter-key #f)) ; and start is empty 468 + (new-chapter-page req story-key story-ent #f)] 469 + [else (render-chapter story-key story-ent chapter-key)]))))) 470 + 471 +(define (get-init-story req) 472 + (respond req 'ok "new story" 473 + '((p "what kind of story do you want to create?") 474 + (form "POST" "/init" 475 + (field "name" "story-name" "text") 476 + (field "genre" "story-genre" "text") 477 + (field "synopsis" "story-desc" "textarea"))) 478 + '(("never mind" . "/")))) 479 + 480 +(define (post-init-story req) 481 + (define (try msg expr) (if (eq? expr #f) #f msg)) 482 + (let* ([params (netreq-post-params req)] 483 + [name (post-field params "story-name")] 484 + [genre (post-field params "story-genre")] 485 + [desc (post-field params "story-desc")] 486 + [story-key (generate-key 4)] 487 + [author-key (generate-key 8)] 488 + [failure (or (try "name" (< (string-length name) 4)) 489 + (try "genre" (< (string-length genre) 4)) 490 + (try "synopsis" (< (string-length desc) 16)))] 491 + [body (cond [(string? failure) 492 + (list 493 + (list 'p (string-append 494 + "the " failure " you entered isn't long enough!")))] 495 + [else (list 496 + (list 'p "your story has been created!") 497 + (list 'p (list 'text 498 + "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.")))])] 499 + [link (cond [(eq? failure #f) 500 + (list (cons (list 'text "starting writing " (list 'b name)) 501 + (string-append "/p/" story-key)))] 502 + [else (list '("try again" . "/init") 503 + '("give up" . "/"))])]) 504 + 505 + (unless (string? failure) (begin 506 + (let* ([new-story (make-story name genre desc author-key #f)] 507 + [db-entry (cons story-key new-story)]) 508 + (set! (db-stories *database*) 509 + (cons db-entry (db-stories *database*)))))) 510 + (respond req 'ok "new story" body link))) 511 + 512 +(define route-table (list 513 + (cons '(get . ("style")) get-stylesheet) 514 + 515 + (cons '(get . ("p")) get-story-chapter) 516 + 517 + (cons '(get . ("init")) get-init-story) 518 + (cons '(post . ("init")) post-init-story) 519 + 520 + (cons '(get . ("new")) get-new-chapter) 521 + (cons '(post . ("new")) post-new-chapter) 522 + 523 + (cons '(get . ("flag")) get-flag-chapter) 524 + (cons '(post . ("flag")) post-flag-chapter))) 525 + 526 +(define (find-route method path) 527 + (define (search table path) 528 + (cond [(null? table) #f] 529 + [(equal? (cons method path) (caar table)) (cdar table)] 530 + [else (search (cdr table) path)])) 531 + (if (null? path) #f 532 + (let ((rs (search route-table path))) 533 + (if (not (eq? rs #f)) rs 534 + (find-route method (butlast path)))))) 535 + 536 +(define (route req) 537 + (let* ([path (netreq-path req)] 538 + [method (netreq-method req)] 539 + [pagefn (if (null? path) display-index-page 540 + (or (find-route method path) 541 + error-not-found))]) 542 + (pagefn req))) 543 + 544 +(define (read-ahead skip ct . args) 545 + (define (loop buf skip ct) 546 + (if (eq? ct 0) buf 547 + (let ([nextchar (apply read-char args)]) 548 + (if (eq? #!eof nextchar) buf 549 + (loop (if (> skip 0) buf 550 + (string-append buf (string nextchar))) 551 + (max 0 (- skip 1)) 552 + (- ct 1)))))) 553 + (loop "" skip (+ skip ct))) 554 + 555 +(define (characterize input) 556 + (define (loop len ptr) 557 + (if (equal? "" ptr) (if (> 0 len) 'invalid 'incomplete) 558 + (let* ([char (string-ref ptr 0)] 559 + [val (char->integer char)]) 560 + (cond [(and (>= val #x30) ;is ascii digit? 561 + (<= val #x39)) 562 + (loop (+ (- val #x30) (* len 10)) 563 + (substring ptr 1))] 564 + [(eqv? char #\:) (if (< (string-length ptr) len) 'incomplete 565 + (make-netstr len 566 + (substring ptr 1 len) 567 + (substring ptr len)))] 568 + [else 'invalid])))) 569 + (loop 0 input)) 570 + 571 +(define (parse-header str) 572 + (define (pairup a b . rst) 573 + (let ([p (cons a b)]) 574 + (if (null? rst) (cons p '()) 575 + (cons p (apply pairup rst))))) 576 + (let ([lst (string-split str "\x00" #t)]) 577 + (apply pairup lst))) 578 + 579 +(define (connect in out) 580 + (define (shutdown) 581 + (close-input-port in) 582 + (close-output-port out)) 583 + (define (accumulate buf) 584 + (let ([state (characterize buf)]) 585 + (cond 586 + [(eq? state 'invalid) #f] 587 + [(eq? state 'incomplete) (accumulate 588 + (string-append buf (string (read-char in))))] 589 + [else state]))) 590 + (let ([req (accumulate "")]) 591 + (if (not (netstr? req)) (write-string "bad scgi request" #f out) 592 + 593 + (let* ([header (parse-header (netstr-val req))] 594 + [bodysz (string->number 595 + (cdr (assoc "CONTENT_LENGTH" header)))] 596 + [body (string-append 597 + (netstr-rest req) 598 + (read-ahead 2 bodysz in))]) 599 + ; pass the structured data on to the router function, which 600 + ; will generate the appropriate page text for the request 601 + ; and pass it back as a netresp struct 602 + (write-string 603 + (netresp->string 604 + (route (alist->netreq header body))) #f out) 605 + )) 606 + (shutdown))) 607 + 608 + 609 +(define (serve port) 610 + (define (await-connections s) 611 + (let-values ([{in out} (tcp-accept s)]) 612 + (connect in out) 613 + #;(condition-case (connect in out) 614 + (v () (v))) 615 + (await-connections s))) 616 +(let ([server (tcp-listen port 100 "127.0.0.1")]) 617 + (await-connections server) 618 + (tcp-close server))) 619 + 620 +(serve 4056) 621 +#;(cond-expand 622 + (chicken-script ) 623 + (else))
Modified sexpc/sexpc.scm from [46b6c9a575] to [7c5e1b9792].
18 18 ; _Bool (((*(*const (((v)[])))(char, unsigned 19 19 ; __int128_t)))[5]) 20 20 ; (as i'm sure you immediately guessed) 21 21 ; 22 22 ; → no dependencies besides the lisp-macro.scm file 23 23 ; bundled with it, and the chicken stdlib. 24 24 25 -(import (chicken process-context)) 26 -(import (chicken condition)) 27 -(import (chicken pretty-print)) 28 -(import (chicken io)) 25 +(import (chicken process-context) 26 + (chicken condition) 27 + (chicken pretty-print) 28 + (chicken io)) 29 29 (include "../scmlib/lisp-macro.scm") 30 30 31 31 (define (first fst . lst) fst) 32 32 33 33 (: string-reduce (list --> string)) 34 34 (: words->string (list --> string)) 35 35 (: separate (string list --> string))