(chicken condition)
(chicken process)
(chicken process-context)
- srfi-13 matchable)
+ srfi-1 srfi-13 matchable)
(define gopher-index-file-name "index")
+(define burrow-version "1.0.0")
+
+(define burrow-footer
+ (conc "\n"
+ "--------------------------------------------------\n"
+ "Served by Burrow Gopher Server v" burrow-version "\n"
+ "Powered by Chicken Scheme!"))
+
;;; Server loop
;; We don't actually use worker threads here to handle requests,
;; the server just blocks until the first request is finished.
-(define (make-server-config root-dir host port)
- (list root-dir host port))
-
-(define (server-root-dir config) (list-ref config 0))
-(define (server-host config) (list-ref config 1))
-(define (server-port config) (list-ref config 2))
+(define-record config root-dir host port display-footer)
(define (run-server config)
- (print "Gopher server listening on port " (server-port config) " ...")
- (let ((listener (tcp-listen (server-port config))))
+ (print "Gopher server listening on port " (config-port config) " ...")
+ (let ((listener (tcp-listen (config-port config))))
(let server-loop ()
(let-values (((in-port out-port) (tcp-accept listener)))
(let* ((line (read-line in-port))
selector config))
(define (serve-directory path config)
- (let ((file-name (make-pathname (list (server-root-dir config) path)
+ (let ((file-name (make-pathname (list (config-root-dir config) path)
gopher-index-file-name)))
(if (regular-file? file-name)
- (with-input-from-file file-name
- (lambda ()
- (let loop ((c (peek-char)))
- (if (eof-object? c)
- 'done
- (begin
- (if (eq? c #\,)
- (begin
- (read-char)
- (serve-record (read) path config)
- (read-line))
- (serve-info-record (read-line)))
- (loop (peek-char)))))))
+ (begin
+ (with-input-from-file file-name
+ (lambda ()
+ (let loop ((c (peek-char)))
+ (if (eof-object? c)
+ 'done
+ (begin
+ (if (eq? c #\,)
+ (begin
+ (read-char)
+ (serve-record (read) path config)
+ (read-line))
+ (serve-info-records (read-line)))
+ (loop (peek-char)))))))
+ (if (config-display-footer config)
+ (serve-info-records burrow-footer)))
(error "Index file not found."))))
(define (serve-text-file path config)
- (let ((file-name (make-pathname (server-root-dir config) path)))
+ (let ((file-name (make-pathname (config-root-dir config) path)))
(if (regular-file? file-name)
(with-input-from-file file-name
(lambda ()
(error "File not found." file-name))))
(define (serve-binary-file path config)
- (let ((file-name (make-pathname (server-root-dir config) path)))
+ (let ((file-name (make-pathname (config-root-dir config) path)))
(if (regular-file? file-name)
(with-input-from-file file-name
(lambda ()
;;; Index rendering
-(define (serve-info-record info-string)
- (print "i" info-string "\tfake\tfake\t1\r"))
+(define (serve-info-records string)
+ (for-each
+ (lambda (line)
+ (print* "i")
+ (for-each (lambda (char)
+ (print* (if (eq? char #\tab)
+ " "
+ char)))
+ (string->list line))
+ (print "\tfake\tfake\t1\r"))
+ (string-split string "\n" #t)))
(define (serve-record record path config)
(match record
+ (('shell command) (serve-shell-command command))
+ (('eval expression) (serve-expression expression))
((type display-string selector host port)
(print type display-string "\t" selector "\t" host "\t" port "\r"))
((type display-string selector host)
path config))
((type display-string selector)
(serve-record (list type display-string selector
- (server-host config) (server-port config))
+ (config-host config) (config-port config))
path config))
((display-string selector)
(serve-record (list (infer-selector-type selector) display-string selector)
path config))
((selector)
- (serve-record (list (infer-selector-type selector) selector)
+ (serve-record (list (infer-selecto-type selector) selector)
path config))
(else (error "Unknown record type."))))
+(define (serve-shell-command command)
+ (let-values (((in-port out-port id) (process command)))
+ (serve-info-records (string-chomp (read-string #f in-port) "\n"))))
+
+(define (serve-expression expression)
+ (serve-info-records (conc (eval expression))))
;;; main
+(define (print-usage progname)
+ (print "Usage:\n"
+ progname " -h/--help\n"
+ progname " [-n/--no-footer] gopher-root-dir server-hostname [server-port]\n"
+ "\n"
+ "The -n option tells the server to not display a directory footer."))
+
(define (main)
- (let ((progname (car (argv)))
- (args (cdr (argv))))
- (if (or (< (length args) 2)
+ (let* ((progname (car (argv)))
+ (args (cdr (argv)))
+ (config (make-config '() '() 70 #t)))
+
+ (if (or (null? args)
(equal? (car args) "-h")
(equal? (car args) "--help"))
- (print "Usage:\n"
- progname " -h/--help\n"
- progname " gopher-root-dir server-hostname server-port")
- (let ((root (car args))
- (hostname (cadr args))
- (port (if (= (length args) 3) (string->number (caddr args)) 70)))
- (if port
- (run-server (make-server-config root hostname port))
- (error "Invalid port argument." port))))))
+ (print-usage progname)
+ (begin
+ (if (or (equal? (car args) "-n")
+ (equal? (car args) "--no-footer"))
+ (begin
+ (config-display-footer-set! config #f)
+ (set! args (cdr args))))
+ (print args)
+ (if (or (< (length args) 2)
+ (> (length args) 3))
+ (print-usage progname)
+ (begin
+ (config-root-dir-set! config (car args))
+ (config-host-set! config (cadr args))
+ (if (= (length args) 3)
+ (config-port-set! config (string->number (caddr args))))
+ (run-server config)))))))
;; (main)
(define (test)
- (run-server (make-server-config "gopher-root" "localhost" 70)))
+ (run-server (make-config "gopher-root" "localhost" 70 #t)))
;; (test)
The Lambda Lab / projects / scratchy.git / blobdiff