X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=scratchy.git;a=blobdiff_plain;f=burrow.scm;h=bb21e3af7bfefdd730f553fdf0924dde87e02a0b;hp=31cb2edb09cbe2fa91529f235fa35d34984b7bfc;hb=d3aae97b2523a554f31f7a6ff6468cf0ef6046d9;hpb=2c37c7eb2d1116c358712faab1bb760bde5bcf72 diff --git a/burrow.scm b/burrow.scm index 31cb2ed..bb21e3a 100644 --- a/burrow.scm +++ b/burrow.scm @@ -10,6 +10,8 @@ (chicken process-context) srfi-1 srfi-13 matchable) +;;; Global constants + (define gopher-index-file-name "index") (define burrow-version "1.0.0") @@ -20,9 +22,13 @@ "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, + +;; 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-record config root-dir host port display-footer) @@ -35,25 +41,26 @@ (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) @@ -69,19 +76,24 @@ ((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 (serve-selector selector config) - ((case (infer-selector-type selector) - ((1) serve-directory) - ((0) serve-text-file) - (else serve-binary-file)) - selector config)) +(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 (serve-directory path config) - (let ((file-name (make-pathname (list (config-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) (begin @@ -94,7 +106,7 @@ (if (eq? c #\,) (begin (read-char) - (serve-record (read) path config) + (serve-record (read) selector config) (read-line)) (serve-info-records (read-line))) (loop (peek-char))))))) @@ -102,8 +114,8 @@ (serve-info-records burrow-footer))) (error "Index file not found.")))) -(define (serve-text-file path config) - (let ((file-name (make-pathname (config-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 () @@ -113,8 +125,8 @@ (read-lines)))) (error "File not found." file-name)))) -(define (serve-binary-file path config) - (let ((file-name (make-pathname (config-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 () @@ -126,6 +138,21 @@ (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 @@ -141,33 +168,58 @@ (print "\tfake\tfake\t1\r")) (string-split string "\n" #t))) -(define (serve-record record path config) +(define (serve-record record dir-selector config) (match record - (('shell command) (serve-shell-command command)) - (('eval expression) (serve-expression expression)) + (('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) - path config)) + dir-selector config)) ((type display-string selector) - (serve-record (list type display-string selector + (serve-record (list type display-string + (make-pathname dir-selector selector) (config-host config) (config-port config)) - path config)) + dir-selector config)) ((display-string selector) (serve-record (list (infer-selector-type selector) display-string selector) - path config)) + dir-selector config)) ((selector) (serve-record (list (infer-selecto-type selector) selector) - path config)) + dir-selector 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-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 (serve-expression expression) - (serve-info-records (conc (eval expression)))) +(define (with-selector-dir selector config thunk) + (with-current-working-directory + (make-pathname (config-root-dir config) + (pathname-directory selector)) thunk)) ;;; main @@ -193,7 +245,6 @@ (begin (config-display-footer-set! config #f) (set! args (cdr args)))) - (print args) (if (or (< (length args) 2) (> (length args) 3)) (print-usage progname) @@ -204,9 +255,9 @@ (config-port-set! config (string->number (caddr args)))) (run-server config))))))) -;; (main) +(main) -(define (test) - (run-server (make-config "gopher-root" "localhost" 70 #t))) +;; (define (test) +;; (run-server (make-config "gopher-root" "localhost" 70 #t))) ;; (test)