diff --git a/.gitignore b/.gitignore index 50c25c5..5318efb 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,2 @@ *\~ -sncf build-deps* diff --git a/build.ss b/build.ss index db81327..44d322f 100755 --- a/build.ss +++ b/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")))) diff --git a/sncf.ss b/sncf.ss index 61d692c..8ac85f1 100755 --- a/sncf.ss +++ b/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)))) diff --git a/sncf/api.ss b/sncf/api.ss new file mode 100644 index 0000000..29c5b5c --- /dev/null +++ b/sncf/api.ss @@ -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)))) diff --git a/sncf/display.ss b/sncf/display.ss new file mode 100644 index 0000000..c0eb1bd --- /dev/null +++ b/sncf/display.ss @@ -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)))))) diff --git a/sncf/mattermost.ss b/sncf/mattermost.ss new file mode 100644 index 0000000..2a26832 --- /dev/null +++ b/sncf/mattermost.ss @@ -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))))