diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/API.hs | 9 | ||||
| -rw-r--r-- | lib/Server.hs | 27 | ||||
| -rwxr-xr-x | tools/obu-config | 59 | ||||
| -rwxr-xr-x | tools/obu-guess-trip | 75 | ||||
| -rwxr-xr-x | tools/obu-ping | 126 | ||||
| -rw-r--r-- | tools/obu-state.edn | 1 | ||||
| -rw-r--r-- | tools/other.edn | 1 | ||||
| -rw-r--r-- | tools/test.edn | 1 |
8 files changed, 289 insertions, 10 deletions
@@ -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"} |