#lang scheme/base ;; Minimalistic file server. (require "file-access.ss" ;; subpath file access "command.ss" ;; command-interpreter "simple-serve.ss") ;; minimalistic tcp server ;; Access control wrapper. (define (wrap-cmd fn) (lambda args (parameterize ((current-security-guard (make-security-guard (current-security-guard) (make-subpath-file-guard (lambda () '("/home/melissa/womenwriters.us.to")) (lambda (path) (raise-user-error 'permission-denied))) (lambda _ (raise-user-error 'no-network-access))))) (apply fn args)))) ;; Routines implementing commands. (define (mtime filename) (file-or-directory-modify-seconds filename)) (define (get filename) (with-input-from-file filename (lambda () (read-bytes (file-size filename))))) ;; Command interpreter. (define (default-cmd) (raise-user-error 'bad-request)) (define interpret (let ((interpret (command-interpreter (default-cmd wrap-cmd) (mtime get)))) (lambda (expr) (with-handlers ((void (lambda (ex) 'error))) (interpret expr))))) ;; Keep handling. (define (repl in out) (let next () (let ((command (read in))) (printf "~s\n" command) (parameterize ((current-output-port out)) (write (interpret command)) (newline) (flush-output)) (next)))) ;; Run the interpreter over TCP. (define (go port) (serve port repl)) (define (port) (read (open-input-string (vector-ref (current-command-line-arguments) 0)))) (define (debug) (let ((shutdown (serve (port) repl))) (display "Hit ENTER to terminate\n") (read-line) (shutdown))) (define (busy) (sleep 1000) (busy)) (define (start) (serve (port) repl) (busy)) (start)