--- /dev/null
+(import (chicken tcp)
+ (chicken port)
+ (chicken io)
+ (chicken string)
+ (chicken pathname)
+ (chicken file posix)
+ (chicken time posix)
+ (chicken condition)
+ (chicken process-context)
+ srfi-13)
+
+(define gopher-index-file-name "index")
+
+;;; Server loop
+;; We don't actually use worker threads here to handle requests,
+;; the server just blocks until the first request is finished.
+
+(define (run-server gopher-root gopher-server-hostname gopher-server-port)
+ (print "Gopher server listening on port " gopher-server-port " ...")
+ (let ((listener (tcp-listen gopher-server-port)))
+ (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-file
+ (if (= (string-length selector) 0)
+ "1/"
+ selector)
+ gopher-root
+ gopher-server-hostname
+ gopher-server-port)))
+ (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)))
+
+
+;;; Item retrieval
+
+(define (serve-file selector gopher-root server-host server-port)
+ (let ((type (with-input-from-string (substring selector 0 1) read))
+ (path (substring selector 1)))
+ (case type
+ ((1) (serve-index-file path gopher-root server-host server-port))
+ ((0) (serve-text-file path gopher-root))
+ ((9 g I) (serve-binary-file path gopher-root))
+ (else (error "Unhandled file type:" type)))))
+
+(define (serve-index-file path gopher-root server-host server-port)
+ (let ((file-name (make-pathname (list gopher-root path) gopher-index-file-name)))
+ (if (regular-file? file-name)
+ (with-input-from-file file-name
+ (lambda ()
+ (render-index (read)
+ path
+ server-host
+ server-port)))
+ (error "Index file not found."))))
+
+(define (serve-text-file path gopher-root)
+ (let ((file-name (make-pathname gopher-root path)))
+ (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))))
+
+(define (serve-binary-file path gopher-root)
+ (let ((file-name (make-pathname gopher-root path)))
+ (if (regular-file? file-name)
+ (with-input-from-file file-name
+ (lambda ()
+ (let loop ((b (read-byte)))
+ (if (eof-object? b)
+ 'done
+ (begin
+ (write-byte b)
+ (loop (read-byte)))))))
+ (error "File not found." file-name))))
+
+
+;;; Index rendering
+
+(define entry-type car)
+
+(define entry-name cadr)
+
+(define (has-selector? entry) (>= (length entry) 3))
+
+(define (entry-selector entry) (list-ref entry 2))
+
+(define (has-host? entry) (>= (length entry) 4))
+
+(define (entry-host entry) (list-ref entry 3))
+
+(define (has-port? entry) (>= (length entry) 5))
+
+(define (entry-port entry) (list-ref entry 4))
+
+(define (render-entry entry default-selector default-host default-port selector-prefix)
+ (let ((name-string (entry-name entry)))
+ (for-each
+ (lambda (name-string-line)
+ (print* (entry-type entry) name-string-line)
+ (print* "\t" (if (has-selector? entry)
+ (if (has-host? entry)
+ (entry-selector entry)
+ (conc (entry-type entry)
+ (make-pathname selector-prefix (entry-selector entry))))
+ default-selector))
+ (print* "\t" (if (has-host? entry)
+ (entry-host entry)
+ default-host))
+ (print* "\t" (if (has-port? entry)
+ (entry-port entry)
+ default-port))
+ (print* "\r\n"))
+ (string-split name-string "\n" #t))))
+
+(define (render-index index selector-prefix this-host this-port)
+ (for-each
+ (lambda (entry)
+ (if (eq? (entry-type entry) 'i)
+ (render-entry entry "fake.selector" "fake.host" 1 selector-prefix)
+ (render-entry entry "" this-host this-port selector-prefix)))
+ index)
+ (print "."))
+
+
+;;; main
+
+(define (main)
+ (let ((progname (car (argv)))
+ (args (cdr (argv))))
+ (if (or (< (length args) 2)
+ (equal? (car args) "-h")
+ (equal? (car args) "--help"))
+ (print "Usage:\n"
+ progname " -h/--help\n"
+ progname " gopher-root-dir server-hostname server-port")
+ (let ((root (car args))
+ (hostname (cadr args))
+ (port (if (= (length args) 3) (string->number (caddr args)) 70)))
+ (if port
+ (run-server root hostname port)
+ (error "Invalid port argument." port))))))
+
+(main)
+
+;; (define (test)
+ ;; (run-server "gopher-root" "localhost" 70))