X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=scratchy.git;a=blobdiff_plain;f=burrow.scm;h=bb21e3af7bfefdd730f553fdf0924dde87e02a0b;hp=26814d895f355cce086bf69e35e5cd44ed67d887;hb=d3aae97b2523a554f31f7a6ff6468cf0ef6046d9;hpb=7aabc06f178c6bb5f37ecb95f0f3c03375663491 diff --git a/burrow.scm b/burrow.scm index 26814d8..bb21e3a 100644 --- a/burrow.scm +++ b/burrow.scm @@ -8,87 +8,114 @@ (chicken condition) (chicken process) (chicken process-context) - srfi-13) + srfi-1 srfi-13 matchable) + +;;; Global constants (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)) +;; We don't yet use worker threads here to handle requests, +;; the server just blocks until the first request is finished. +;; While we should fix this, it's actually probably okay, as +;; we genuinely don't expect a huge flood of gopher traffic. :-( -(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 (string-trim-both line))) (let-values (((local-ip remote-ip) (tcp-addresses in-port))) (print "Accepted connection from " remote-ip - " on " (seconds->string))) - (condition-case - (begin - (with-output-to-port out-port - (lambda () - (serve-selector (if (= (string-length selector) 0) - "/" - selector) - config))) - (print "... served selector '" selector "'. Closing connection.")) - (o (exn) - (print-error-message o out-port) - (print-error-message o) - (print "Error while attempting to serve selector " selector ".")))) + " on " (seconds->string)) + (condition-case + (begin + (with-output-to-port out-port + (lambda () + (serve-selector (if (= (string-length selector) 0) + "/" + selector) + remote-ip config))) + (print "... served selector '" selector "'. Closing connection.")) + (o (exn) + (print-error-message o out-port) + (print-error-message o) + (print "Error while attempting to serve selector " selector "."))))) (close-input-port in-port) (close-output-port out-port)) (server-loop)) (tcp-close listener))) +;;; Selector type inference + +(define (has-suffix? selector . suffixes) + (if (null? suffixes) + #f + (if (string-suffix? (car suffixes) selector) + #t + (apply has-suffix? selector (cdr suffixes))))) + +(define (infer-selector-type selector) + (let ((l (string-downcase selector))) + (cond + ((or (= (string-length l) 0) (string-suffix? "/" l)) 1) + ((has-suffix? l ".txt" ".org" ".md") 0) + ((has-suffix? l ".png" ".jpg" ".gif" ".bmp" ".tif" ".tga") 'I) + ((has-suffix? l "?") 7) + (else 9)))) + + ;;; Selector retrieval -(define (directory-selector? selector) - (string-suffix? "/" selector)) +(define (serve-selector raw-selector remote-ip config) + (let* ((selector-list (string-split raw-selector "\t")) + (selector (car selector-list)) + (arguments (cdr selector-list))) + (case (infer-selector-type selector) + ((1) (serve-directory selector config)) + ((0) (serve-text-file selector config)) + ((7) (serve-query selector arguments remote-ip config)) + (else (serve-binary-file selector config))))) -(define (text-selector? selector) - (apply or (map (lambda (ext) (string-suffix? ext selector)) - '(".txt" ".org" ".md")))) - -(define (serve-selector selector config) - ((cond - ((directory-selector? selector) serve-directory) - ((text-selector? seletor) serve-text-file) - (else serve-binary-file)) - selector config)) - -(define (serve-directory path config) - (let ((file-name (make-pathname (list (server-root-dir config) path) +(define (serve-directory selector config) + (let ((file-name (make-pathname (list (config-root-dir config) selector) 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) selector 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))) +(define (serve-text-file selector config) + (let ((file-name (make-pathname (config-root-dir config) selector))) (if (regular-file? file-name) (with-input-from-file file-name (lambda () @@ -98,8 +125,8 @@ (read-lines)))) (error "File not found." file-name)))) -(define (serve-binary-file path config) - (let ((file-name (make-pathname (server-root-dir config) path))) +(define (serve-binary-file selector config) + (let ((file-name (make-pathname (config-root-dir config) selector))) (if (regular-file? file-name) (with-input-from-file file-name (lambda () @@ -111,33 +138,126 @@ (loop (read-byte))))))) (error "File not found." file-name)))) +(define (serve-query selector arguments remote-ip config) + (let ((file-name (make-pathname (config-root-dir config) + (conc (string-chomp selector "?") ".scm")))) + (if (and (regular-file? file-name) + (= (length arguments) 1)) + (with-input-from-file file-name + (lambda () + (serve-info-records + (with-selector-dir + selector config + (lambda () + (apply (eval (read)) + (list (car arguments) remote-ip))))))) + (error "Invalid query.")))) + ;;; 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 dir-selector config) + (match record + (('shell command) (serve-shell-command command dir-selector config)) + (('eval expression) (serve-expression expression dir-selector config)) + (('url display-string url) + (print #\h display-string "\tURL:" url "\tfake\t80\r")) + ((type display-string selector host port) + (print type display-string "\t" selector "\t" host "\t" port "\r")) + ((type display-string selector host) + (serve-record (list type display-string selector host 70) + dir-selector config)) + ((type display-string selector) + (serve-record (list type display-string + (make-pathname dir-selector selector) + (config-host config) (config-port config)) + dir-selector config)) + ((display-string selector) + (serve-record (list (infer-selector-type selector) display-string selector) + dir-selector config)) + ((selector) + (serve-record (list (infer-selecto-type selector) selector) + dir-selector config)) + (else (error "Unknown record type.")))) + +(define (serve-shell-command command dir-selector config) + (with-selector-dir + dir-selector config + (lambda () + (let-values (((in-port out-port id) (process command))) + (serve-info-records (string-chomp (read-string #f in-port) "\n")))))) + +(define (serve-expression expression dir-selector config) + (with-selector-dir + dir-selector config + (lambda () + (serve-info-records (conc (eval expression)))))) + + +;;; Utility methods + +(define (with-current-working-directory directory thunk) + (let ((old-wd (current-directory)) + (result 'none)) + (change-directory directory) + (set! result (thunk)) + (change-directory old-wd) + result)) + +(define (with-selector-dir selector config thunk) + (with-current-working-directory + (make-pathname (config-root-dir config) + (pathname-directory selector)) thunk)) ;;; 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)))) + (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)