dimitri/sncf-bot
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Add logs and fix issues where the server is crashing

Browse source
This commit is contained in:
Dimitri Lozeve 2022-09-20 19:36:01 +02:00
parent c21bbbb559
commit e223a736e1
1 changed files with 57 additions and 38 deletions
Download patch file Download diff file Expand all files Collapse all files

95
server.ss
View file

@ -2,8 +2,11 @@
(export main)
(import :std/getopt
(import :std/format
:std/getopt
:std/iter
:std/logger
:std/net/address
:std/net/httpd
:std/srfi/19
:std/sugar
@ -19,54 +22,70 @@
(try
(let (opt (getopt-parse gopt args))
(run (hash-get opt 'address)))
(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)
(def sncf-key (getenv "SNCF_AUTH_KEY" #f))
(unless sncf-key
(display "No SNCF API authentication key found. Set the SNCF_AUTH_KEY environment variable.\n"
(current-error-port))
(exit 1))
(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 station (assoc "station" params))
(when station (set! station (cdr station)))
(def datetime-str (assoc "datetime" params))
(def datetime (if datetime-str
(string->date (cdr datetime-str) "~Y~m~dT~H~M~S")
#f))
(define-values (station-name station-id)
(if station
(get-station-id sncf-key station)
(values "Vernon - Giverny (Vernon)" "stop_area:SNCF:87415604")))
(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))
(let/cc return
(infof "~a ~a ~a"
(http-request-method req)
(http-request-path req)
(inet-address->string (http-request-client req)))
(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 station (assoc "station" params))
(when station (set! station (cdr station)))
(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))
(define-values (station-name station-id)
(if (string? station)
(get-station-id sncf-key station)
(values "Vernon - Giverny (Vernon)" "stop_area:SNCF:87415604")))
(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