From 85202d014fa114989cb619e48bc815cac870d1d3 Mon Sep 17 00:00:00 2001 From: Tim Vaughan Date: Sat, 4 May 2019 11:04:32 +0200 Subject: [PATCH] Added support for search selectors. --- burrow.scm | 99 ++++++++++++++++++++++++++++++++++++------------------ 1 file changed, 67 insertions(+), 32 deletions(-) diff --git a/burrow.scm b/burrow.scm index 09b8df3..9e01845 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)) +;;; Selector retrieval -(define (serve-directory path config) - (let ((file-name (make-pathname (list (config-root-dir config) path) +(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 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,17 @@ (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 (apply (eval (read)) + (list (car arguments) remote-ip))))) + (error "Invalid query.")))) + ;;; Index rendering @@ -171,6 +194,18 @@ (define (serve-expression expression) (serve-info-records (conc (eval expression)))) + +;;; Utility methods + +(define (with-current-working-directory directory thunk) + (let ((old-wd (current-directory))) + (change-directory directory) + (thunk) + (change-directory old-wd))) + +(define (with-selector-dir selector thunk) + (with-current-working-directory (pathname-directory selector) thunk)) + ;;; main (define (print-usage progname) @@ -206,9 +241,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) -- 2.20.1