aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--lib/API.hs9
-rw-r--r--lib/Server.hs27
-rwxr-xr-xtools/obu-config59
-rwxr-xr-xtools/obu-guess-trip75
-rwxr-xr-xtools/obu-ping126
-rw-r--r--tools/obu-state.edn1
-rw-r--r--tools/other.edn1
-rw-r--r--tools/test.edn1
8 files changed, 289 insertions, 10 deletions
diff --git a/lib/API.hs b/lib/API.hs
index 79a467a..5bf9877 100644
--- a/lib/API.hs
+++ b/lib/API.hs
@@ -14,7 +14,8 @@ import Data.Swagger (MimeList (MimeList),
PathItem (_pathItemGet),
Scheme (Wss), Swagger,
ToSchema (..), _swaggerPaths,
- genericDeclareNamedSchema)
+ genericDeclareNamedSchema, type_,
+ NamedSchema(..), SwaggerType (SwaggerObject))
import Data.Swagger.ParamSchema (ToParamSchema (..))
import Data.Text (Text)
import Data.Time (Day, UTCTime)
@@ -31,7 +32,7 @@ import Servant.Swagger (HasSwagger (..))
import Web.Internal.FormUrlEncoded (Form)
import Control.Lens (At (at), (&), (?~))
-import Data.Aeson (FromJSON (..), genericParseJSON)
+import Data.Aeson (FromJSON (..), genericParseJSON, Value)
import Data.ByteString.Lazy (ByteString)
import Data.HashMap.Strict.InsOrd (singleton)
import GHC.Generics (Generic)
@@ -50,10 +51,14 @@ instance FromJSON RegisterJson where
parseJSON = genericParseJSON (aesonOptions "register")
instance ToSchema RegisterJson where
declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "register")
+instance ToSchema Value where
+ declareNamedSchema _ = pure $ NamedSchema (Just "json") $ mempty
+ & type_ ?~ SwaggerObject
-- | The server's API (as it is actually intended).
type API = "stations" :> Get '[JSON] (Map StationID Station)
:<|> "timetable" :> Capture "Station ID" StationID :> QueryParam "day" Day :> Get '[JSON] (Map TripID (Trip Deep Deep))
+ :<|> "timetable" :> "stops" :> Capture "Date" Day :> Get '[JSON] Value
:<|> "trip" :> Capture "Trip ID" TripID :> Get '[JSON] (Trip Deep Deep)
-- ingress API (put this behind BasicAuth?)
-- TODO: perhaps require a first ping for registration?
diff --git a/lib/Server.hs b/lib/Server.hs
index 8d81127..7fdfd71 100644
--- a/lib/Server.hs
+++ b/lib/Server.hs
@@ -7,6 +7,7 @@
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE DataKinds #-}
-- Implementation of the API. This module is the main point of the program.
@@ -23,6 +24,7 @@ import Control.Monad.Logger (LoggingT, logWarnN)
import Control.Monad.Reader (forM)
import Control.Monad.Trans (lift)
import qualified Data.Aeson as A
+import Data.Aeson ((.=))
import qualified Data.ByteString.Char8 as C8
import Data.Coerce (coerce)
import Data.Functor ((<&>))
@@ -85,7 +87,7 @@ doMigration pool = runSql pool $
server :: GTFS -> Metrics -> TVar (M.Map TripID [TQueue (Maybe TrainPing)]) -> Pool SqlBackend -> ServerConfig -> Service CompleteAPI
server gtfs@GTFS{..} Metrics{..} subscribers dbpool settings = handleDebugAPI
- :<|> (handleStations :<|> handleTimetable :<|> handleTrip
+ :<|> (handleStations :<|> handleTimetable :<|> handleTimetableStops :<|> handleTrip
:<|> handleRegister :<|> handleTrainPing (throwError err401) :<|> handleWS
:<|> handleSubscribe :<|> handleDebugState :<|> handleDebugTrain
:<|> handleDebugRegister :<|> gtfsRealtimeServer gtfs dbpool)
@@ -93,13 +95,22 @@ server gtfs@GTFS{..} Metrics{..} subscribers dbpool settings = handleDebugAPI
:<|> serveDirectoryFileServer (serverConfigAssets settings)
:<|> pure (unsafePerformIO (toWaiAppPlain (ControlRoom gtfs dbpool settings)))
where handleStations = pure stations
- handleTimetable station maybeDay = do
- -- TODO: resolve "overlay" trips (perhaps just additional CalendarDates?)
- day <- liftIO $ maybeM (getCurrentTime <&> utctDay) pure (pure maybeDay)
- pure
- -- don't send stations ending at this station
- . M.filter ((==) station . stationId . stopStation . V.last . tripStops)
- $ tripsOnDay gtfs day
+ handleTimetable station maybeDay =
+ M.filter isLastStop . tripsOnDay gtfs <$> liftIO day
+ where isLastStop = (==) station . stationId . stopStation . V.last . tripStops
+ day = maybeM (getCurrentTime <&> utctDay) pure (pure maybeDay)
+ handleTimetableStops day =
+ pure . A.toJSON . fmap mkJson . M.elems $ tripsOnDay gtfs day
+ where mkJson :: Trip Deep Deep -> A.Value
+ mkJson Trip {..} = A.object
+ [ "trip" .= tripTripID
+ , "stops" .= fmap (\Stop{..} -> A.object
+ [ "departure" .= stopDeparture
+ , "station" .= stationId stopStation
+ , "lat" .= stationLat stopStation
+ , "lon" .= stationLon stopStation
+ ]) tripStops
+ ]
handleTrip trip = case M.lookup trip trips of
Just res -> pure res
Nothing -> throwError err404
diff --git a/tools/obu-config b/tools/obu-config
new file mode 100755
index 0000000..0cce2ee
--- /dev/null
+++ b/tools/obu-config
@@ -0,0 +1,59 @@
+#!/usr/bin/env gosh
+
+(use text.edn)
+(use file.util)
+(use scheme.mapping.hash)
+(use gauche.parseopt)
+
+(define (show-help progname)
+ (display (format
+"~a: tracktrain's onboard config-and-state manager.
+
+Usage: ~a [options] key [value]
+
+This is a very simple key-value store. Give both to set,
+give just the key to look something up
+
+Options:
+ -s --statefile: state file
+ -h --help: display this help
+" progname))
+ (exit 0))
+
+(define (main args)
+ (let-args
+ (cdr args)
+ ((statefile "s|state=s")
+ (help "h|help" => (cut show-help (car args)))
+ . restargs)
+
+ (define file
+ (if (equal? statefile #f)
+ "./obu-state.edn"
+ statefile))
+
+ (if (= (length restargs) 2)
+ (set file
+ (list-ref restargs 0)
+ (list-ref restargs 1))
+ (display
+ (get file
+ (list-ref restargs 0))))
+ (exit 0)))
+
+(define (set file key value)
+ (define data
+ (if (file-exists? file)
+ (call-with-input-file file parse-edn)
+ (edn-map)))
+ (define data2
+ (hashmap-set data (string->symbol key) value))
+ (call-with-output-file file
+ (cut construct-edn data2 <>)))
+
+(define (get file key)
+ (if (file-exists? file)
+ (hashmap-ref
+ (call-with-input-file file parse-edn)
+ (string->symbol key))
+ #f))
diff --git a/tools/obu-guess-trip b/tools/obu-guess-trip
new file mode 100755
index 0000000..478ba2b
--- /dev/null
+++ b/tools/obu-guess-trip
@@ -0,0 +1,75 @@
+#!/usr/bin/env gosh
+
+(use rfc.http)
+(use rfc.uri)
+(use rfc.json)
+(use file.util)
+(use srfi-19)
+(use gauche.collection)
+(use gauche.parseopt)
+(use gauche.process)
+
+
+(define (main args)
+ (let-args
+ (cdr args)
+ ((adir "d|dir=s")
+ (baseurl "u|url=s")
+ (statefile "s|statefile=s")
+ (help "h|help" => (cut show-help (car args)))
+ . restargs)
+ (if (equal? baseurl #f)
+ (show-help (car args))
+ (guesstimate
+ (if (equal? adir #f) "." adir)
+ baseurl
+ (if statefile statefile "./obu-state.edn")))
+ (exit 0)))
+
+
+(define (show-help progname)
+ (display (format
+"~a: tracktrain's on-board guesstimater for which trip you're on
+
+Arguments:
+ -u --url: base url of the tracktrain server [required]
+ -s --statefile: state file
+ -c --config: config file (default is /etc/tracktrain/obu.conf)
+ -h --help: display this help
+" progname))
+ (exit 0))
+
+(define (guesstimate dir url statefile)
+ (define stops (fetch-stations url))
+ (define pos
+ (with-input-from-process `(obu-ping -s ,statefile -n 1 -d) read))
+ (define trip (assoc-ref (closest-stop-to stops pos) 'trip))
+ (display trip))
+
+(define (closest-stop-to stops pos)
+ (define stops-by-station
+ (apply vector-append (vector->list
+ (vector-map (lambda (trip)
+ (vector-map
+ (lambda (stop) (cons `(trip . ,(assoc-ref trip 'trip)) stop))
+ (assoc-ref trip 'stops)))
+ stops))))
+ (find-min
+ stops-by-station
+ :key (lambda (stop)
+ (+ (square (- (assoc-ref pos 'lat) (assoc-ref stop 'lat)))
+ (square (- (assoc-ref pos 'lon) (assoc-ref stop 'lon)))))
+ :default (vector-ref stops 0)))
+
+(define (fetch-stations url)
+ (define day (date->string (current-date) "~1"))
+ (define tls
+ (equal? (uri-ref url 'scheme) 'https))
+ (parameterize
+ ; replace all json keys with symbols; everything else is confusing
+ ([json-object-handler
+ (cut map (lambda p `(,(string->symbol (car (car p))) . ,(cdr (car p)))) <>)])
+ (parse-json-string
+ (values-ref (http-get (uri-ref url 'host+port)
+ (format "/api/timetable/stops/~a" day)
+ :secure tls) 2))))
diff --git a/tools/obu-ping b/tools/obu-ping
new file mode 100755
index 0000000..ee75402
--- /dev/null
+++ b/tools/obu-ping
@@ -0,0 +1,126 @@
+#!/usr/bin/env gosh
+
+(use rfc.json)
+(use rfc.uri)
+(use rfc.http)
+(use srfi-19)
+(use file.util)
+(use util.match)
+(use gauche.parseopt)
+(use gauche.process)
+(use text.edn)
+(use scheme.mapping.hash)
+
+(define (show-help progname)
+ (display (format
+"~a: tracktrain's on-board reporting thing. Excepts input to be
+piped from gpsd's `gpspipe --json` onto stdin.
+
+Arguments:
+ -u --url: base url of the tracktrain server [required]
+ -n: number of positions to fetch (default is to loop forever)
+ -d --no-ping: just print the positions, don't send anything
+ -s --statefile: state file
+ -c --config: config file (default is /etc/tracktrain/obu.conf)
+ -h --help: display this help
+" progname))
+ (exit 0))
+
+(define (main args)
+ (let-args
+ (cdr args)
+ ((statefile "s|state=s")
+ (baseurl "u|url=s")
+ (n "n=i")
+ (no-ping "d|no-ping")
+ (help "h|help" => (cut show-help (car args)))
+ . restargs)
+ (if (and (equal? baseurl #f) (equal? no-ping #f))
+ (show-help (car args))
+ (with-input-from-process
+ '(gpspipe --json)
+ (cut report-position
+ (if (equal? statefile #f) "./obu-state.edn" statefile)
+ baseurl
+ n
+ no-ping)
+ :on-abnormal-exit :ignore))
+ (exit 0)))
+
+
+(define (try-get-current-pos)
+ (define json
+ (parameterize
+ ; replace all json keys with symbols; everything else is confusing
+ ([json-object-handler
+ (cut map (lambda p `(,(string->symbol (car (car p))) . ,(cdr (car p)))) <>)])
+ (parse-json)))
+ (define class
+ (assoc-ref json 'class))
+ (match class
+ ("TPV" `((lat . ,(assoc-ref json 'lat))
+ (lon . ,(assoc-ref json 'lon))
+ (time . ,(assoc-ref json 'time))))
+ (_ (try-get-current-pos))))
+
+(define json-symbol-key
+ (cut map (lambda p `(,(string->symbol (car (car p))) . ,(cdr (car p)))) <>))
+
+(define (report-position statefile url n no-ping)
+ (define trip
+ (if no-ping #f
+ (process-output->string `(obu-guess-trip -u ,url))))
+ (define token
+ (if no-ping #f (get-token url trip statefile)))
+ (if n
+ (dotimes (i n)
+ (ping-pos statefile url token))
+ (while #t
+ (ping-pos statefile url token))))
+
+(define (ping-pos dir url token)
+ (let ([pos (try-get-current-pos)])
+ (display (format "~a\n" pos))
+ (if (not (equal? token #f))
+ (display (format "server: ~a\n" (ping url token pos))))))
+
+(define (get-token url trip statefile)
+ (define cached?
+ (with-input-from-process `(obu-config -s ,statefile token) read))
+ (if cached?
+ (symbol->string cached?)
+ (let* ([token (fetch-token url trip)])
+ (do-process `(obu-config -s ,statefile token ,token))
+ token)))
+
+(define (fetch-token url trip)
+ (define tls
+ (equal? (uri-ref url 'scheme) 'https))
+ (display (format "fetching new token for trip ~a…\n" trip))
+ (parameterize
+ ; replace all json keys with symbols; everything else is confusing
+ ([json-object-handler json-symbol-key])
+ (parse-json-string
+ (values-ref (http-post
+ (uri-ref url 'host+port)
+ (format "/api/train/register/~a" trip)
+ (construct-json-string '((agent . "onboard-unit")))
+ :content-type "application/json"
+ :secure tls)
+ 2))))
+
+(define (ping url token pos)
+ (define tls
+ (equal? (uri-ref url 'scheme) 'https))
+ (parameterize ([json-object-handler json-symbol-key])
+ (parse-json-string
+ (values-ref (http-post
+ (uri-ref url 'host+port)
+ "/api/train/ping"
+ (construct-json-string `((token . ,token)
+ (lat . ,(assoc-ref pos 'lat))
+ (long . ,(assoc-ref pos 'lon))
+ (timestamp . ,(assoc-ref pos 'time))))
+ :content-type "application/json"
+ :secure tls)
+ 2))))
diff --git a/tools/obu-state.edn b/tools/obu-state.edn
new file mode 100644
index 0000000..db989c8
--- /dev/null
+++ b/tools/obu-state.edn
@@ -0,0 +1 @@
+{token "5ab95c26-367e-40fc-8d3e-2956af6f61e4"} \ No newline at end of file
diff --git a/tools/other.edn b/tools/other.edn
new file mode 100644
index 0000000..b4b44d4
--- /dev/null
+++ b/tools/other.edn
@@ -0,0 +1 @@
+{a "b", c "b"} \ No newline at end of file
diff --git a/tools/test.edn b/tools/test.edn
new file mode 100644
index 0000000..aa0da75
--- /dev/null
+++ b/tools/test.edn
@@ -0,0 +1 @@
+{token "string"}