Added support for search selectors.

diff --git a/burrow.scm b/burrow.scm
index 09b8df3..9e01845 100644 (file)
--- 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)