X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=scratchy.git;a=blobdiff_plain;f=burrower.scm;h=f9604a7ec6baa3c6a0c1dc67d83c1bd65a0440ed;hp=a042e582687f07cb00094ff4d5d7f91c48dacf5c;hb=307887439e723047cab1bc5a2572cb89e2f06630;hpb=4e168d456f8ba1d7d3b94073a05814d431bc2808 diff --git a/burrower.scm b/burrower.scm index a042e58..f9604a7 100644 --- a/burrower.scm +++ b/burrower.scm @@ -6,7 +6,7 @@ (chicken io) (chicken string) (chicken pathname) - (chicken file posix) + (chicken file) (chicken time posix) (chicken condition) (chicken process) @@ -18,14 +18,14 @@ ;;; Global constants -(define gopher-index-file-name "index") +(define gopher-index-filename "index") (define burrower-version "1.0.0") (define burrower-footer (conc "\n" "--------------------------------------------------\n" - "This gopher hole was dug using Burrower v" burrower-version "\n" + "This gopher hole was dug using Burrower v" burrower-version ".\n" "Powered by Chicken Scheme!")) ;;; Server loop @@ -38,6 +38,7 @@ (define-record config root-dir host port display-footer) (define (run-server config) + (set-buffering-mode! (current-output-port) #:line) (print "Gopher server listening on port " (config-port config) " ...") (let ((listener (tcp-listen (config-port config)))) (let server-loop () @@ -68,20 +69,33 @@ ;;; 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))) (cond - ((or (= (string-length l) 0) (string-suffix? "/" l)) 1) + ((or (= (string-length l) 0) + (string-suffix? "/" l) + (string-contains l ":")) 1) ((has-suffix? l ".txt" ".org" ".md") 0) ((has-suffix? l ".png" ".jpg" ".gif" ".bmp" ".tif" ".tga") 'I) - ((has-suffix? l "?.scm") 7) + ((has-suffix? l "?" "%3f") 7) + ((has-prefix? l "url:" "/url:") 'h) (else 9)))) @@ -91,18 +105,35 @@ (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 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) + (if (string-contains selector ":") + (let ((l (string-split selector ":"))) + (serve-script (car l) (cdr l) config)) + (case (infer-selector-type selector) + ((1) (serve-directory-file selector config)) + ((7) (let ((l (string-split selector "?"))) + (serve-script (car l) arguments config))) + ((0) (serve-text-file selector 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)) + (file-exists? filename) + (not (directory-exists? filename)) + (file-readable? filename))) + +(define (legal-script-filename? filename config) + (and (legal-filename? filename config) + (string-suffix? ".scm" filename) + (file-executable? filename))) + +(define (serve-directory-file selector config) + (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) @@ -116,24 +147,27 @@ (serve-info-records (read-line))) (loop (peek-char))))))) (if (config-display-footer config) - (serve-info-records burrower-footer))) - (error "Index file not found.")))) + (serve-info-records burrower-footer)) + (print ".\r")) + (error "No legal 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 - (lambda () - (for-each - (lambda (line) - (print line "\r")) - (read-lines)))) - (error "File not found." file-name)))) + (let ((filename (make-pathname (config-root-dir config) selector))) + (if (legal-filename? filename config) + (begin + (with-input-from-file filename + (lambda () + (for-each + (lambda (line) + (print line "\r")) + (read-lines)))) + (print ".\r")) + (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,24 +175,47 @@ (begin (write-byte b) (loop (read-byte))))))) - (error "File not found." file-name)))) - -(define (serve-query selector arguments config) - (let ((file-name (make-pathname (config-root-dir config) selector))) - (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)) arguments)))))) - (error "Invalid query." selector arguments)))) + (error "File not found." filename)))) + +(define (serve-url selector config) + (let ((url (substring selector 4))) + (print + "Redirection" + "" + "" + "

If you are seeing this page, your gopher browser does not " + "properly support URL directory entries or cannot follow such " + "links.

" + "

If you are viewing this page using a web browser, you should " + "be redirected shortly. Otherwise, you can manually open the " + "the follwing url:\n" + "\n" + "" url "\n" + ""))) + +(define (serve-script selector arguments config) + (let ((filename (make-pathname (config-root-dir config) selector))) + (if (legal-script-filename? filename config) + (let* ((sexp (with-input-from-file filename read)) + (script-result (with-selector-dir + selector config + (lambda () + (apply (eval sexp) arguments))))) + (when (pair? script-result) + (serve-records script-result + (pathname-directory selector) config) + (print ".\r"))) + (error "No legal index script not found." filename)))) ;;; Index rendering +(define (serve-records records dir-selector config) + (for-each + (lambda (record) + (serve-record record dir-selector config)) + records)) + (define (serve-info-records string) (for-each (lambda (line) @@ -173,6 +230,7 @@ (define (serve-record record dir-selector config) (match record + ((? string?) (serve-info-records record)) (('shell command) (serve-shell-command command dir-selector config)) (('eval expression) (serve-expression expression dir-selector config)) (('url display-string url) @@ -193,7 +251,7 @@ (serve-record (list (infer-selector-type selector) display-string selector) dir-selector config)) ((selector) - (serve-record (list (infer-selecto-type selector) selector) + (serve-record (list (infer-selector-type selector) selector) dir-selector config)) (else (error "Unknown record type.")))) @@ -205,13 +263,15 @@ (let ((string (read-string #f in-port))) (if (and (not (eof-object? string)) (> (string-length string) 0)) - (serve-info-records (string-chomp string "\n")))))))) + (serve-info-records (string-chomp string "\n"))) + (close-input-port in-port) + (close-output-port out-port)))))) (define (serve-expression expression dir-selector config) (with-selector-dir dir-selector config (lambda () - (serve-info-records (conc (eval expression)))))) + (serve-records (eval expression) dir-selector config)))) ;;; Utility methods @@ -234,7 +294,8 @@ (make-pathname (config-root-dir config) (pathname-directory selector)) thunk)) -;;; main + +;;; Main (define (print-usage progname) (print "Usage:\n" @@ -268,9 +329,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) +(test)