59 lines
2.1 KiB
Scheme
59 lines
2.1 KiB
Scheme
|
(define scheme-program-handler
|
||
|
|
(lambda (path req)
|
||
|
|
(if (pair? path) ; Got to have at least one elt.
|
||
|
|
(let* ((prog (car path))
|
||
|
|
|
||
|
|
(search (http-url:search (request:url req))) ; Compute the
|
||
|
|
(arglist (if (and search (not (index search #\=))) ; argv list.
|
||
|
|
(split-and-decode-search-spec search)
|
||
|
|
'()))
|
||
|
|
(env (exec-env req (cdr path))) ; set global environment vars
|
||
|
|
(doit (lambda ()
|
||
|
|
((runprogram prog) arglist))))
|
||
|
|
|
||
|
|
(and (http-log "----------------------------------------~%")
|
||
|
|
(http-log " Programmname : ~s~%" prog)
|
||
|
|
(http-log " search : ~s~%" search)
|
||
|
|
(http-log " Argumente : ~s~%" arglist)
|
||
|
|
(http-log "----------------------------------------~%")
|
||
|
|
|
||
|
|
(switch string=? (request:method req)
|
||
|
|
(("GET" "POST") ; Could do others also.
|
||
|
|
(wait (fork doit)))
|
||
|
|
(else (http-error http-reply/method-not-allowed req)))))
|
||
|
|
|
||
|
|
(http-error http-reply/bad-request req "Error "))))
|
||
|
|
|
||
|
|
(define (runprogram progstring)
|
||
|
|
(let* ( (progsymbol (read (make-string-input-port progstring)))
|
||
|
|
(progsymbol1 (string->symbol progstring)))
|
||
|
|
(and (http-log "[]run-program ~s ~s ~s~%" progstring progsymbol progsymbol1)
|
||
|
|
(eval progsymbol (interaction-environment)))))
|
||
|
|
|
||
|
|
(define (split-and-decode-search-spec s)
|
||
|
|
(let recur ((i 0))
|
||
|
|
(? ((index s #\+ i) => (lambda (j) (cons (unescape-uri s i j)
|
||
|
|
(recur (+ j 1)))))
|
||
|
|
(else (list (unescape-uri s i (string-length s)))))))
|
||
|
|
|
||
|
|
(define url-path)
|
||
|
|
(define script-path)
|
||
|
|
(define script-name)
|
||
|
|
(define (exec-env req path-suffix)
|
||
|
|
(let* (;; Compute the $SCRIPT_PATH string.
|
||
|
|
(url-path1 (http-url:path (request:url req)))
|
||
|
|
(script-path1 (take (- (length url-path1) (length path-suffix))
|
||
|
|
url-path1))
|
||
|
|
(script-name1 (uri-path-list->path script-path1)))
|
||
|
|
(and (set! url-path url-path1)
|
||
|
|
(set! script-path script-path1)
|
||
|
|
(set! script-name script-name1))))
|
||
|
|
|
||
|
|
(define (take n lis)
|
||
|
|
(if (zero? n) '()
|
||
|
|
(cons (car lis) (take (- n 1) (cdr lis)))))
|
||
|
|
|
||
|
|
(define (drop n lis)
|
||
|
|
(if (zero? n) lis
|
||
|
|
(drop (- n 1) (cdr lis))))
|