Group functions in submodules

.gitignore

@@ -1,3 +1,2 @@
 *\~
-sncf
 build-deps*

build.ss

@@ -2,22 +2,33 @@
 
 (import :std/make)
 
-;; the build specification
+(def lib-build-spec
-(def 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
+     (main "lib")
-           ;;bindir: srcdir          ; where to place executables; default is GERBIL_PATH/bin
+     (main "bin"))))
-           optimize: #t            ; enable optimizations
-           debug: #f               ; enable debugger introspection
-           static: #t              ; don't generate static compilation artifacts
-           build-spec))))          ; the actual build specification

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)
+	:dlozeve/sncf/api
-
+	:dlozeve/sncf/display
-(def +sncf-url+ "https://api.sncf.com/v1/coverage/sncf")
+	: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))))

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))))

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))))))

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))))