109 lines
3.7 KiB
Scheme
Executable file
109 lines
3.7 KiB
Scheme
Executable file
#!/usr/bin/env gxi
|
|
|
|
(export main)
|
|
|
|
(import :std/format
|
|
:std/getopt
|
|
:std/iter
|
|
:std/logger
|
|
:std/net/address
|
|
:std/net/httpd
|
|
:std/srfi/19
|
|
:std/sugar
|
|
:gerbil/gambit/threads
|
|
:dlozeve/sncf/api
|
|
:dlozeve/sncf/display)
|
|
|
|
(def (main . args)
|
|
(def gopt
|
|
(getopt (option 'address "-a" "--address"
|
|
help: "server address"
|
|
default: ":8080")))
|
|
|
|
(try
|
|
(let (opt (getopt-parse gopt args))
|
|
(parameterize ((current-logger-options 'DEBUG))
|
|
(start-logger!)
|
|
(run (hash-get opt 'address))))
|
|
(catch (getopt-error? exn)
|
|
(getopt-display-help exn "server" (current-error-port))
|
|
(exit 1))))
|
|
|
|
(def (run address)
|
|
(infof "Starting HTTP server on ~a" (inet-address->string address))
|
|
(let (httpd (start-http-server! address mux: (make-default-http-mux default-handler)))
|
|
(http-register-handler httpd "/" departures-handler)
|
|
(thread-join! httpd)))
|
|
|
|
;; /
|
|
(def (departures-handler req res)
|
|
(let/cc return
|
|
(def sncf-key (getenv "SNCF_AUTH_KEY" #f))
|
|
(unless sncf-key
|
|
(errorf "No SNCF API authentication key found. Set the SNCF_AUTH_KEY environment variable.")
|
|
(http-response-write res 500 '(("Content-Type" . "text/plain; charset=utf-8"))
|
|
"Missing SNCF API authentication key\n")
|
|
(return))
|
|
(def headers (http-request-headers req))
|
|
(def accept-header (assoc "Accept" headers))
|
|
(when accept-header (set! accept-header (cdr accept-header)))
|
|
(def params (parse-request-params (http-request-params req)))
|
|
(def datetime-str (assoc "datetime" params))
|
|
(def datetime (if datetime-str
|
|
(try
|
|
(string->date (cdr datetime-str) "~Y~m~dT~H~M~S")
|
|
(catch _
|
|
(warnf "Badly formatted date string: ~a" (cdr datetime-str))
|
|
(http-response-write res 400 '(("Content-Type" . "text/plain; charset=utf-8"))
|
|
(format "Badly formatted date string, expected %Y%m%dT%H%M%S: ~a\n"
|
|
(cdr datetime-str)))
|
|
(return)))
|
|
#f))
|
|
(def station (assoc "station" params))
|
|
(when station (set! station (cdr station)))
|
|
(define-values (station-name station-id)
|
|
(if (string? station)
|
|
(get-station-id sncf-key station)
|
|
(values "Vernon - Giverny (Vernon)" "stop_area:SNCF:87415604")))
|
|
(unless station-name
|
|
(set! station-name "Vernon - Giverny"))
|
|
(unless station-id
|
|
(set! station-id "stop_area:SNCF:87415604"))
|
|
(infof "~a ~a ~a ~a (\"~a\")~a"
|
|
(inet-address->string (http-request-client req))
|
|
(http-request-method req)
|
|
(http-request-path req)
|
|
station-name
|
|
station
|
|
(if datetime (string-append " at " (cdr datetime-str)) ""))
|
|
(define-values (departures disruptions) (get-departures sncf-key station-id datetime))
|
|
(def content
|
|
(cond
|
|
((or (assoc "markdown" params) (string-prefix? "text/markdown" accept-header))
|
|
(with-output-to-string
|
|
(lambda () (display-all departures disruptions station-name datetime
|
|
style: 'markdown))))
|
|
((string-prefix? "text/html" accept-header) ; TODO
|
|
(with-output-to-string
|
|
(lambda () (display-all departures disruptions station-name datetime
|
|
style: 'markdown))))
|
|
(#t
|
|
(with-output-to-string
|
|
(lambda () (display-all departures disruptions station-name datetime
|
|
style: 'unicode))))))
|
|
(http-response-write res 200 '(("Content-Type" . "text/plain; charset=utf-8"))
|
|
content)))
|
|
|
|
(def (parse-request-params params)
|
|
(if params
|
|
(for/collect ((param (string-split params #\&)))
|
|
(match (string-split param #\=)
|
|
([k] (cons k #t))
|
|
([k v] (cons k v))
|
|
([k . rest] (cons k rest))))
|
|
'()))
|
|
|
|
;; default
|
|
(def (default-handler req res)
|
|
(http-response-write res 404 '(("Content-Type" . "text/plain"))
|
|
"these aren't the droids you are looking for.\n"))
|