From 842468cf533add63afa686b131090cb20669dba4 Mon Sep 17 00:00:00 2001
From: Dimitri Lozeve <dimitri@lozeve.com>
Date: Mon, 19 Sep 2022 19:40:09 +0200
Subject: [PATCH] Add HTTP server app

---
 .gitignore       |  2 ++
 Dockerfile       |  7 +++--
 Dockerfile-build |  7 +++++
 build.sh         |  2 +-
 build.ss         | 11 ++++++++
 fly.toml         | 38 ++++++++++++++++++++++++++
 server.ss        | 69 ++++++++++++++++++++++++++++++++++++++++++++++++
 7 files changed, 133 insertions(+), 3 deletions(-)
 create mode 100644 Dockerfile-build
 create mode 100644 fly.toml
 create mode 100755 server.ss

diff --git a/.gitignore b/.gitignore
index a78dc71..562a63a 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,3 +1,5 @@
 *\~
+TAGS
 build-deps*
 sncf-static
+server
diff --git a/Dockerfile b/Dockerfile
index 4809204..64107c7 100644
--- a/Dockerfile
+++ b/Dockerfile
@@ -3,5 +3,8 @@ FROM gerbil/alpine
 RUN gxpkg install github.com/dlozeve/fancy
 
 COPY . .
-RUN ./build.ss
-RUN gxc -exe -static -cc-options -static -ld-options -lz -o sncf-static sncf.ss
+RUN ./build.ss lib
+RUN ./build.ss server
+
+EXPOSE 8080
+CMD ["/src/server"]
diff --git a/Dockerfile-build b/Dockerfile-build
new file mode 100644
index 0000000..4809204
--- /dev/null
+++ b/Dockerfile-build
@@ -0,0 +1,7 @@
+FROM gerbil/alpine
+
+RUN gxpkg install github.com/dlozeve/fancy
+
+COPY . .
+RUN ./build.ss
+RUN gxc -exe -static -cc-options -static -ld-options -lz -o sncf-static sncf.ss
diff --git a/build.sh b/build.sh
index 838612b..41bb0e6 100755
--- a/build.sh
+++ b/build.sh
@@ -2,7 +2,7 @@
 
 set -eux
 
-docker build . -t dlozeve/sncf-bot
+docker build . -f Dockerfile-build -t dlozeve/sncf-bot
 CONTAINER_ID=$(docker run -d dlozeve/sncf-bot)
 docker cp "$CONTAINER_ID":/src/sncf-static sncf-static
 docker rm -f "$CONTAINER_ID"
diff --git a/build.ss b/build.ss
index 44d322f..4daf9e3 100755
--- a/build.ss
+++ b/build.ss
@@ -11,6 +11,9 @@
 (def bin-build-spec
   '((exe: "sncf")))
 
+(def server-build-spec
+  '((exe: "server")))
+
 (def srcdir
   (path-normalize (path-directory (this-source-file))))
 
@@ -29,6 +32,14 @@
            static: #t
 	   build-deps: "build-deps-bin"
            bin-build-spec))
+    (["server"]
+     (make srcdir: srcdir
+	   bindir: srcdir
+           optimize: #t
+           debug: #f
+           static: #t
+	   build-deps: "build-deps-server"
+           server-build-spec))
     ([]
      (main "lib")
      (main "bin"))))
diff --git a/fly.toml b/fly.toml
new file mode 100644
index 0000000..8eebee6
--- /dev/null
+++ b/fly.toml
@@ -0,0 +1,38 @@
+# fly.toml file generated for sncf-bot on 2022-09-19T19:20:26+02:00
+
+app = "sncf-bot"
+kill_signal = "SIGINT"
+kill_timeout = 5
+processes = []
+
+[env]
+
+[experimental]
+  allowed_public_ports = []
+  auto_rollback = true
+
+[[services]]
+  http_checks = []
+  internal_port = 8080
+  processes = ["app"]
+  protocol = "tcp"
+  script_checks = []
+  [services.concurrency]
+    hard_limit = 25
+    soft_limit = 20
+    type = "connections"
+
+  [[services.ports]]
+    force_https = true
+    handlers = ["http"]
+    port = 80
+
+  [[services.ports]]
+    handlers = ["tls", "http"]
+    port = 443
+
+  [[services.tcp_checks]]
+    grace_period = "1s"
+    interval = "15s"
+    restart_limit = 0
+    timeout = "2s"
diff --git a/server.ss b/server.ss
new file mode 100755
index 0000000..2c57053
--- /dev/null
+++ b/server.ss
@@ -0,0 +1,69 @@
+#!/usr/bin/env gxi
+
+(export main)
+
+(import :std/getopt
+	:std/iter
+	:std/net/httpd
+	:std/srfi/19
+	:std/sugar
+	:gerbil/gambit/threads
+	:dlozeve/sncf/api
+	:dlozeve/sncf/display)
+
+(def (main . args)
+  (def gopt
+    (getopt (option 'address "-a" "--address"
+                    help: "server address"
+                    default: ":8080")))
+
+  (try
+   (let (opt (getopt-parse gopt args))
+     (run (hash-get opt 'address)))
+   (catch (getopt-error? exn)
+     (getopt-display-help exn "server" (current-error-port))
+     (exit 1))))
+
+(def (run 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 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))
+  (def style (if (assoc "markdown" params) 'markdown 'unicode))
+  (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))
+  (http-response-write res 200 '(("Content-Type" . "text/plain"))
+		       (with-output-to-string
+			 (lambda () (display-all departures disruptions station-name datetime
+					    style: style)))))
+
+(def (parse-request-params params)
+  (if params
+    (for/collect ((param (string-split params #\&)))
+      (match (string-split param #\=)
+	([k] (cons k #t))
+	([k v] (cons k v))
+	([k . rest] (cons k rest))))
+    '()))
+
+;; default
+(def (default-handler req res)
+  (http-response-write res 404 '(("Content-Type" . "text/plain"))
+		       "these aren't the droids you are looking for.\n"))