X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=scratchy.git;a=blobdiff_plain;f=burrower.scm;h=f9604a7ec6baa3c6a0c1dc67d83c1bd65a0440ed;hp=fa8e1662c24cf0331bb91b614bf7b69995447f47;hb=307887439e723047cab1bc5a2572cb89e2f06630;hpb=d22cda7ea80777aa9ed10ec9b2917b9762fe5fe5 diff --git a/burrower.scm b/burrower.scm index fa8e166..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) @@ -25,7 +25,7 @@ (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 () @@ -88,10 +89,12 @@ (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" "%3f.scm") 7) + ((has-suffix? l "?" "%3f") 7) ((has-prefix? l "url:" "/url:") 'h) (else 9)))) @@ -102,19 +105,30 @@ (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)) - ((h) (serve-url selector config)) - (else (serve-binary-file selector config))))) + (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)) - (regular-file? filename))) + (file-exists? filename) + (not (directory-exists? filename)) + (file-readable? filename))) -(define (serve-directory selector config) +(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) @@ -133,18 +147,21 @@ (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 ((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)))) + (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) @@ -160,21 +177,6 @@ (loop (read-byte))))))) (error "File not found." filename)))) -(define (serve-query selector arguments config) - (let ((filename (make-pathname (config-root-dir config) - (string-translate* selector '(("%3f" . "?")))))) - (if (and (legal-filename? filename config) - (= (length arguments) 1)) - (with-input-from-file filename - (lambda () - (serve-info-records - (with-selector-dir - selector config - (lambda () - (apply (eval (read)) arguments)))))) - (error "Invalid query." selector arguments)))) - - (define (serve-url selector config) (let ((url (substring selector 4))) (print @@ -191,9 +193,29 @@ "" 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) @@ -208,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) @@ -228,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.")))) @@ -240,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 @@ -269,7 +294,8 @@ (make-pathname (config-root-dir config) (pathname-directory selector)) thunk)) -;;; main + +;;; Main (define (print-usage progname) (print "Usage:\n" @@ -303,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)