util  Check-in [e82124aeb7]

Overview
Comment:updates
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA3-256: e82124aeb7366f10622ff5431f4b81019e873a2ad2afee35a1ea515c98c7e701
User & Date: lexi on 2019-07-29 06:11:18
Other Links: manifest | tags
Context
2019-07-29
06:11
add fabulist stylesheet check-in: 689acafd82 user: lexi tags: trunk
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
Changes

Modified fabulist.scm from [e734573397] to [189c348a0b].

     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))

Modified nkvd.c from [6971590b48] to [ca4bf4ac94].

   106    106    *
   107    107    * TODO: support a mappings file/variable for those programs
   108    108    *       too special to simply name their config file
   109    109    *       "~/.(argv[0])". 
   110    110    *
   111    111    * TODO: exempt xdg dirs beginning with ~/. from proscription
   112    112    *       in nkvd_interdict_all=1 mode
          113  + *
          114  + * TODO: instead of function passthrough,  alter environment
          115  + *       to delete  LD_PRELOAD and re-exec  whitelisted apps
          116  + *       without nkvd loading at all
   113    117    */
   114    118   
   115    119   #include <stdarg.h>
   116    120   #include <unistd.h>
   117    121   #include <sys/types.h>
   118    122   #include <fcntl.h>
   119    123   #include <limits.h>