;;; Imports ;; Chicken 5 (import (chicken tcp) (chicken port) (chicken io) (chicken string) (chicken pathname) (chicken file posix) (chicken time posix) (chicken condition) (chicken process) (chicken process-context) 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" "Powered by Chicken Scheme!")) ;;; Server loop ;; 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) (define (run-server config) (print "Gopher server listening on port " (config-port config) " ...") (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))) ;;; Selector type inference (define (true-for-one? predicate values) (if (null? values) #f (if (predicate (car values)) #t (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) ((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)))) ;;; Selector retrieval (define (serve-selector raw-selector 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 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 ((filename (make-pathname (list (config-root-dir config) selector) gopher-index-filename))) (if (legal-filename? filename config) (begin (with-input-from-file filename (lambda () (let loop ((c (peek-char))) (if (eof-object? c) 'done (begin (if (eq? c #\,) (begin (read-char) (serve-record (read) selector config) (read-line)) (serve-info-records (read-line))) (loop (peek-char))))))) (if (config-display-footer config) (serve-info-records burrower-footer))) (error "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)))) (error "File not found." filename)))) (define (serve-binary-file selector config) (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) 'done (begin (write-byte b) (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"))) ;;; Index rendering (define (serve-info-records string) (for-each (lambda (line) (print* "i") (for-each (lambda (char) (print* (if (eq? char #\tab) " " char))) (string->list line)) (print "\tfake\tfake\t1\r")) (string-split string "\n" #t))) (define (serve-record record dir-selector config) (match record (('shell command) (serve-shell-command command dir-selector config)) (('eval expression) (serve-expression expression dir-selector config)) (('url display-string url) (print #\h display-string "\tURL:" url "\t" (config-host config) "\t" (config-port config) "\r")) ((type display-string selector host port) (print type display-string "\t" selector "\t" host "\t" port "\r")) ((type display-string selector host) (serve-record (list type display-string selector host 70) dir-selector config)) ((type display-string selector) (serve-record (list type display-string (make-pathname dir-selector selector) (config-host config) (config-port config)) dir-selector config)) ((display-string selector) (serve-record (list (infer-selector-type selector) display-string selector) dir-selector config)) ((selector) (serve-record (list (infer-selecto-type selector) selector) dir-selector config)) (else (error "Unknown record type.")))) (define (serve-shell-command command dir-selector config) (with-selector-dir dir-selector config (lambda () (let-values (((in-port out-port id) (process command))) (let ((string (read-string #f in-port))) (if (and (not (eof-object? string)) (> (string-length string) 0)) (serve-info-records (string-chomp string "\n")))))))) (define (serve-expression expression dir-selector config) (with-selector-dir dir-selector config (lambda () (serve-info-records (conc (eval expression)))))) ;;; Utility methods (define (with-current-working-directory directory thunk) (let ((old-wd (current-directory)) (result 'none)) (condition-case (begin (change-directory directory) (set! result (thunk)) (change-directory old-wd) result) (o (exn) (change-directory old-wd) (signal o))))) (define (with-selector-dir selector config thunk) (with-current-working-directory (make-pathname (config-root-dir config) (pathname-directory selector)) thunk)) ;;; main (define (print-usage progname) (print "Usage:\n" progname " -h/--help\n" progname " [-n/--no-footer] gopher-root-dir server-hostname [server-port]\n" "\n" "The -n option tells the server to not display a directory footer.")) (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")) (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))))))) (main) ;; (define (test) ;; (run-server (make-config "gopher-root" "localhost" 70 #t))) ;; (test)