sunet/scheme-program-server.scm

60 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 "----------------------------------------~%")
(let ((request-method (request:method req)))
(if (or (string=? request-method "GET")
(string=? request-method "POST")) ; Could do others also.
(wait (fork doit))
(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))
(cond ((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))))