X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=scratchy.git;a=blobdiff_plain;f=burrower.scm;h=ed5e98ffaebfc3d65e9e04e4beb25ba46f8624e9;hp=62aa85329022acef87cbe34a03bef93f2af2f18c;hb=2ee1c7c6da9e093c1722a0009c82dba5c14a0db0;hpb=437a64dafdbc1f9475e62bf993b6dbf1b4c96ddb diff --git a/burrower.scm b/burrower.scm index 62aa853..ed5e98f 100644 --- a/burrower.scm +++ b/burrower.scm @@ -1,33 +1,35 @@ +;;; Burrower gopher server +;; +;; Requires Chicken 5.0.0. +;; + ;;; Imports -;; Chicken 5 (import (chicken tcp) (chicken port) (chicken io) (chicken string) (chicken pathname) - (chicken file posix) + (chicken file) (chicken time posix) (chicken condition) (chicken process) (chicken process-context) + (chicken process-context posix) srfi-1 srfi-13 matchable) -;; Chicken 4 -;; (use srfi-1 srfi-13 tcp posix matchable) - ;;; Global constants -(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!")) +(define gopher-index-filename "index") + ;;; Server loop ;; We don't yet use worker threads here to handle requests, @@ -35,36 +37,48 @@ ;; 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) +(define-record config + root-dir host port display-footer user group) (define (run-server config) - (print "Gopher server listening on port " (config-port config) " ...") + (set-buffering-mode! (current-output-port) #:line) (let ((listener (tcp-listen (config-port config)))) - (let server-loop () - (let-values (((in-port out-port) (tcp-accept listener))) - (let* ((line (read-line in-port)) - (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 "."))))) - (close-input-port in-port) - (close-output-port out-port)) - (server-loop)) - (tcp-close listener))) - + (print "Gopher server listening on port " (config-port config) " ...") + (drop-privs config) + (server-loop listener config)) + (tcp-close listener)) + +(define (drop-privs config) + (let ((uid (config-user config)) + (gid (config-group config))) + (if (not (null? gid)) ; Group first, since only root can switch groups. + (set! (current-group-id) gid)) + (if (not (null? uid)) + (set! (current-user-id) uid)))) + +(define (server-loop listener config) + (let-values (((in-port out-port) (tcp-accept listener))) + (let* ((line (read-line in-port)) + (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 "."))))) + (close-input-port in-port) + (close-output-port out-port)) + (server-loop listener config)) ;;; Selector type inference @@ -88,10 +102,11 @@ (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)) 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)))) @@ -102,19 +117,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 (legal-script-filename? filename config) + (and (legal-filename? filename config) + (string-suffix? ".scm" filename) + (file-executable? filename))) -(define (serve-directory selector config) +(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 +159,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,33 +189,45 @@ (loop (read-byte))))))) (error "File not found." filename)))) -(define (serve-query selector arguments config) - (let ((filename (make-pathname (config-root-dir config) selector))) - (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 - "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"))) + "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) @@ -201,6 +242,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) @@ -221,7 +263,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.")))) @@ -233,13 +275,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 @@ -262,43 +306,55 @@ (make-pathname (config-root-dir config) (pathname-directory selector)) thunk)) -;;; main + +;;; Main (define (print-usage progname) (print "Usage:\n" progname " -h/--help\n" - progname " [-n/--no-footer] gopher-root-dir server-hostname [server-port]\n" + progname " [-n/--no-footer] [-u/--user UID] [-g/--group GID] root-dir hostname [port]\n" "\n" - "The -n option tells the server to not display a directory footer.")) + "The -n option tells the server to not display a directory footer." + "The -u and -g can be used to set the UID and GID of the process following" + "the creation of the TCP port listener (which often requires root).")) (define (main) (let* ((progname (car (argv))) - (args (cdr (argv))) - (config (make-config '() '() 70 #t))) - - (if (or (null? args) - (equal? (car args) "-h") - (equal? (car args) "--help")) + (config (make-config '() '() 70 #t '() '()))) + (if (null? (cdr (argv))) (print-usage progname) - (begin - (if (or (equal? (car args) "-n") - (equal? (car args) "--no-footer")) - (begin - (config-display-footer-set! config #f) - (set! args (cdr args)))) - (if (or (< (length args) 2) - (> (length args) 3)) - (print-usage progname) - (begin - (config-root-dir-set! config (car args)) - (config-host-set! config (cadr args)) - (if (= (length args) 3) - (config-port-set! config (string->number (caddr args)))) - (run-server config))))))) + (let loop ((args (cdr (argv)))) + (let ((this-arg (car args)) + (rest-args (cdr args))) + (if (string-prefix? "-" this-arg) + (cond + ((or (equal? this-arg "-h") + (equal? this-arg "--help")) + (print-usage progname)) + ((or (equal? this-arg "-n") + (equal? this-arg "--no-footer")) + (config-display-footer-set! config #f) + (loop rest-args)) + ((or (equal? this-arg "-u") + (equal? this-arg "--user")) + (config-user-set! config (string->number (car rest-args))) + (loop (cdr rest-args))) + ((or (equal? this-arg "-g") + (equal? this-arg "--group")) + (config-group-set! config (string->number (car rest-args))) + (loop (cdr rest-args))) + (else + (print-usage progname))) + (begin + (config-root-dir-set! config (car args)) + (config-host-set! config (cadr args)) + (if (>= (length rest-args) 2) + (config-port-set! config (string->number (caddr args)))) + (run-server config)))))))) (main) ;; (define (test) -;; (run-server (make-config "gopher-root" "localhost" 70 #t))) +;; (run-server (make-config "gopher-root" "localhost" 70 #t '() '()))) ;; (test)