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) (export main)
(import :std/getopt (import :std/format
:std/getopt
:std/iter :std/iter
:std/logger
:std/net/address
:std/net/httpd :std/net/httpd
:std/srfi/19 :std/srfi/19
:std/sugar :std/sugar
@ -19,54 +22,70 @@
(try (try
(let (opt (getopt-parse gopt args)) (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) (catch (getopt-error? exn)
(getopt-display-help exn "server" (current-error-port)) (getopt-display-help exn "server" (current-error-port))
(exit 1)))) (exit 1))))
(def (run address) (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))) (let (httpd (start-http-server! address mux: (make-default-http-mux default-handler)))
(http-register-handler httpd "/" departures-handler) (http-register-handler httpd "/" departures-handler)
(thread-join! httpd))) (thread-join! httpd)))
;; / ;; /
(def (departures-handler req res) (def (departures-handler req res)
(def sncf-key (getenv "SNCF_AUTH_KEY" #f)) (let/cc return
(unless sncf-key (infof "~a ~a ~a"
(display "No SNCF API authentication key found. Set the SNCF_AUTH_KEY environment variable.\n" (http-request-method req)
(current-error-port)) (http-request-path req)
(exit 1)) (inet-address->string (http-request-client req)))
(def headers (http-request-headers req)) (def sncf-key (getenv "SNCF_AUTH_KEY" #f))
(def accept-header (assoc "Accept" headers)) (unless sncf-key
(when accept-header (set! accept-header (cdr accept-header))) (errorf "No SNCF API authentication key found. Set the SNCF_AUTH_KEY environment variable.")
(def params (parse-request-params (http-request-params req))) (http-response-write res 500 '(("Content-Type" . "text/plain; charset=utf-8"))
(def station (assoc "station" params)) "Missing SNCF API authentication key\n")
(when station (set! station (cdr station))) (return))
(def datetime-str (assoc "datetime" params)) (def headers (http-request-headers req))
(def datetime (if datetime-str (def accept-header (assoc "Accept" headers))
(string->date (cdr datetime-str) "~Y~m~dT~H~M~S") (when accept-header (set! accept-header (cdr accept-header)))
#f)) (def params (parse-request-params (http-request-params req)))
(define-values (station-name station-id) (def station (assoc "station" params))
(if station (when station (set! station (cdr station)))
(get-station-id sncf-key station) (def datetime-str (assoc "datetime" params))
(values "Vernon - Giverny (Vernon)" "stop_area:SNCF:87415604"))) (def datetime (if datetime-str
(define-values (departures disruptions) (get-departures sncf-key station-id datetime)) (try
(def content (string->date (cdr datetime-str) "~Y~m~dT~H~M~S")
(cond (catch _
((or (assoc "markdown" params) (string-prefix? "text/markdown" accept-header)) (warnf "Badly formatted date string: ~a" (cdr datetime-str))
(with-output-to-string (http-response-write res 400 '(("Content-Type" . "text/plain; charset=utf-8"))
(lambda () (display-all departures disruptions station-name datetime (format "Badly formatted date string, expected %Y%m%dT%H%M%S: ~a\n"
style: 'markdown)))) (cdr datetime-str)))
((string-prefix? "text/html" accept-header) ; TODO (return)))
(with-output-to-string #f))
(lambda () (display-all departures disruptions station-name datetime (define-values (station-name station-id)
style: 'markdown)))) (if (string? station)
(#t (get-station-id sncf-key station)
(with-output-to-string (values "Vernon - Giverny (Vernon)" "stop_area:SNCF:87415604")))
(lambda () (display-all departures disruptions station-name datetime (define-values (departures disruptions) (get-departures sncf-key station-id datetime))
style: 'unicode)))))) (def content
(http-response-write res 200 '(("Content-Type" . "text/plain; charset=utf-8")) (cond
content)) ((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) (def (parse-request-params params)
(if params (if params