Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
A trivial gemini server in 100 lines of racket
#lang racket
;; Limit our memory usage
(custodian-limit-memory (current-custodian) (* 16 1024 1024))
;; Load libraries
(require openssl)
(require racket/date)
(require net/url-string)
;; Define the folders we are going to use
(define gemini-dir (reroot-path "/public_gemini" (find-system-path 'home-dir)))
(define private-dir (reroot-path "/.config/gemini" (find-system-path 'home-dir)))
(define test-key "/usr/share/racket/collects/openssl/test.pem")
;; Define how to display dates
(date-display-format 'iso-8601)
;; Define an SSL listener, immediately load certificates from `private-dir`
(define listener (ssl-listen 1965 5 #t))
(ssl-load-certificate-chain! listener (reroot-path "/localhost.crt" private-dir))
(ssl-load-private-key! listener (reroot-path "/localhost.key" private-dir))
;; cleanse-path PATH -- returns a cleaned-up version of PATH
;; Basically works the same as `(simplify-path PATH #f)`, but it also
;; removes `.` and `..` from the beginning of the path.
(define (cleanse-path path)
(apply build-path
(filter (lambda (x) (not (or (equal? x 'up) (equal? x 'same))))
(explode-path (simplify-path path #f)))))
;; localize-path PATH [BASE] -- relocates PATH under BASE
(define (localize-path path [base (find-system-path 'home-dir)])
(reroot-path (path->complete-path (cleanse-path path) "/") base))
;; path-exists? PATH -- checks if PATH exists and is either a file or a directory
(define (path-exists? path)
(or (file-exists? path) (directory-exists? path)))
;; get-perms PATH -- returns the permission bits for PATH
(define (get-perms path)
(file-or-directory-permissions path 'bits))
;; world-readable? PATH -- checks if the file at PATH is world-readable
(define (world-readable? path)
(= (bitwise-and (get-perms path) #o444) #o444))
;; file-listing PATH -- creates a text/gemini-formatted file listing for PATH
(define (file-listing path)
(for/list ([f (in-directory path)] #:unless (not (world-readable? f)))
(if (file-exists? f)
(format "=> ~a ~a [~aB]" (find-relative-path gemini-dir f) (file-name-from-path f) (file-size f))
(format "=> ~a ~a" (find-relative-path gemini-dir f) (file-name-from-path f)))))
;; gemini-serve REQUEST OUTPORT -- serves the response to REQUEST to OUTPORT
;; Checks if the file specified by REQUEST exists under `gemini-dir`, and
;; if it is world readable. If it does, it is served as text/gemini. If
;; it is a folder, and its `index.gmi` exists and is world-readable, it is
;; served instead; if it doesn't exist, then a simple directory listing is
;; created.
;;
;; If the file requested does not exist at all, or if it is not world-
;; readable, then replies with `51 Not Found`.
(define (gemini-serve request outport)
(define (outline string . pieces) (fprintf outport "~a~c~n" (apply format string pieces) #\return))
(define (log string) (display (current-memory-use)) (display (format "~a~n" string)))
(log request)
(let* ([path (url->path (string->url request))]
[file (localize-path path gemini-dir)]
[ok (and (path-exists? file) (world-readable? file))])
(log file)
(cond
[(and ok (directory-exists? file) (file-exists? (localize-path "index.gmi" file)))
(outline "~a ~a" 20 "text/gemini")
(call-with-input-file (localize-path "index.gmi" file)
(lambda (in) (copy-port in outport)))]
[(and ok (directory-exists? file))
(outline "~a ~a" 20 "text/gemini")
(outline "# ~a:" (find-relative-path gemini-dir file #:more-than-same? #f))
(outline (string-join (file-listing file) "\n"))
(outline "---~nGenerated by UNNAMED-GEMINI-SERVER on ~a" (date->string (current-date) #t))]
[ok
(outline "~a ~a" 20 "text/gemini")
(call-with-input-file file
(lambda (in) (copy-port in outport)))]
[else
(outline "~a ~a" 51 "Not found")])))
;; Main server loop: accepts an SSL connection, reads a single line from the
;; client, and invokes `(gemini-serve)` to handle it. Handles exceptions by
;; printing them out and ignoring them.
(let gemini-server ()
(with-handlers ([exn:fail:network?
(lambda (e) (displayln (exn-message e)))])
(define-values [inport outport] (ssl-accept listener))
(thread (lambda ()
(let ((request (read-line inport 'return-linefeed)))
(close-input-port inport)
(gemini-serve request outport)
(close-output-port outport)))))
(gemini-server))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment