X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=scratchy.git;a=blobdiff_plain;f=burrower.scm;h=8829de4f54a0a17cabe4c2f1277a66ae1681ef77;hp=a042e582687f07cb00094ff4d5d7f91c48dacf5c;hb=8b7b8b99877605d47975fc550047493d25c0f392;hpb=4e168d456f8ba1d7d3b94073a05814d431bc2808

diff --git a/burrower.scm b/burrower.scm
index a042e58..8829de4 100644
--- a/burrower.scm
+++ b/burrower.scm
@@ -18,7 +18,7 @@
 
 ;;; Global constants
 
-(define gopher-index-file-name "index")
+(define gopher-index-filename "index")
 
 (define burrower-version "1.0.0")
 
@@ -68,12 +68,22 @@
 
 ;;; Selector type inference
 
-(define (has-suffix? selector . suffixes)
-  (if (null? suffixes)
+(define (true-for-one? predicate values)
+  (if (null? values)
       #f
-      (if (string-suffix? (car suffixes) selector)
+      (if (predicate (car values))
           #t
-          (apply has-suffix? selector (cdr suffixes)))))
+          (true-for-one? predicate (cdr values)))))
+
+(define (has-suffix? selector . suffixes)
+  (true-for-one? (lambda (suffix)
+                   (string-suffix? suffix selector))
+                 suffixes))
+
+(define (has-prefix? selector . prefixes)
+  (true-for-one? (lambda (prefix)
+                   (string-prefix? prefix selector))
+                 prefixes))
 
 (define (infer-selector-type selector)
   (let ((l (string-downcase selector)))
@@ -82,6 +92,7 @@
      ((has-suffix? l ".txt" ".org" ".md") 0)
      ((has-suffix? l ".png" ".jpg" ".gif" ".bmp" ".tif" ".tga") 'I)
      ((has-suffix? l "?.scm") 7)
+     ((has-prefix? l "url:" "/url:") 'h)
      (else 9))))
 
 
@@ -95,14 +106,20 @@
       ((1) (serve-directory selector config))
       ((0) (serve-text-file selector config))
       ((7) (serve-query selector arguments config))
+      ((h) (serve-url selector config))
       (else (serve-binary-file selector config)))))
 
+(define (legal-filename? filename config)
+  (and (string-prefix? (config-root-dir config)
+                       (normalize-pathname filename))
+       (regular-file? filename)))
+
 (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)
+  (let ((filename (make-pathname (list (config-root-dir config) selector
+                                  gopher-index-filename))))
+    (if (legal-filename? filename config)
         (begin
-          (with-input-from-file file-name
+          (with-input-from-file filename
             (lambda ()
               (let loop ((c (peek-char)))
                 (if (eof-object? c)
@@ -120,20 +137,20 @@
         (error "Index file not found."))))
   
 (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
+  (let ((filename (make-pathname (config-root-dir config) selector)))
+    (if (legal-filename? filename config)
+        (with-input-from-file filename
           (lambda ()
             (for-each
              (lambda (line)
                (print line "\r"))
              (read-lines))))
-        (error "File not found." file-name))))
+        (error "File not found." filename))))
 
 (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
+  (let ((filename (make-pathname (config-root-dir config) selector)))
+    (if (legal-filename? filename config)
+        (with-input-from-file filename
           (lambda ()
             (let loop ((b (read-byte)))
               (if (eof-object? b)
@@ -141,13 +158,13 @@
                   (begin
                     (write-byte b)
                     (loop (read-byte)))))))
-        (error "File not found." file-name))))
+        (error "File not found." filename))))
 
 (define (serve-query selector arguments config)
-  (let ((file-name (make-pathname (config-root-dir config) selector)))
-    (if (and (regular-file? file-name)
+  (let ((filename (make-pathname (config-root-dir config) selector)))
+    (if (and (legal-filename? filename config)
              (= (length arguments) 1))
-        (with-input-from-file file-name
+        (with-input-from-file filename
           (lambda ()
             (serve-info-records
              (with-selector-dir
@@ -157,6 +174,17 @@
         (error "Invalid query." selector arguments))))
 
 
+(define (serve-url selector config)
+  (let ((url (substring selector 4)))
+    (print
+     "If you are seeing this page, your gopher browser does not\r\n"
+     "properly support URL directory entries or cannot follow such\r\n"
+     "links.  To view the link you requested, use a web browser to\r\n"
+     "open the follwing url:\r\n"
+     "\r\n"
+     url "\r\n")))
+
+
 ;;; Index rendering
 
 (define (serve-info-records string)