Group functions in submodules
This commit is contained in:
parent
0f6e22bf6a
commit
8c68491550
6 changed files with 143 additions and 111 deletions
1
.gitignore
vendored
1
.gitignore
vendored
|
|
@ -1,3 +1,2 @@
|
|||
*\~
|
||||
sncf
|
||||
build-deps*
|
||||
|
|
|
|||
33
build.ss
33
build.ss
|
|
@ -2,22 +2,33 @@
|
|||
|
||||
(import :std/make)
|
||||
|
||||
;; the build specification
|
||||
(def build-spec
|
||||
(def lib-build-spec
|
||||
'("sncf/api"
|
||||
"sncf/display"
|
||||
"sncf/mattermost"
|
||||
))
|
||||
|
||||
(def bin-build-spec
|
||||
'((exe: "sncf")))
|
||||
|
||||
;; the source directory anchor
|
||||
(def srcdir
|
||||
(path-normalize (path-directory (this-source-file))))
|
||||
|
||||
;; the main function of the script
|
||||
(def (main . args)
|
||||
(match args
|
||||
;; this is the default (and, here, only) action, which builds the project
|
||||
(["lib"]
|
||||
(make srcdir: srcdir
|
||||
optimize: #t
|
||||
debug: 'src
|
||||
static: #t
|
||||
lib-build-spec))
|
||||
(["bin"]
|
||||
(make srcdir: srcdir
|
||||
optimize: #t
|
||||
debug: #f
|
||||
static: #t
|
||||
build-deps: "build-deps-bin"
|
||||
bin-build-spec))
|
||||
([]
|
||||
(make srcdir: srcdir ; source anchor
|
||||
;;bindir: srcdir ; where to place executables; default is GERBIL_PATH/bin
|
||||
optimize: #t ; enable optimizations
|
||||
debug: #f ; enable debugger introspection
|
||||
static: #t ; don't generate static compilation artifacts
|
||||
build-spec)))) ; the actual build specification
|
||||
(main "lib")
|
||||
(main "bin"))))
|
||||
|
|
|
|||
102
sncf.ss
102
sncf.ss
|
|
@ -4,17 +4,12 @@
|
|||
|
||||
(import :std/format
|
||||
:std/getopt
|
||||
:std/iter
|
||||
:std/misc/string
|
||||
:std/net/request
|
||||
:std/net/uri
|
||||
:std/srfi/19
|
||||
:std/sugar
|
||||
:std/text/json
|
||||
:dlozeve/fancy/format
|
||||
:dlozeve/fancy/table)
|
||||
|
||||
(def +sncf-url+ "https://api.sncf.com/v1/coverage/sncf")
|
||||
:dlozeve/sncf/api
|
||||
:dlozeve/sncf/display
|
||||
:dlozeve/sncf/mattermost)
|
||||
|
||||
(def (main . args)
|
||||
(def gopt (getopt (optional-argument 'station help: "Name of the station (default Vernon-Giverny).")
|
||||
|
|
@ -70,94 +65,3 @@
|
|||
(catch (exn)
|
||||
(display (error-message exn) (current-error-port))
|
||||
(exit 1))))
|
||||
|
||||
(def (get-station-id sncf-key station)
|
||||
(def url (format "~a/pt_objects?q=~a&type\\[\\]=stop_area" +sncf-url+ (uri-encode station)))
|
||||
(def req (http-get url headers: `(("Authorization" . ,sncf-key))))
|
||||
(if (eq? 200 (request-status req))
|
||||
(let (req-json (request-json req))
|
||||
(let ((pts (hash-ref req-json 'pt_objects #f)))
|
||||
(if (and pts (not (null? pts)))
|
||||
(values (hash-ref (car pts) 'name) (hash-ref (car pts) 'id))
|
||||
(begin (display (format "No station found for \"~a\".\n" station) (current-error-port))
|
||||
(exit 1)))))
|
||||
(begin (display (format "Failed to query the SNCF API: ~a ~a\n"
|
||||
(request-status req) (request-status-text req)))
|
||||
(exit 1))))
|
||||
|
||||
(def (get-departures sncf-key station-id (datetime #f))
|
||||
(def url (format "~a/stop_areas/~a/departures" +sncf-url+ station-id))
|
||||
(def params (if datetime
|
||||
`(("from_datetime" . ,(date->string datetime "~Y~m~dT~H~M~S")))
|
||||
#f))
|
||||
(def req (http-get url headers: `(("Authorization" . ,sncf-key)) params: params))
|
||||
(if (eq? 200 (request-status req))
|
||||
(let (req-json (request-json req))
|
||||
(values (parse-departures (hash-ref req-json 'departures))
|
||||
(hash-ref req-json 'disruptions)))
|
||||
(begin (display (format "Failed to query the SNCF API: ~a ~a\n"
|
||||
(request-status req) (request-status-text req)))
|
||||
(exit 1))))
|
||||
|
||||
(defstruct departure (network direction base-datetime datetime))
|
||||
|
||||
(def (parse-departures departures-json)
|
||||
(for/collect ((dep departures-json))
|
||||
(let* ((info (hash-ref dep (string->symbol "display_informations")))
|
||||
(stop-dt (hash-ref dep (string->symbol "stop_date_time")))
|
||||
(base-dep-dt-str (hash-ref stop-dt (string->symbol "base_departure_date_time")))
|
||||
(base-dep-dt (string->date base-dep-dt-str "~Y~m~dT~H~M~S"))
|
||||
(dep-dt-str (hash-ref stop-dt (string->symbol "departure_date_time")))
|
||||
(dep-dt (string->date dep-dt-str "~Y~m~dT~H~M~S")))
|
||||
(departure (hash-ref info 'network)
|
||||
(hash-ref info 'direction)
|
||||
base-dep-dt
|
||||
dep-dt))))
|
||||
|
||||
(def (compute-table-widths departures)
|
||||
(def widths
|
||||
(for/collect ((dep departures))
|
||||
(with ((departure network direction _ _) dep)
|
||||
(list (string-length network) (string-length direction)))))
|
||||
(apply map max widths))
|
||||
|
||||
(def (display-departures-table departures style: (style 'unicode))
|
||||
(def good-emoji (if (eq? style 'markdown) ":white_check_mark: " ""))
|
||||
(def bad-emoji (if (eq? style 'markdown) ":warning: " "[yellow]"))
|
||||
(def widths (compute-table-widths departures))
|
||||
(def headers (if (eq? style 'markdown)
|
||||
'("Réseau" "Direction" "Heure")
|
||||
'("[bold]Réseau" "[bold]Direction" "[bold]Heure")))
|
||||
(def tab (table headers [(map max '(6 9) widths) ... (if (eq? style 'markdown) 32 13)] style))
|
||||
(display (table-header tab))
|
||||
(for ((dep departures))
|
||||
(with ((departure network direction base-dep-dt dep-dt) dep)
|
||||
(let* ((hour-str (if (equal? dep-dt base-dep-dt)
|
||||
(str good-emoji (date->string dep-dt "~H:~M"))
|
||||
(str bad-emoji (format "~a → ~a"
|
||||
(date->string base-dep-dt "~H:~M")
|
||||
(date->string dep-dt "~H:~M"))))))
|
||||
(display (table-row tab network direction hour-str)))))
|
||||
(display (table-footer tab)))
|
||||
|
||||
(def (display-disruptions disruptions style: (style 'unicode))
|
||||
(unless (null? disruptions)
|
||||
(displayln (if (eq? style 'markdown) "**Perturbations :**" (parse-markup "[bold]Perturbations :"))))
|
||||
(for ((dis disruptions))
|
||||
(let ((messages (hash-ref dis 'messages '())))
|
||||
(display (if (eq? style 'markdown) "* " "• "))
|
||||
(displayln (if (null? messages) "[Pas de message]" (hash-ref (car messages) 'text))))))
|
||||
|
||||
(def (post-to-mattermost url text channel: (channel #f))
|
||||
(def data (list->hash-table `((text . ,text))))
|
||||
(when channel
|
||||
(hash-put! data 'channel channel))
|
||||
(def mattermost-headers '(("Content-Type" . "application/json")))
|
||||
(def req (http-post url
|
||||
headers: mattermost-headers
|
||||
data: (json-object->string data)))
|
||||
(if (eq? 200 (request-status req))
|
||||
(display (format "Sent to Mattermost in ~a\n" (if channel channel "default channel")))
|
||||
(begin (display (format "Failed to send the message to Mattermost: ~a ~a\n"
|
||||
(request-status req) (request-status-text req)))
|
||||
(exit 1))))
|
||||
|
|
|
|||
55
sncf/api.ss
Normal file
55
sncf/api.ss
Normal file
|
|
@ -0,0 +1,55 @@
|
|||
(export get-station-id
|
||||
(struct-out departure)
|
||||
get-departures)
|
||||
|
||||
(import :std/format
|
||||
:std/iter
|
||||
:std/net/request
|
||||
:std/net/uri
|
||||
:std/srfi/19
|
||||
:std/text/json)
|
||||
|
||||
(def +sncf-url+ "https://api.sncf.com/v1/coverage/sncf")
|
||||
|
||||
(def (get-station-id sncf-key station)
|
||||
(def url (format "~a/pt_objects?q=~a&type\\[\\]=stop_area" +sncf-url+ (uri-encode station)))
|
||||
(def req (http-get url headers: `(("Authorization" . ,sncf-key))))
|
||||
(if (eq? 200 (request-status req))
|
||||
(let (req-json (request-json req))
|
||||
(let ((pts (hash-ref req-json 'pt_objects #f)))
|
||||
(if (and pts (not (null? pts)))
|
||||
(values (hash-ref (car pts) 'name) (hash-ref (car pts) 'id))
|
||||
(begin (display (format "No station found for \"~a\".\n" station) (current-error-port))
|
||||
(exit 1)))))
|
||||
(begin (display (format "Failed to query the SNCF API: ~a ~a\n"
|
||||
(request-status req) (request-status-text req)))
|
||||
(exit 1))))
|
||||
|
||||
(def (get-departures sncf-key station-id (datetime #f))
|
||||
(def url (format "~a/stop_areas/~a/departures" +sncf-url+ station-id))
|
||||
(def params (if datetime
|
||||
`(("from_datetime" . ,(date->string datetime "~Y~m~dT~H~M~S")))
|
||||
#f))
|
||||
(def req (http-get url headers: `(("Authorization" . ,sncf-key)) params: params))
|
||||
(if (eq? 200 (request-status req))
|
||||
(let (req-json (request-json req))
|
||||
(values (parse-departures (hash-ref req-json 'departures))
|
||||
(hash-ref req-json 'disruptions)))
|
||||
(begin (display (format "Failed to query the SNCF API: ~a ~a\n"
|
||||
(request-status req) (request-status-text req)))
|
||||
(exit 1))))
|
||||
|
||||
(defstruct departure (network direction base-datetime datetime))
|
||||
|
||||
(def (parse-departures departures-json)
|
||||
(for/collect ((dep departures-json))
|
||||
(let* ((info (hash-ref dep (string->symbol "display_informations")))
|
||||
(stop-dt (hash-ref dep (string->symbol "stop_date_time")))
|
||||
(base-dep-dt-str (hash-ref stop-dt (string->symbol "base_departure_date_time")))
|
||||
(base-dep-dt (string->date base-dep-dt-str "~Y~m~dT~H~M~S"))
|
||||
(dep-dt-str (hash-ref stop-dt (string->symbol "departure_date_time")))
|
||||
(dep-dt (string->date dep-dt-str "~Y~m~dT~H~M~S")))
|
||||
(departure (hash-ref info 'network)
|
||||
(hash-ref info 'direction)
|
||||
base-dep-dt
|
||||
dep-dt))))
|
||||
44
sncf/display.ss
Normal file
44
sncf/display.ss
Normal file
|
|
@ -0,0 +1,44 @@
|
|||
(export display-departures-table
|
||||
display-disruptions)
|
||||
|
||||
(import :std/format
|
||||
:std/iter
|
||||
:std/misc/string
|
||||
:std/srfi/19
|
||||
:dlozeve/fancy/format
|
||||
:dlozeve/fancy/table
|
||||
:dlozeve/sncf/api)
|
||||
|
||||
(def (compute-table-widths departures)
|
||||
(def widths
|
||||
(for/collect ((dep departures))
|
||||
(with ((departure network direction _ _) dep)
|
||||
(list (string-length network) (string-length direction)))))
|
||||
(apply map max widths))
|
||||
|
||||
(def (display-departures-table departures style: (style 'unicode))
|
||||
(def good-emoji (if (eq? style 'markdown) ":white_check_mark: " ""))
|
||||
(def bad-emoji (if (eq? style 'markdown) ":warning: " "[yellow]"))
|
||||
(def widths (compute-table-widths departures))
|
||||
(def headers (if (eq? style 'markdown)
|
||||
'("Réseau" "Direction" "Heure")
|
||||
'("[bold]Réseau" "[bold]Direction" "[bold]Heure")))
|
||||
(def tab (table headers [(map max '(6 9) widths) ... (if (eq? style 'markdown) 32 13)] style))
|
||||
(display (table-header tab))
|
||||
(for ((dep departures))
|
||||
(with ((departure network direction base-dep-dt dep-dt) dep)
|
||||
(let* ((hour-str (if (equal? dep-dt base-dep-dt)
|
||||
(str good-emoji (date->string dep-dt "~H:~M"))
|
||||
(str bad-emoji (format "~a → ~a"
|
||||
(date->string base-dep-dt "~H:~M")
|
||||
(date->string dep-dt "~H:~M"))))))
|
||||
(display (table-row tab network direction hour-str)))))
|
||||
(display (table-footer tab)))
|
||||
|
||||
(def (display-disruptions disruptions style: (style 'unicode))
|
||||
(unless (null? disruptions)
|
||||
(displayln (if (eq? style 'markdown) "**Perturbations :**" (parse-markup "[bold]Perturbations :"))))
|
||||
(for ((dis disruptions))
|
||||
(let ((messages (hash-ref dis 'messages '())))
|
||||
(display (if (eq? style 'markdown) "* " "• "))
|
||||
(displayln (if (null? messages) "[Pas de message]" (hash-ref (car messages) 'text))))))
|
||||
19
sncf/mattermost.ss
Normal file
19
sncf/mattermost.ss
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
(export post-to-mattermost)
|
||||
|
||||
(import :std/format
|
||||
:std/net/request
|
||||
:std/text/json)
|
||||
|
||||
(def (post-to-mattermost url text channel: (channel #f))
|
||||
(def data (list->hash-table `((text . ,text))))
|
||||
(when channel
|
||||
(hash-put! data 'channel channel))
|
||||
(def mattermost-headers '(("Content-Type" . "application/json")))
|
||||
(def req (http-post url
|
||||
headers: mattermost-headers
|
||||
data: (json-object->string data)))
|
||||
(if (eq? 200 (request-status req))
|
||||
(display (format "Sent to Mattermost in ~a\n" (if channel channel "default channel")))
|
||||
(begin (display (format "Failed to send the message to Mattermost: ~a ~a\n"
|
||||
(request-status req) (request-status-text req)))
|
||||
(exit 1))))
|
||||
Loading…
Add table
Add a link
Reference in a new issue