diff options
49 files changed, 3629 insertions, 1349 deletions
@@ -0,0 +1 @@ +use nix @@ -1,3 +1,4 @@ dist-newstyle/* result gtfs.zip +config.yaml diff --git a/CHANGELOG.md b/CHANGELOG.md index 1df15d0..68dc1d2 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,16 @@ -# Revision history for haskell-gtfs +# Revision history for tracktrain -## 0.1.0.0 -- YYYY-mm-dd + +## 0.0.2.0 -- 2024-05-?? +* Hopefully first version usable in production? +* Restructure: database contents no longer depend on GTFS, so the GTFS can + be safely swapped out during operation +* Restructure: the backend server is no responsible for keeping track of which + trip on OBU is on, further minimising the required onboard-side logic +* Logs can now be sent as push notifications via ntfy-sh +* added Space-Time diagrams. These will not work correctly if stops are in different time zones + +## 0.0.1.0 -- ~ 2022-11-01 * First version. Released on an unsuspecting world. +* First version which could successfully send data to Google diff --git a/GLOSSARY.md b/GLOSSARY.md new file mode 100644 index 0000000..062f897 --- /dev/null +++ b/GLOSSARY.md @@ -0,0 +1,78 @@ +# Glossary + +This is meant to give a rough overview of (train-related) terms used in +this code; both for others as a reference and for me so I can remember +to use them in a (somewhat) consistent way, since they are somewhat +arbitrary. I've tried to remain at least broadly close to the +terminology used by GTFS. + +## Terms + +Ticket +: A single tracked trip. These are imported from the GTFS (or couple be created + manually via the web interface), and are independent from it, i.e. they are + saved in tracktrain's data base and won't change with subsequent GTFS updates, + but would have to be deleted and reimported instead. + + This prevents tracktrain from ending up with invalid data if a trip's id + or stops change retroactively. + +Trip (don't confuse with Train) +: Used as in GTFS: a trip is a defined sequence of *stops*, referred to by + a number (called its trip ID, e.g. IC 94). Usually runs on multiple + days. Always has an associated *shape*. + + (might match your intuition for "train line") + +(Calendar-)Date / Day +: A single, unique day (e.g. 1970-01-01). Usually used to indicate if a + *trip* is running on that day or not. + +Seconds (on a given Day) +: Time on a given day, given in seconds (though often displayed as + minutes) since midnight. If a trip crosses midnight it is treated as if + it took place entirely on the previous day, and times simply count up + beyond the total number of seconds in a day (note that that's a + timezone-series dependent number). + +Stop +: A *station* with associated arrival/departure *time*. + +Station +: A train station. Tracktrain refers to each by an ID, and hopefully knows + its geolocation. + +Shape +: A sequence of geolocations describing a line between stations, + describing the physical railway along which trains travel. + +Vehicle +: An actual, physical vehicle, which might act as the *train* going along + a *trip* on a certain *date*. + + For now tracktrain doesn't really care about them (but if it's curious + it might yet learn about them!) + +Announcement +: The thing that GTFS calls "Service Alert" --- a text message giving + human-readable information about some *train*. + +(Train-)Ping +: A single packet of data sent from a train's *OBU*. Might arrive in some + arbitrary order. + +(Train-)Anchor +: An "anchored" point of position of a train along a trip; a snapshot of its + delay and state at a known position. These are generated from train pings, + and are the basis for extrapolating future delays for passanger information. + +Control Room +: The "admin interface" of tracktrain, which is not meant to be used by + on-board staff. + +On-Board Unit (OBU) +: A thing on a vehicle which does geolocation tracking and yells at + tracktrain about it. + + If we ever run into potential confusion regarding this term we're + probably way too professional to actually use tracktrain for anything. diff --git a/GLOSSARY.org b/GLOSSARY.org deleted file mode 100644 index 38cda75..0000000 --- a/GLOSSARY.org +++ /dev/null @@ -1,66 +0,0 @@ -#+TITLE: Glossary of Terms - -This is meant to give a rough overview of (train-related) terms used in this -code; both for others as a reference and for me so I can remember to use them -in a (somewhat) consistent way, since they are somewhat arbitrary. I've tried -to remain at least broadly close to the terminology used by GTFS. - -* Terms -** (Calendar-)Date / Day -A single, unique day (e.g. 1970-01-01). Usually used to indicate if a /trip/ -is running on that day or not. - -** Time (of Day) -Time on a given day, given in seconds (though often displayed as minutes) -since midnight. If a trip crosses midnight it is treated as if it took place -entirely on the previous day, and times simply count up beyond the total -number of seconds in a day (note that that's a timezone-series dependent -number). - -** Trip (don't confuse with Train) -Used as in GTFS: a trip is a defined sequence of /stops/, referred to by a -number (called its trip ID, e.g. IC 94). Usually runs on multiple days. -Always has an associated /shape/. - -(might match your intuition for "train line") - -** Stop -A /station/ with associated arrival/departure /time/. - -** Station -A train station. Tracktrain refers to each by an ID, and hopefully knows -its geolocation. - -** Shape -A sequence of geolocations describing a line between stations, describing -the physical railway along which trains travel. - -** Train (don't confuse with Trip) -A single instance of a /trip/ on a concrete /date/. Tracktrain mostly concerns -itself with keeping track of those; the rest is just additional stuff. - -** Vehicle -An actual, physical vehicle, which might act as the /train/ going along a -/trip/ on a certain /date/. - -For now tracktrain doesn't really care about them (but if it's curious it -might yet learn about them!) - -** Announcement -The thing that GTFS calls "Service Alert" — a text message giving -human-readable information about some /train/. - -** (Train-)Ping -A single packet of data sent from a train's /OBU/. Might arrive in some -arbitrary order. - -** Control Room -The "admin interface" of tracktrain, which is not meant to be used by on-board -staff. - -** On-Board Unit (OBU) -A thing on a vehicle which does geolocation tracking and yells at tracktrain -about it. - -If we ever run into potential confusion regarding this term we're probably -way too professional to actually use tracktrain for anything. diff --git a/app/GenJS.hs b/app/GenJS.hs index a580d23..1e7ba3a 100644 --- a/app/GenJS.hs +++ b/app/GenJS.hs @@ -4,12 +4,12 @@ -- bother with it module Main where -import Universum -import Servant.JS -import Servant.JS.Vanilla -import System.Environment (getArgs) +import Servant.JS +import Servant.JS.Vanilla +import System.Environment (getArgs) +import Universum -import API +import API apiJS :: Text -> Text apiJS url = jsForAPI (Proxy @API) (vanillaJSWith options) @@ -19,6 +19,6 @@ main :: IO () main = do args <- getArgs case args of - [] -> putText (apiJS "") + [] -> putText (apiJS "") [prefix] -> putText (apiJS (toText prefix)) - _ -> error "don't understand these options" + _ -> error "don't understand these options" diff --git a/app/Main.hs b/app/Main.hs index a61140a..3856a67 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,15 +1,15 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} -- | The main module. Does little more than handle some basic ocnfic, then -- call the server module Main where -import Conferer (fetch) -import Conferer.Config (addSource, emptyConfig) -import qualified Conferer.Source.Aeson as ConfAeson -import qualified Conferer.Source.CLIArgs as ConfCLI -import qualified Conferer.Source.Env as ConfEnv -import qualified Conferer.Source.Yaml as ConfYaml +import Conftrack +import Conftrack.Pretty +import Conftrack.Source.Env (mkEnvSource) +import Conftrack.Source.Yaml (mkYamlFileSource) import Control.Monad.Extra (ifM) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Logger (runStderrLoggingT) @@ -20,6 +20,7 @@ import Network.Wai.Middleware.RequestLogger (OutputFormat (..), RequestLoggerSettings (..), mkRequestLogger) import System.Directory (doesFileExist) +import System.OsPath (osp) import Config (ServerConfig (..)) import GTFS (loadGtfs) @@ -27,19 +28,15 @@ import Server (application) main :: IO () main = do - confconfig <- pure emptyConfig - >>= addSource ConfCLI.fromConfig - >>= addSource (ConfEnv.fromConfig "tracktrain") - -- for some reason the yaml source fails if the file does not exist, but json works fine - >>= (\c -> ifM (doesFileExist "./config.yaml") - (addSource (ConfYaml.fromFilePath "./config.yaml") c) - (pure c)) - >>= (\c -> ifM (doesFileExist "./config.yml") - (addSource (ConfYaml.fromFilePath "./config.yml") c) - (pure c)) - >>= addSource (ConfAeson.fromFilePath "./config.json") - settings@ServerConfig{..} <- fetch confconfig + Right ymlsource <- mkYamlFileSource [osp|./config.yaml|] + + Right (settings@ServerConfig{..}, origins, warnings) <- + runFetchConfig [mkEnvSource "tracktrain", ymlsource] + + putStrLn "reading configs .." + printConfigOrigins origins + printConfigWarnings warnings gtfs <- loadGtfs serverConfigGtfs serverConfigZoneinfoPath loggerMiddleware <- mkRequestLogger diff --git a/assets/style.css b/assets/style.css index 6a3552f..315675d 100644 --- a/assets/style.css +++ b/assets/style.css @@ -5,7 +5,6 @@ section { border: 0.1rem solid black; padding: 1rem; margin: 2vw; - margin-top: 0; padding-top: 0; } body { diff --git a/config.yaml b/config.yaml deleted file mode 100644 index 123031d..0000000 --- a/config.yaml +++ /dev/null @@ -1,17 +0,0 @@ - - -dbstring: "dbname=tracktrain" -gtfs: "./gtfs.zip" -zoneinfoPath: "/etc/zoneinfo/" - -# generic warp server options (see warp docs) -warp: - port: 9000 - -# only oauth2 with uffd supported (for now) -login: - enable: true - clientname: tracktrain - clientsecret: secret - url: http://localhost:8080 - diff --git a/config.yaml.sample b/config.yaml.sample new file mode 100644 index 0000000..41072b0 --- /dev/null +++ b/config.yaml.sample @@ -0,0 +1,25 @@ + + +dbstring: "dbname=tracktrain" +gtfs: "gtfs.zip" +zoneinfopath: "/etc/zoneinfo/" + +assets: ./assets + +# generic warp server options (see warp docs) +warp: + port: 5000 + +# only oauth2 with uffd supported (for now) +login: + enable: false + clientname: tracktrain + clientsecret: secret + url: http://localhost:8080 + +logging: + # logs can be sent as push notifications + ntfytoken: tk_something_or_other + ntfytopic: ntfy.example.org/tracktrain + # a free-form label used as title for messages + name: debug-deployment diff --git a/default.nix b/default.nix index d6ce56c..90d8e1c 100644 --- a/default.nix +++ b/default.nix @@ -4,10 +4,38 @@ let inherit (nixpkgs) pkgs; + conftrack = + { mkDerivation, aeson, base, bytestring, containers, directory + , file-io, filepath, lib, mtl, QuickCheck, quickcheck-instances + , scientific, template-haskell, text, transformers, yaml + }: + mkDerivation { + pname = "conftrack"; + version = "0.0.1"; + # sha256 = "51bdd96aff8537b4871498d67b936df8ab360b886aabec21a1dcb187a73aa2ec"; + src = nixpkgs.fetchgit { + url = "https://stuebinm.eu/git/conftrack"; + rev = "7349f170a1e33c449f73d05f206872ebc1f334de"; + hash = "sha256-v1hs7bNLubVwNfNeJBiuR820urXiA2iwZMsxbpwHJ/M="; + }; + revision = "1"; + editedCabalFile = "0wx03gla2x51llwng995snp9lyg1msnyf0337hd1ph9874zcadxr"; + libraryHaskellDepends = [ + aeson base bytestring containers directory file-io filepath mtl + scientific template-haskell text transformers yaml + ]; + patches = [ ./tracktrain-conftrack-deps.patch ]; + jailbreak = true; + testHaskellDepends = [ + aeson base containers QuickCheck quickcheck-instances text + ]; + description = "Tracable multi-source config management"; + license = lib.licenses.bsd3; + }; + f = { mkDerivation, aeson, base, blaze-html, blaze-markup - , bytestring, cassava, conduit, conferer, conferer-aeson - , conferer-warp, conferer-yaml, containers, data-default-class - , directory, either, exceptions, extra, fmt, hoauth2, http-api-data + , bytestring, cassava, conduit, conftrack, containers, data-default-class + , directory, either, esqueleto, exceptions, extra, filepath, fmt, hoauth2, http-api-data , http-media, insert-ordered-containers, lens, lib, monad-logger , mtl, path-pieces, persistent, persistent-postgresql , prometheus-client, prometheus-metrics-ghc, proto-lens @@ -27,7 +55,7 @@ let isExecutable = true; libraryHaskellDepends = [ aeson base blaze-html blaze-markup bytestring cassava conduit - conferer conferer-warp containers either exceptions extra fmt + conftrack containers either esqueleto exceptions extra fmt filepath hoauth2 http-api-data http-media insert-ordered-containers lens monad-logger mtl path-pieces persistent persistent-postgresql prometheus-client prometheus-metrics-ghc proto-lens @@ -39,7 +67,7 @@ let zip-archive ]; executableHaskellDepends = [ - aeson base bytestring conferer conferer-aeson conferer-yaml + aeson base bytestring conftrack data-default-class directory extra fmt monad-logger persistent-postgresql proto-lens time wai-extra warp ]; @@ -63,6 +91,8 @@ let # (currently kept as a dummy) hpkgs = haskellPackages.override { overrides = self: super: with pkgs.haskell.lib.compose; { + conftrack = self.callPackage conftrack {}; + # filepath = self.filepath_1_4_100_4; # conferer-warp = markUnbroken super.conferer-warp; }; }; diff --git a/hie.yaml b/hie.yaml deleted file mode 100644 index 4bc07c5..0000000 --- a/hie.yaml +++ /dev/null @@ -1,10 +0,0 @@ -cradle: - cabal: - - path: "app/Main.hs" - component: "tracktrain:exe:tracktrain" - - - path: "lib" - component: "lib:tracktrain" - - - path: "gtfs" - component: "tracktrain:lib:gtfs" @@ -1,14 +1,11 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE UndecidableInstances #-} -- | The sole authorative definition of this server's API, given as a Servant-style -- Haskell type. All other descriptions of the API are generated from this one. -module API (API, CompleteAPI, GtfsRealtimeAPI, RegisterJson(..), Metrics(..)) where +module API (API, CompleteAPI, GtfsRealtimeAPI, RegisterJson(..), Metrics(..), SentPing(..)) where import Data.Map (Map) import Data.Proxy (Proxy (..)) @@ -31,10 +28,9 @@ import Servant (Application, FormUrlEncoded, import Servant.API (Accept, Capture, Get, JSON, MimeRender, MimeUnrender, NoContent, OctetStream, PlainText, - Post, QueryParam, Raw, ReqBody, - type (:<|>) (..)) + Post, QueryFlag, QueryParam, Raw, + ReqBody, type (:<|>) (..)) import Servant.API.WebSocket (WebSocket) --- import Servant.GTFS.Realtime (Proto) import Servant.Swagger (HasSwagger (..)) import Web.Internal.FormUrlEncoded (Form) @@ -44,58 +40,55 @@ import Data.Aeson (FromJSON (..), Value, import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as LB import Data.HashMap.Strict.InsOrd (singleton) -import Data.ProtoLens (Message, encodeMessage) +import Data.ProtoLens (Message (messageName), + encodeMessage) import GHC.Generics (Generic) -import GTFS +import GTFS (Depth (Deep), GTFSFile (..), + StationID, Trip, TripId, + aesonOptions, swaggerOptions) import Network.HTTP.Media ((//)) +import qualified OwnTracks as OT import Persist import Prometheus import Proto.GtfsRealtime (FeedMessage) import Servant.API.ContentTypes (Accept (..)) -newtype RegisterJson = RegisterJson - { registerAgent :: Text } - deriving (Show, Generic) +-- | a bare ping as sent by a tracker device +data SentPing = SentPing + { sentPingTrackerId :: TrackerId + , sentPingGeopos :: Geopos + , sentPingTimestamp :: UTCTime + } deriving (Generic) -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 +instance FromJSON SentPing where + parseJSON = genericParseJSON (aesonOptions "sentPing") --- | 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) +-- | tracktrain's API +type API = -- ingress API (put this behind BasicAuth?) -- TODO: perhaps require a first ping for registration? - :<|> "train" :> "register" :> Capture "Trip ID" TripID :> ReqBody '[JSON] RegisterJson :> Post '[JSON] Token - -- TODO: perhaps a websocket instead? - :<|> "train" :> "ping" :> ReqBody '[JSON] TrainPing :> Post '[JSON] (Maybe TrainAnchor) - :<|> "train" :> "ping" :> "ws" :> WebSocket - :<|> "train" :> "subscribe" :> Capture "Trip ID" TripID :> Capture "Day" Day :> WebSocket - -- debug things - :<|> "debug" :> "pings" :> Get '[JSON] (Map Token [TrainPing]) - :<|> "debug" :> "pings" :> Capture "Trip ID" TripID :> Capture "day" Day :> Get '[JSON] [TrainPing] - :<|> "debug" :> "register" :> Capture "Trip ID" TripID :> Capture "day" Day :> Post '[JSON] Token + "tracker" :> "register" :> ReqBody '[JSON] RegisterJson :> Post '[JSON] TrackerId + :<|> "tracker" :> "ping" :> ReqBody '[JSON] SentPing :> Post '[JSON] (Maybe TrainAnchor) + :<|> "tracker" :> "ping" :> "ws" :> WebSocket + :<|> "ticker" :> "current" :> Get '[JSON] Value + :<|> "ticket" :> "subscribe" :> Capture "Ticket Id" UUID :> WebSocket + :<|> "debug" :> "pings" :> Get '[JSON] (Map UUID [Ping]) + :<|> "debug" :> "pings" :> Capture "Ticket Id" UUID :> Get '[JSON] [Ping] :<|> "gtfs.zip" :> Get '[OctetStream] GTFSFile :<|> "gtfs" :> GtfsRealtimeAPI + :<|> "owntracks" :> OwnTracksAPI + +type GtfsRealtimeAPI = "servicealerts" :> QueryFlag "force" :> Get '[Proto] FeedMessage + :<|> "tripupdates" :> QueryFlag "force" :> Get '[Proto] FeedMessage + :<|> "vehiclepositions" :> QueryFlag "force" :> Get '[Proto] FeedMessage --- | The API used for publishing gtfs realtime updates -type GtfsRealtimeAPI = "servicealerts" :> Get '[Proto] FeedMessage - :<|> "tripupdates" :> Get '[Proto] FeedMessage - :<|> "vehiclepositions" :> Get '[Proto] FeedMessage +type OwnTracksAPI = + "pub" :> QueryParam "u" Text :> QueryParam "d" Text :> QueryParam "version" Int :> ReqBody '[JSON] OT.Message :> Post '[JSON] [OT.Command] --- | The server's API with an additional debug route for accessing the specification --- itself. Split from API to prevent the API documenting the format in which it is --- documented, which would be silly and way to verbose. type CompleteAPI = - "api" :> "openapi" :> Get '[JSON] Swagger - :<|> "api" :> API + {- "api" :> "openapi" :> Get '[JSON] Swagger + :<|> -} "api" :> "v1" :> API :<|> "metrics" :> Get '[PlainText] Text :<|> "assets" :> Raw :<|> Raw -- hook for yesod frontend @@ -107,6 +100,20 @@ data Metrics = Metrics instance MimeRender OctetStream GTFSFile where mimeRender p (GTFSFile bytes) = mimeRender p bytes +newtype RegisterJson = RegisterJson + { registerAgent :: Text } + deriving (Show, Generic) + +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 +instance ToSchema SentPing where + declareNamedSchema = genericDeclareNamedSchema (GTFS.swaggerOptions "ping") + -- TODO write something useful here! (and if it's just "hey this is some websocket thingie") @@ -115,7 +122,7 @@ instance HasSwagger WebSocket where { _swaggerPaths = singleton "/" $ mempty { _pathItemGet = Just $ mempty { _operationSummary = Just "this is a websocket endpoint!" - , _operationDescription = Just "this is a websocket endpoint meant for continious operations, e.g. sending many trainPings one after the other. Unfortunately OpenAPI 2.0 is not suitable to thoroughly model it (hence this text)." + , _operationDescription = Just "this is a websocket endpoint meant for continious operations, e.g. sending many pings one after the other. Unfortunately OpenAPI 2.0 is not suitable to thoroughly model it (hence this text)." , _operationSchemes = Just [ Wss ] , _operationConsumes = Just $ MimeList [ "application/json" ] , _operationProduces = Just $ MimeList [ "application/json" ] @@ -132,7 +139,8 @@ instance Accept Proto where instance Message msg => MimeRender Proto msg where mimeRender _ = LB.fromStrict . encodeMessage --- TODO: this instance is horrible; ideally it should at least include --- the name of the message type (if at all possible) +-- | Not an ideal instance, hides fields of the protobuf message instance {-# OVERLAPPABLE #-} Message msg => ToSchema msg where - declareNamedSchema _ = declareNamedSchema (Proxy @String) + declareNamedSchema proxy = + pure (NamedSchema (Just (messageName proxy)) mempty) + diff --git a/lib/Config.hs b/lib/Config.hs index 363a068..c7fd4e4 100644 --- a/lib/Config.hs +++ b/lib/Config.hs @@ -1,15 +1,22 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE RecordWildCards #-} --- | +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} -module Config where -import Conferer (DefaultConfig (configDef)) -import Conferer.FromConfig -import Conferer.FromConfig.Warp () +module Config (UffdConfig(..), ServerConfig(..), LoggingConfig(..)) where +import Conftrack +import Conftrack.Value (ConfigValue (..)) import Data.ByteString (ByteString) +import Data.Function ((&)) +import Data.Functor ((<&>)) +import Data.String (IsString (..)) import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8) import GHC.Generics (Generic) -import Network.Wai.Handler.Warp (Settings) +import qualified Network.Wai.Handler.Warp as Warp +import System.OsPath (OsPath, encodeUtf, osp) import URI.ByteString data UffdConfig = UffdConfig @@ -20,35 +27,86 @@ data UffdConfig = UffdConfig } deriving (Generic, Show) data ServerConfig = ServerConfig - { serverConfigWarp :: Settings + { serverConfigWarp :: Warp.Settings , serverConfigDbString :: ByteString - , serverConfigGtfs :: FilePath - , serverConfigAssets :: FilePath - , serverConfigZoneinfoPath :: FilePath - , serverConfigLogin :: UffdConfig + , serverConfigGtfs :: OsPath + , serverConfigAssets :: OsPath + , serverConfigZoneinfoPath :: OsPath + , serverConfigDebugMode :: Bool + , serverConfigLogin :: Maybe UffdConfig + , serverConfigLogging :: LoggingConfig + , serverConfigBeSilent :: Bool } deriving (Generic) -instance FromConfig ServerConfig +data LoggingConfig = LoggingConfig + { loggingConfigNtfyToken :: Maybe Text + , loggingConfigNtfyTopic :: Text + , loggingConfigHostname :: Text + } deriving (Generic) -instance DefaultConfig ServerConfig where - configDef = ServerConfig - { serverConfigWarp = configDef - , serverConfigDbString = "" - , serverConfigGtfs = "./gtfs.zip" - , serverConfigAssets = "./assets" - , serverConfigZoneinfoPath = "/etc/zoneinfo/" - , serverConfigLogin = configDef - } +instance ConfigValue (URIRef Absolute) where + fromConfig val@(ConfigString text) = + case parseURI strictURIParserOptions text of + Right uri -> Right uri + Left err -> Left $ ParseError (T.pack $ show err) + fromConfig val = Left (TypeMismatch "URI" val) -instance DefaultConfig UffdConfig where - configDef = UffdConfig uri "secret" "uffdclient" False - where Right uri = parseURI strictURIParserOptions "http://www.example.org" + prettyValue uri = decodeUtf8 (serializeURIRef' uri) -instance FromConfig UffdConfig where - fromConfig key config = do - url <- fetchFromConfig (key /. "url") config - let Right uffdConfigUrl = parseURI strictURIParserOptions url - uffdConfigClientName <- fetchFromConfig (key /. "clientName") config - uffdConfigClientSecret <- fetchFromConfig (key /. "clientSecret") config - uffdConfigEnable <- fetchFromConfig (key /. "enable") config +instance Config UffdConfig where + readConfig = do + uffdConfigUrl <- readRequiredValue [key|url|] + uffdConfigClientName <- readRequiredValue [key|clientName|] + uffdConfigClientSecret <- readRequiredValue [key|clientSecret|] + uffdConfigEnable <- readRequiredValue [key|enable|] pure UffdConfig {..} + +instance Config LoggingConfig where + readConfig = LoggingConfig + <$> readOptionalValue [key|ntfyTrackerId|] + <*> readValue "tracktrain" [key|ntfyTopic|] + <*> readValue "tracktrain" [key|name|] + +instance Config Warp.Settings where + readConfig = do + port <- readOptionalValue [key|port|] + host <- readOptionalValue [key|host|] + timeout <- readOptionalValue [key|timeout|] + fdCacheDuration <- readOptionalValue [key|fdCacheDuration|] + fileInfoCacheDuration <- readOptionalValue [key|fileInfoCacheDuration|] + noParsePath <- readOptionalValue [key|noParsePath|] + serverName <- readOptionalValue [key|serverName|] + maximumBodyFlush <- readOptionalValue [key|maximumBodyFlush|] + gracefulShutdownTimeout <- readOptionalValue [key|gracefulShutdownTimeout|] + altSvc <- readOptionalValue [key|altSvc|] + + pure $ Warp.defaultSettings + & doIf port Warp.setPort + & doIf host Warp.setHost + & doIf timeout Warp.setTimeout + & doIf fdCacheDuration Warp.setFdCacheDuration + & doIf fileInfoCacheDuration Warp.setFileInfoCacheDuration + & doIf noParsePath Warp.setNoParsePath + & doIf serverName Warp.setServerName + & doIf maximumBodyFlush Warp.setMaximumBodyFlush + & doIf gracefulShutdownTimeout Warp.setGracefulShutdownTimeout + & doIf altSvc Warp.setAltSvc + + where doIf Nothing _ = id + doIf (Just a) f = f a + +instance ConfigValue Warp.HostPreference where + fromConfig (ConfigString buf) = Right $ fromString (T.unpack (decodeUtf8 buf)) + fromConfig val = Left (TypeMismatch "HostPreference" val) + +instance Config ServerConfig where + readConfig = ServerConfig + <$> readNested [key|warp|] + <*> readValue "" [key|dbstring|] + <*> readValue [osp|./gtfs.zip|] [key|gtfs|] + <*> readValue [osp|./assets|] [key|assets|] + <*> readValue [osp|/etc/zoneinfo/|] [key|zoneinfopath|] + <*> readValue False [key|debugmode|] + <*> readNestedOptional [key|login|] + <*> readNested [key|logging|] + <*> readValue False [key|beSilent|] diff --git a/lib/Extrapolation.hs b/lib/Extrapolation.hs index 5adc074..3d19393 100644 --- a/lib/Extrapolation.hs +++ b/lib/Extrapolation.hs @@ -1,48 +1,57 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstrainedClassMethods #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecordWildCards #-} module Extrapolation (Extrapolator(..), LinearExtrapolator(..), linearDelay, distanceAlongLine, euclid) where -import Data.Foldable (maximumBy, minimumBy) -import Data.Function (on) -import Data.List.NonEmpty (NonEmpty) -import qualified Data.List.NonEmpty as NE -import qualified Data.Map as M -import Data.Time (Day, UTCTime (UTCTime, utctDay), - diffUTCTime, getCurrentTime, - nominalDiffTimeToSeconds) -import qualified Data.Vector as V -import GHC.Float (int2Double) -import GHC.IO (unsafePerformIO) +import Data.Foldable (maximumBy, minimumBy) +import Data.Function (on) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map as M +import Data.Time (Day, + UTCTime (UTCTime, utctDay), + diffUTCTime, + getCurrentTime, + nominalDiffTimeToSeconds) +import qualified Data.Vector as V +import GHC.Float (int2Double) +import GHC.IO (unsafePerformIO) -import Conduit (MonadIO (liftIO)) -import Data.List (sortBy, sortOn) -import Data.Ord (Down (..)) -import GTFS (Depth (Deep), GTFS (..), Seconds (..), - Shape (..), Station (stationName), - Stop (..), Time, Trip (..), seconds2Double, - stationGeopos, toSeconds) -import Persist (Running (..), TrainAnchor (..), - TrainPing (..)) -import Server.Util (utcToSeconds) +import API (SentPing (..)) +import Conduit (MonadIO (liftIO)) +import Data.List (sortBy, sortOn) +import Data.Ord (Down (..)) +import Data.Time.LocalTime.TimeZone.Series (TimeZoneSeries) +import GTFS (Seconds (..), + seconds2Double, toSeconds) +import Persist (Geopos (..), + ShapePoint (shapePointGeopos), + Station (..), Stop (..), + Ticket (..), TicketId, + Tracker (..), + TrackerId (..), + TrainAnchor (..)) +import Server.Util (utcToSeconds) -- | Determines how to extrapolate delays (and potentially other things) from the real-time -- data sent in by the OBU. Potentially useful to swap out the algorithm, or give it options. -- TODO: maybe split into two classes? -class Extrapolator a where +class Extrapolator strategy where -- | here's a position ping, guess things from that! - extrapolateAnchorFromPing :: a -> GTFS -> Running -> TrainPing -> TrainAnchor + extrapolateAnchorFromPing + :: strategy + -> TicketId + -> Ticket + -> V.Vector (Stop, Station, TimeZoneSeries) + -> V.Vector ShapePoint + -> SentPing + -> TrainAnchor -- | extrapolate status at some time (i.e. "how much delay does the train have *now*?") - extrapolateAtSeconds :: a -> NonEmpty TrainAnchor -> Seconds -> Maybe TrainAnchor + extrapolateAtSeconds :: strategy -> NonEmpty TrainAnchor -> Seconds -> Maybe TrainAnchor -- | extrapolate status at some places (i.e. "how much delay will it have at the next station?") - extrapolateAtPosition :: a -> NonEmpty TrainAnchor -> Double -> Maybe TrainAnchor + extrapolateAtPosition :: strategy -> NonEmpty TrainAnchor -> Double -> Maybe TrainAnchor data LinearExtrapolator = LinearExtrapolator @@ -51,64 +60,73 @@ instance Extrapolator LinearExtrapolator where extrapolateAtSeconds _ history secondsNow = fmap (minimumBy (compare `on` difference)) $ NE.nonEmpty $ NE.filter (\a -> trainAnchorWhen a < secondsNow) history - where difference status = secondsNow - (trainAnchorWhen status) + where difference status = secondsNow - trainAnchorWhen status -- note that this sorts (descending) for time first as a tie-breaker -- (in case the train just stands still for a while, take the most recent update) extrapolateAtPosition _ history positionNow = fmap (minimumBy (compare `on` difference)) - $ NE.nonEmpty $ sortOn (Down . trainAnchorWhen) + $ NE.nonEmpty $ sortOn (Down . trainAnchorCreated) $ NE.filter (\a -> trainAnchorSequence a < positionNow) history - where difference status = positionNow - (trainAnchorSequence status) + where difference status = positionNow - trainAnchorSequence status - extrapolateAnchorFromPing _ gtfs@GTFS{..} Running{..} ping@TrainPing{..} = TrainAnchor - { trainAnchorCreated = trainPingTimestamp - , trainAnchorTrip = runningTrip - , trainAnchorDay = runningDay - , trainAnchorWhen = utcToSeconds trainPingTimestamp runningDay + extrapolateAnchorFromPing _ ticketId Ticket{..} stops shape ping@SentPing{..} = TrainAnchor + { trainAnchorCreated = sentPingTimestamp + , trainAnchorTicket = ticketId + , trainAnchorWhen = utcToSeconds sentPingTimestamp ticketDay , trainAnchorSequence , trainAnchorDelay , trainAnchorMsg = Nothing } - where Just trip = M.lookup runningTrip trips - (trainAnchorDelay, trainAnchorSequence) = linearDelay gtfs trip ping runningDay + where + (trainAnchorDelay, trainAnchorSequence) = linearDelay stops shape ping ticketDay + tzseries = undefined -linearDelay :: GTFS -> Trip Deep Deep -> TrainPing -> Day -> (Seconds, Double) -linearDelay GTFS{..} trip@Trip{..} TrainPing{..} runningDay = (observedDelay, observedSequence) - where -- | at which sequence number is the ping? +linearDelay :: V.Vector (Stop, Station, TimeZoneSeries) -> V.Vector ShapePoint -> SentPing -> Day -> (Seconds, Double) +linearDelay tripStops shape SentPing{..} runningDay = (observedDelay, observedSequence) + where -- at which (fractional) sequence number is the ping? observedSequence = int2Double (stopSequence lastStop) + observedProgress * int2Double (stopSequence nextStop - stopSequence lastStop) - -- | how much later/earlier is the ping than would be expected? + + -- how much later/earlier is the ping than would be expected? observedDelay = Seconds $ round $ (expectedProgress - observedProgress) * int2Double (unSeconds expectedTravelTime) + + if expectedProgress == 1 -- if the hypothetical on-time train is already at (or past) the next station, -- just add the time distance we're behind - + if expectedProgress /= 1 then 0 - else seconds2Double (utcToSeconds trainPingTimestamp runningDay - - toSeconds (stopArrival nextStop) tzseries runningDay) + then seconds2Double (utcToSeconds sentPingTimestamp runningDay - nextSeconds) + -- otherwise the above is sufficient + else 0 - -- | how far along towards the next station is the ping (between 0 and 1)? + -- how far along towards the next station is the ping (between 0 and 1)? observedProgress = - distanceAlongLine line (stationGeopos $ stopStation lastStop) closestPoint - / distanceAlongLine line (stationGeopos $ stopStation lastStop) (stationGeopos $ stopStation nextStop) - -- | to compare: where would a linearly-moving train be (between 0 and 1)? + distanceAlongLine line (stationGeopos lastStation) closestPoint + / distanceAlongLine line (stationGeopos lastStation) (stationGeopos nextStation) + + -- to compare: where would a linearly-moving train be (between 0 and 1)? expectedProgress = if | p < 0 -> 0 | p > 1 -> 1 | otherwise -> p - where p = seconds2Double (utcToSeconds trainPingTimestamp runningDay - - toSeconds (stopDeparture lastStop) tzseries runningDay) - / seconds2Double expectedTravelTime - -- | how long do we expect the trip from last to next station to take? - expectedTravelTime = - toSeconds (stopArrival nextStop) tzseries runningDay - - toSeconds (stopDeparture lastStop) tzseries runningDay + where p = seconds2Double (utcToSeconds sentPingTimestamp runningDay - lastSeconds) + / seconds2Double expectedTravelTime + + -- scheduled duration between last and next stops + expectedTravelTime = nextSeconds - lastSeconds + + -- closest point on the shape; this is where we assume the train to be + closestPoint = minimumBy (compare `on` euclid sentPingGeopos) line + + -- scheduled departure at last & arrival at next stop + lastSeconds = toSeconds (stopDeparture lastStop) lastTzSeries runningDay + nextSeconds = toSeconds (stopArrival nextStop) nextTzSeries runningDay + + (lastStop, lastStation, lastTzSeries) = tripStops V.! (nextIndex - 1) + (nextStop, nextStation, nextTzSeries) = tripStops V.! nextIndex + + line = fmap shapePointGeopos shape - closestPoint = minimumBy (compare `on` euclid (trainPingLat, trainPingLong)) line - line = shapePoints tripShape - lastStop = tripStops V.! (nextIndex - 1) - nextStop = tripStops V.! nextIndex - -- | index of the /next/ stop in the list, except when we're already at the last stop + -- index of the /next/ stop in the list, except when we're already at the last stop -- (in which case it stays the same) nextIndex = if | null remaining -> length tripStops - 1 @@ -116,23 +134,24 @@ linearDelay GTFS{..} trip@Trip{..} TrainPing{..} runningDay = (observedDelay, ob | otherwise -> idx' where idx' = fst $ V.minimumBy (compare `on` snd) remaining remaining = V.filter (\(_,dist) -> dist > 0) $ V.indexed - $ fmap (distanceAlongLine line closestPoint . stationGeopos . stopStation) tripStops + $ fmap (distanceAlongLine line closestPoint . stationGeopos . \(_,stop,_) -> stop) tripStops -distanceAlongLine :: V.Vector (Double, Double) -> (Double, Double) -> (Double, Double) -> Double +-- | approximate (but euclidean) distance along a geoline +distanceAlongLine :: V.Vector Geopos -> Geopos -> Geopos -> Double distanceAlongLine line p1 p2 = along2 - along1 where along1 = along p1 along2 = along p2 - along p@(x,y) = + along p@(Geopos (x,y)) = sumSegments $ V.take (index + 1) line where index = V.minIndexBy (compare `on` euclid p) line - sumSegments :: V.Vector (Double, Double) -> Double + sumSegments :: V.Vector Geopos -> Double sumSegments line = snd - $ foldl (\(p,a) p' -> (p', a + euclid p p')) (V.head line,0) $ line + $ foldl (\(p,a) p' -> (p', a + euclid p p')) (V.head line,0) line -- | euclidean distance. Notably not applicable when you're on a sphere -- (but good enough when the sphere is the earth) -euclid :: Floating f => (f,f) -> (f,f) -> f -euclid (x1,y1) (x2,y2) = sqrt (x*x + y*y) +euclid :: Geopos -> Geopos -> Double +euclid (Geopos (x1,y1)) (Geopos (x2,y2)) = sqrt (x*x + y*y) where x = x1 - x2 y = y1 - y2 diff --git a/lib/GTFS.hs b/lib/GTFS.hs index a2718b1..c4e2093 100644 --- a/lib/GTFS.hs +++ b/lib/GTFS.hs @@ -1,19 +1,11 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- | All kinds of stuff that has to deal with GTFS directly -- (i.e. parsing, querying, Aeson instances, etc.) @@ -73,6 +65,8 @@ import Data.Time.LocalTime.TimeZone.Olson (getTimeZoneSeriesFromOlson import Data.Time.LocalTime.TimeZone.Series (TimeZoneSeries, timeZoneFromSeries) import GHC.Float (int2Double) +import System.OsPath (OsPath, decodeUtf, + encodeUtf, (</>)) -- | for some reason this doesn't exist already in cassava @@ -96,11 +90,11 @@ swaggerOptions prefix = -- whatsoever, but are given in the timezone of the transport agency, and -- potentially displayed in a different timezone depending on the station they -- apply to. -data Time = Time { timeSeconds :: Int, timeTZseries :: TimeZoneSeries, timeTZname :: Text } +data Time = Time { timeSeconds :: Int, tzname :: Text } deriving (Generic) instance ToJSON Time where - toJSON (Time seconds _ tzname) = + toJSON (Time seconds tzname) = A.object [ "seconds" A..= seconds, "timezone" A..= tzname ] -- | a type for all timetable values lacking context @@ -123,7 +117,7 @@ seconds2Double = int2Double . unSeconds -- at the given number of seconds since midnight (note that this may lead to -- strange effects for timezone changes not taking place at midnight) toSeconds :: Time -> TimeZoneSeries -> Day -> Seconds -toSeconds (Time seconds _ _) tzseries refday = +toSeconds (Time seconds _) tzseries refday = Seconds $ seconds - timeZoneMinutes timezone * 60 where timezone = timeZoneFromSeries tzseries reftime reftime = UTCTime refday (fromInteger $ toInteger seconds) @@ -138,7 +132,7 @@ toUTC time tzseries refday = -- | Times in GTFS are given without timezone info, which is handled -- seperately (as an attribute of the stop / the agency). We attach that information -- back to the Time, this is just an intermediate step during parsing. -newtype RawTime = RawTime { unRawTime :: TimeZoneSeries -> Text -> Time } +newtype RawTime = RawTime { unRawTime :: Text -> Time } deriving (Generic) instance CSV.FromField RawTime where @@ -151,7 +145,7 @@ instance CSV.FromField RawTime where _ -> fail $ "encountered an invalid date: " <> text instance Show Time where - show (Time seconds _ _) = "" + show (Time seconds _) = "" +|pad (seconds `div` 3600)|+":" +|pad ((seconds `mod` 3600) `div` 60)|+ if seconds `mod` 60 /= 0 then":"+|pad (seconds `mod` 60)|+"" @@ -162,7 +156,7 @@ instance Show Time where where str = show num showTimeWithSeconds :: Time -> String -showTimeWithSeconds (Time seconds _ _) = "" +showTimeWithSeconds (Time seconds _) = "" +|pad (seconds `div` 3600)|+":" +|pad ((seconds `mod` 3600) `div` 60)|+ ":"+|pad (seconds `mod` 60)|+"" @@ -201,7 +195,7 @@ type family Optional c a where Optional Shallow _ = () type StationID = Text -type TripID = Text +type TripId = Text type ServiceID = Text @@ -226,7 +220,7 @@ stationGeopos Station{..} = (stationLat, stationLon) -- | This is what's called a stop time in GTFS data Stop (deep :: Depth) = Stop - { stopTrip :: TripID + { stopTrip :: TripId , stopArrival :: Switch deep Time RawTime , stopDeparture :: Switch deep Time RawTime , stopStation :: Switch deep Station StationID @@ -282,7 +276,7 @@ instance FromForm CalendarDate data Trip (deep :: Depth) (shape :: Depth)= Trip { tripRoute :: Switch deep (Route Deep) Text - , tripTripID :: TripID + , tripTripId :: TripId , tripHeadsign :: Maybe Text , tripShortName :: Maybe Text , tripDirection :: Maybe Bool @@ -411,11 +405,11 @@ instance CSV.FromNamedRecord ShapePoint where intAsBool :: CSV.NamedRecord -> BS.ByteString -> CSV.Parser (Maybe Bool) intAsBool r field = do - int <- r .: field - pure $ case int :: Int of - 1 -> Just True - 0 -> Just False - _ -> Nothing + int <- r .:? field + pure $ case int :: Maybe Int of + Just 1 -> Just True + Just 0 -> Just False + _ -> Nothing intAsBool' :: CSV.NamedRecord -> BS.ByteString -> CSV.Parser Bool intAsBool' r field = intAsBool r field >>= maybe @@ -495,7 +489,7 @@ data RawGTFS = RawGTFS data GTFS = GTFS { stations :: Map StationID Station - , trips :: Map TripID (Trip Deep Deep) + , trips :: Map TripId (Trip Deep Deep) , calendar :: Map DayOfWeek (Vector Calendar) , calendarDates :: Map Day (Vector CalendarDate) , shapes :: Map Text Shape @@ -507,9 +501,9 @@ data GTFS = GTFS } -loadRawGtfs :: FilePath -> IO RawGTFS +loadRawGtfs :: OsPath -> IO RawGTFS loadRawGtfs path = do - bytes <- LB.readFile path + bytes <- decodeUtf path >>= LB.readFile let zip = Zip.toArchive bytes RawGTFS <$> decodeTable' "stops.txt" zip @@ -539,7 +533,7 @@ loadRawGtfs path = do -- -- Note that this additionally needs a path to the machine's timezone info -- (usually /etc/zoneinfo or /usr/shared/zoneinfo) -loadGtfs :: FilePath -> FilePath -> IO GTFS +loadGtfs :: OsPath -> OsPath -> IO GTFS loadGtfs path zoneinforoot = do shallow@RawGTFS{..} <- loadRawGtfs path -- TODO: sort these according to sequence numbers @@ -549,7 +543,11 @@ loadGtfs path zoneinforoot = do (fromMaybe mempty rawShapePoints) -- all agencies must have the same timezone, so just take the first's let tzname = agencyTimezone $ V.head rawAgencies - tzseries <- getTimeZoneSeriesFromOlsonFile (zoneinforoot<>T.unpack tzname) + + tzsuffix <- encodeUtf (T.unpack tzname) + tzseries <- decodeUtf (zoneinforoot </> tzsuffix) + >>= getTimeZoneSeriesFromOlsonFile + let agencies' = fmap (\a -> a { agencyTimezone = tzseries }) rawAgencies routes' <- V.mapM (pushRoute agencies') rawRoutes <&> mapFromVector routeId @@ -557,7 +555,7 @@ loadGtfs path zoneinforoot = do trips' <- V.mapM (pushTrip routes' stops' shapes) rawTrips pure $ GTFS { stations = mapFromVector stationId rawStations - , trips = mapFromVector tripTripID trips' + , trips = mapFromVector tripTripId trips' , calendar = fmap V.fromList $ M.fromListWith (<>) @@ -595,22 +593,22 @@ loadGtfs path zoneinforoot = do tzseries <- getTimeZoneSeriesFromOlsonFile (T.unpack $ "/etc/zoneinfo/"<>tzname) pure (tzseries, tzname) pure $ stop { stopStation = station - , stopDeparture = unRawTime (stopDeparture stop) tzseries tzname - , stopArrival = unRawTime (stopArrival stop) tzseries tzname } + , stopDeparture = unRawTime (stopDeparture stop) tzname + , stopArrival = unRawTime (stopArrival stop) tzname } pushTrip :: Map Text (Route Deep) -> Vector (Stop Deep) -> Map Text Shape -> Trip Shallow Shallow -> IO (Trip Deep Deep) pushTrip routes stops shapes trip = if V.length alongRoute < 2 - then fail $ "trip with id "+|tripTripID trip|+" has no stops" + then fail $ "trip with id "+|tripTripId trip|+" has no stops" else do shape <- case M.lookup (tripShape trip) shapes of - Nothing -> fail $ "trip with id "+|tripTripID trip|+" mentions a shape that does not exist." + Nothing -> fail $ "trip with id "+|tripTripId trip|+" mentions a shape that does not exist." Just shape -> pure shape route <- case M.lookup (tripRoute trip) routes of - Nothing -> fail $ "trip with id "+|tripTripID trip|+" specifies a route_id which does not exist." + Nothing -> fail $ "trip with id "+|tripTripId trip|+" specifies a route_id which does not exist." Just route -> pure route pure $ trip { tripStops = alongRoute, tripShape = shape, tripRoute = route} where alongRoute = V.modify (V.sortBy (compare `on` stopSequence)) - $ V.filter (\s -> stopTrip s == tripTripID trip) stops + $ V.filter (\s -> stopTrip s == tripTripId trip) stops pushRoute :: Vector (Agency Deep) -> Route Shallow -> IO (Route Deep) pushRoute agencies route = case routeAgency route of Nothing -> do @@ -644,27 +642,27 @@ servicesOnDay GTFS{..} day = notCancelled serviceID = null (tableLookup caldateServiceId serviceID removed) -tripsOfService :: GTFS -> ServiceID -> Map TripID (Trip Deep Deep) +tripsOfService :: GTFS -> ServiceID -> Map TripId (Trip Deep Deep) tripsOfService GTFS{..} serviceId = M.filter (\trip -> tripServiceId trip == serviceId ) trips -- TODO: this should filter out trips ending there -tripsAtStation :: GTFS -> StationID -> Vector TripID +tripsAtStation :: GTFS -> StationID -> Vector TripId tripsAtStation GTFS{..} at = fmap stopTrip stops where stops = V.filter (\(stop :: Stop Deep) -> stationId (stopStation stop) == at) stops -tripsOnDay :: GTFS -> Day -> Map TripID (Trip Deep Deep) +tripsOnDay :: GTFS -> Day -> Map TripId (Trip Deep Deep) tripsOnDay gtfs today = foldMap (tripsOfService gtfs) (servicesOnDay gtfs today) -runsOnDay :: GTFS -> TripID -> Day -> Bool +runsOnDay :: GTFS -> TripId -> Day -> Bool runsOnDay gtfs trip day = not . null . M.filter same $ tripsOnDay gtfs day - where same Trip{..} = tripTripID == trip + where same Trip{..} = tripTripId == trip -runsToday :: MonadIO m => GTFS -> TripID -> m Bool +runsToday :: MonadIO m => GTFS -> TripId -> m Bool runsToday gtfs trip = do today <- liftIO getCurrentTime <&> utctDay pure (runsOnDay gtfs trip today) tripName :: Trip a b -> Text -tripName Trip{..} = fromMaybe tripTripID tripShortName +tripName Trip{..} = fromMaybe tripTripId tripShortName diff --git a/lib/MultiLangText.hs b/lib/MultiLangText.hs new file mode 100644 index 0000000..4cd3fc3 --- /dev/null +++ b/lib/MultiLangText.hs @@ -0,0 +1,12 @@ + +-- | simple translated text +module MultiLangText (MultiLangText, monolingual) where + +import Data.Map (Map, singleton) +import Data.Text (Text) +import Text.Shakespeare.I18N (Lang) + +type MultiLangText = Map Lang Text + +monolingual :: Lang -> Text -> MultiLangText +monolingual = singleton diff --git a/lib/OwnTracks.hs b/lib/OwnTracks.hs new file mode 100644 index 0000000..e9bb011 --- /dev/null +++ b/lib/OwnTracks.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE LambdaCase #-} + + +module OwnTracks + (Message(..), + module OwnTracks.Location, + module OwnTracks.Status, + module OwnTracks.Configuration, + module OwnTracks.Command, + module OwnTracks.Waypoint + ) where + +import Data.Aeson +import Data.Aeson.Types (Parser) +import Data.ByteString (ByteString) +import Data.ByteString.Base64 +import Data.Functor ((<&>)) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Data.Time (UTCTime, defaultTimeLocale, + parseTimeM) +import Database.Persist +import GHC.Generics (Generic) + +import OwnTracks.Command +import OwnTracks.Configuration +import OwnTracks.Location +import OwnTracks.Status +import OwnTracks.Waypoint + +data Message = + MsgLocation Location + | MsgStatus Status + | MsgConfig Configuration + | MsgWaypoints [Waypoint] + deriving (Generic, Show, Eq) + +instance FromJSON Message where + parseJSON v@(Object o) = do + ty :: Text <- o .: "_type" + case ty of + "location" -> MsgLocation <$> parseJSON v + "status" -> MsgStatus <$> parseJSON v + "configuration" -> MsgConfig <$> parseJSON v + "waypoints" -> MsgWaypoints <$> (fmap (fromMaybe []) (o .:? "waypoints")) + _ -> fail "unknown _type of owntracks message." diff --git a/lib/OwnTracks/Command.hs b/lib/OwnTracks/Command.hs new file mode 100644 index 0000000..532a593 --- /dev/null +++ b/lib/OwnTracks/Command.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE LambdaCase #-} + + +module OwnTracks.Command +-- | https://owntracks.org/booklet/tech/json/ + (Command(..)) where + +import Data.Aeson +import Data.Aeson.Types (Parser) +import Data.ByteString (ByteString) +import Data.ByteString.Base64 +import Data.Functor ((<&>)) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Data.Time (UTCTime, defaultTimeLocale, + parseTimeM) +import Database.Persist +import GHC.Generics (Generic) + +import OwnTracks.Configuration +import OwnTracks.Waypoint + +data Command = + Dump + -- ^ Triggers the publish of a configuration message (iOS) + | GetStatus + -- ^ Triggers the publish of a status message to ../status (iOS) + | ReportSteps { reportStepsFrom :: Maybe Int, reportStepsTo :: Maybe Int } + -- ^ Triggers the report of a steps messages_(iOS)_ + | ReportLocation + -- ^ Triggers the publish of a location messages (iOS,Android) Don‘t expect device to be online. Send with QoS>0. Device will receive and repond when activated next time + | ClearWaypoints + -- ^ deletes all waypoints/regions (iOS) + | SetWaypoints [Waypoint] + -- ^ Imports (merge) and activates new waypoints (iOS,Android) + | SetConfiguration Configuration + -- ^ Imports and activates new configuration values (iOS,Android) + | GetWaypoints + -- ^ Triggers publish of a waypoints message (iOS,Android) + deriving (Eq, Show, Generic) + +instance ToJSON Command where + toJSON c = object ( "_type" .= String "cmd" + : "action" .= String action + : others ) + where action = case c of + Dump -> "dump" + GetStatus -> "status" + ReportSteps _ _ -> "reportSteps" + ReportLocation -> "reportLocation" + ClearWaypoints -> "clearWaypoints" + SetWaypoints _ -> "setWaypoints" + SetConfiguration _ -> "setConfiguration" + GetWaypoints -> "waypoints" + others = case c of + ReportSteps f t -> [ "from" .= f, "to" .= t ] + SetWaypoints ws -> [ "waypoints" .= ws ] + SetConfiguration c -> [ "configuration" .= c ] + _ -> [] + +instance FromJSON Command where + parseJSON (Object v) = do + action :: Text <- v .: "action" + case action of + "dump" -> pure Dump + "status" -> pure GetStatus + "reportSteps" -> ReportSteps <$> v .: "from" <*> v .: "to" + "reportLocation" -> pure ReportLocation + "clearWaypoints" -> pure ClearWaypoints + "setWaypoints" -> SetWaypoints <$> v .: "waypoints" + "setConfiguration" -> SetConfiguration <$> v .: "configuration" + "waypoints" -> pure GetWaypoints + _ -> fail "unknown action in _type=command" + parseJSON _ = fail "Command should be an object" diff --git a/lib/OwnTracks/Configuration.hs b/lib/OwnTracks/Configuration.hs new file mode 100644 index 0000000..a10a46e --- /dev/null +++ b/lib/OwnTracks/Configuration.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + + +module OwnTracks.Configuration +-- | https://owntracks.org/booklet/tech/json/ + (Configuration(..), LocatorPriority(..), MonitoringMode(..)) where + +import Data.Aeson +import qualified Data.Aeson.TH as TH +import Data.Aeson.Types (Parser) +import Data.ByteString (ByteString) +import Data.ByteString.Base64 +import Data.Char (toLower) +import Data.Data (Proxy (..)) +import Data.Functor ((<&>)) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Data.Time (UTCTime, defaultTimeLocale, parseTimeM) +import GHC.Generics (Generic) + +import OwnTracks.Location (MonitoringMode) +import OwnTracks.Waypoint (Waypoint) + + +data LocatorPriority = + NoPower + -- ^ best accuracy possible with zero additional power consumption (Android) + | LowPower + -- ^ city level accuracy (Android) + | BalancedPower + -- ^ block level accuracy based on Wifi/Cell (Android) + | HighPower + -- ^ most accurate accuracy based on GPS (Android) + deriving (Show, Eq, Enum) + +instance FromJSON LocatorPriority where + parseJSON = fmap toEnum . parseJSON + +instance ToJSON LocatorPriority where + toJSON = toJSON . fromEnum + +data ProtocolMode = Mqtt | Http + deriving (Show, Eq) + +instance FromJSON ProtocolMode where + parseJSON (Number 0) = pure Mqtt + parseJSON (Number 3) = pure Http + parseJSON _ = fail "mode must be 0 (mqtt) or 3 (http)" + +instance ToJSON ProtocolMode where + toJSON Mqtt = Number 0 + toJSON Http = Number 3 + +data Configuration = Configuration + { configAdapt :: Maybe Int + -- ^ time in minutes of non-movement before switching from move to significant mode. 0 (zero) means disabled. Defaults to 0 (zero) (iOS/integer/minutes/optional) + , configAllowRemoteLocation :: Maybe Bool + -- ^ Respond to reportLocation cmd message (iOS/boolean) + , configAllowInvalidCerts :: Maybe Bool + -- ^ disable TLS certificate checks insecure (iOS/boolean) + , configAuth :: Maybe Bool + -- ^ Use username and password for endpoint authentication (iOS,Android/boolean) + , configAutostartOnBoot :: Maybe Bool + -- ^ Autostart the app on device boot (Android/boolean) + , configCleanSession :: Maybe Bool + -- ^ MQTT endpoint clean session (iOS,Android/boolean) + , configClientId :: Maybe Text + -- ^ client id to use for MQTT connect. Defaults to "user deviceId" (iOS,Android/string) + , configClientpkcs :: Maybe Text + -- ^ Name of the client pkcs12 file (iOS/string) + , configCmd :: Maybe Bool + -- ^ Respond to cmd messages (iOS,Android/boolean) + , configConnectionTimeoutSeconds :: Maybe Int + -- ^ (default 30) TCP timeout for establishing a connection to the MQTT / HTTP broker, (Android/int) + , configDay :: Maybe Int + -- ^ Number of days to keep locations stored locally. 0 means no local keeping of locations. A negative number indicates to use the positions value. Defaults to -1 for backward compatibility. (iOS/integer/days) + , configDebugLog :: Maybe Bool + -- ^ (default false) whether or not debug logs should be shown in the log viewer / exporter activity (Android/bool) + , configDeviceId :: Maybe Text + -- ^ id of the device used for pubTopicBase and clientId construction. Defaults to the os name of the device (iOS,Android/string) + , configDowngrade :: Maybe Int + -- ^ battery level below which to downgrade monitoring from move mode (iOS/integer/percent/optional) + , configEcryptionKey :: Maybe Text + -- ^ the secret key used for payload encryption (iOS,Android/string) + , configExtendedData :: Maybe Bool + -- ^ Add extended data attributes to location messages (iOS,Android/boolean) + , configHost :: Maybe Text + -- ^ MQTT endpoint host (iOS,Android/string) + -- FIXME: structured type here? + , configHttpHeaders :: Maybe Text + -- ^ extra HTTP headers:field names and field content are separated by a colon (:), multiple fields by a backslash-n (\n) \<field-name>:\<field-content>\n\<field-name>:\<field-content>... (iOS only/string) + , configIgnoreInaccurateLocations :: Maybe Int + -- ^ Location accuracy below which reports are supressed. 0 means no locations are suppressed. (iOS,Android/integer/meters) + , configIgnoreStaleLocations :: Maybe Bool + -- ^ Number of days after which location updates are assumed stale. Locations sent by friends older than the number of days specified here will not be shown on map or in friends list. Defaults to 0, which means stale locations are not filtered. (iOS,Android/integer/days) + , configKeepalive :: Maybe Int + -- ^ MQTT endpoint keepalive (iOS,Android/integer/seconds) + , configLocatorDisplacement :: Maybe Int + -- ^ maximum distance between location source updates (iOS,Android/integer/meters) + , configLocatorInterval :: Maybe Int + -- ^ maximum interval between location source updates (iOS,Android/integer/seconds) + , configLocatorPriority :: Maybe LocatorPriority + -- ^ source/power setting for location updates (Android/integer) + , configLocked :: Maybe Bool + -- ^ Locks settings screen on device for editing (iOS/boolean) + , configMaxHistory :: Maybe Int + -- ^ Number of notifications to store historically. Zero (0) means no notifications are stored and history tab is hidden. Defaults to zero. (iOS/integer) + , configMode :: Maybe ProtocolMode + -- ^ Endpoint protocol mode (iOS,Android/integer) + , configMonitoring :: Maybe MonitoringMode + -- ^ Location reporting mode (iOS,Android/integer) + , configProtocolLevel :: Maybe Int + -- ^ MQTT broker protocol level (iOS,Android/integer) + , configNotificationLocation :: Maybe Bool + -- ^ Show last reported location in ongoing notification (Android/boolean) + , configOpencageApiKey :: Maybe Text + -- ^ API key for alternate Geocoding provider. See OpenCage for details. (Android/string) + , configOsmTemplate :: Maybe Text + -- ^ URL template for alternate tile provider. Defaults to https://tile.openstreetmap.org/{z}/{x}/{y}.png. (iOS/string) + , configOsmCopyright :: Maybe Text + -- ^ Attribution text shown with OSM map. Defaults to (c) OpenStreetMap contributors. (iOS/string) + , configPassphrase :: Maybe Text + -- ^ Passphrase of the client pkcs12 file (iOS/string) + , configPassword :: Maybe Text + -- ^ Endpoint password (iOS,Android/string) + , configPegLocatorFastestIntervalToInterval :: Maybe Bool + -- ^ (default false) - if true, requests that that the device provide locations no faster than the specified interval. Location providers often use the requested interval as a "at least every" setting, and may return locations more frequencly. Some people wanted the behaviour where it also meant "no more frequently than", so this setting lets them specify this (Android/bool) + , configPing :: Maybe Int + -- ^ Interval in which location messages of with t:p are reported (Android/integer) + , configPort :: Maybe Int + -- ^ MQTT endpoint port (iOS,Android/integer) + , configPositions :: Maybe Int + -- ^ Number of locations to keep for friends and own device and display (iOS/integer) + , configPubTopicBase :: Maybe Text + -- ^ MQTT topic base to which the app publishes; %u is replaced by the user name, %d by device (iOS,Android/string) + , configPubRetain :: Maybe Bool + -- ^ MQTT retain flag for reported messages (iOS,Android/boolean) + , configPubQos :: Maybe Int + -- ^ MQTT QoS level for reported messages (iOS,Android/integer) + , configRanging :: Maybe Bool + -- ^ Beacon ranging (iOS/boolean) + , configRemoteConfiguration :: Maybe Bool + -- ^ Allow remote configuration by sending a setConfiguration cmd message (Android/boolean) + , configSub :: Maybe Bool + -- ^ subscribe to subTopic via MQTT (iOS,Android/boolean) + , configSubTopic :: Maybe Text + -- ^ A whitespace separated list of MQTT topics to which the app subscribes if sub is true (defaults see topics) (iOS,Android/string) + , configSubQos :: Maybe Bool + -- ^ (iOS,Android/boolean) + , configTid :: Maybe Text + -- ^ Two digit Tracker ID used to display short name and default face of a user (iOS,Android/string) + , configTls :: Maybe Bool + -- ^ MQTT endpoint TLS connection (iOS,Android/boolean) + , configTlsClientCrtPassword :: Maybe Text + -- ^ Passphrase of the client pkcs12 file (Android/string) + , configUrl :: Maybe Text + -- ^ HTTP endpoint URL to which messages are POSTed (iOS,Android/string) + , configUsername :: Maybe Text + -- ^ Endpoint username (iOS,Android/string) + , configWs :: Maybe Bool + -- ^ use MQTT over Websocket, default false (iOS,Android/boolean) + , configWaypoints :: Maybe [Waypoint] + -- ^ Array of waypoint messages (iOS,Android/array) + } deriving (Show, Eq, Generic) + + +TH.deriveJSON (TH.defaultOptions -- TODO: _type=configuration missing! + { TH.omitNothingFields = True + , TH.rejectUnknownFields = True + , TH.fieldLabelModifier = (\(x:xs) -> toLower x : xs) . drop 6 + }) 'Configuration diff --git a/lib/OwnTracks/Location.hs b/lib/OwnTracks/Location.hs new file mode 100644 index 0000000..6a0fbde --- /dev/null +++ b/lib/OwnTracks/Location.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE LambdaCase #-} + + +module OwnTracks.Location +-- | https://owntracks.org/booklet/tech/json/ + (BatteryStatus(..), Trigger(..), MonitoringMode(..), Location(..)) where + +import Data.Aeson +import Data.Aeson.Types (Parser) +import Data.ByteString (ByteString) +import Data.ByteString.Base64 +import Data.Functor ((<&>)) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Data.Time (UTCTime, defaultTimeLocale, parseTimeM) +import Database.Persist +import GHC.Generics (Generic) + +data BatteryStatus = + Unknown + | Unplugged + | Charging + | Full + deriving (Generic, Show, Eq, Enum) + +data Trigger = + Ping + -- ^ ping issued randomly by background task (iOS,Android) + | CircularRegionEnterLeave + -- ^ circular region enter/leave event (iOS,Android) + | CircularRegionEnterLeavePlus + -- ^ circular region enter/leave event for +follow regions (iOS) + | BeaconRegionEnterLeave + -- ^ beacon region enter/leave event (iOS) + | ReportLocationResponse + -- ^ response to a reportLocation cmd message (iOS,Android) + | ManualTrigger + -- ^ manual publish requested by the user (iOS,Android) + | Timer + -- ^ timer based publish in move move (iOS) + | LocationsServices + -- ^ updated by Settings/Privacy/Locations Services/System Services/Frequent Locations monitoring (iOS) + deriving (Generic, Show, Eq) + +instance FromJSON Trigger where + parseJSON (String s) = case s of + "p" -> pure Ping + "c" -> pure CircularRegionEnterLeave + "C" -> pure CircularRegionEnterLeavePlus + "b" -> pure BeaconRegionEnterLeave + "r" -> pure ReportLocationResponse + "u" -> pure ManualTrigger + "t" -> pure Timer + "v" -> pure LocationsServices + other -> fail $ show other <> "Unknown Trigger Type (not one of p, c, C, b, r, m, t, v)" + parseJSON _ = fail "Trigger Type must be a string" + +data MonitoringMode = Quiet | Manual | Significant | Move + deriving (Generic, Show, Eq, Enum) + +instance FromJSON MonitoringMode where + parseJSON (Number i) = case i of + -1 -> pure Quiet + 0 -> pure Manual + 1 -> pure Significant + 2 -> pure Move + _ -> fail "Unknown Monitoring Mode (not in -1,..,2)" + parseJSON _ = fail "Monitoring Mode must be a number" + +instance ToJSON MonitoringMode where + toJSON m = toJSON (fromEnum m - 1) + +data Connection = + Wifi { connectionSSID :: Maybe Text + -- ^ if available, is the unique name of the WLAN. (iOS,string/optional) + , connectionBSSID :: Maybe Text + -- ^ if available, identifies the access point. (iOS,string/optional) + } + | Offline | Mobile + deriving (Generic, Show, Eq) + + +-- | https://owntracks.org/booklet/tech/json/ +data Location = Location + { locationAccuracy :: Maybe Int + -- ^ Accuracy of the reported location in meters without unit (iOS,Android/integer/meters/optional) + , locationAltitude :: Maybe Int + -- ^ Altitude measured above sea level (iOS,Android/integer/meters/optional) + , locationBattery :: Maybe Int + -- ^ Device battery level (iOS,Android/integer/percent/optional) + , locationBatteryStatus :: Maybe BatteryStatus + -- ^ Battery Status 0=unknown, 1=unplugged, 2=charging, 3=full (iOS, Android) + , locationCourse :: Maybe Int + -- ^ Course over ground (iOS/integer/degree/optional) + , locationLatitude :: Double + -- ^ latitude (iOS,Android/float/degree/required) + , locationLongitude :: Double + -- ^ longitude (iOS,Android/float/degree/required) + , locationRegionRadios :: Maybe Int + -- ^ radius around the region when entering/leaving (iOS/integer/meters/optional) + , locationTrigger :: Maybe Trigger + -- ^ trigger for the location report (iOS,Android/string/optional) + , locationTrackerId :: Maybe Text + -- ^ Tracker ID used to display the initials of a user (iOS,Android/string/optional) required for http mode + , locationTimestamp :: UTCTime + -- ^ UNIX epoch timestamp in seconds of the location fix (iOS,Android/integer/epoch/required) + , locationVerticalAccuracy :: Maybe Int + -- ^ vertical accuracy of the alt element (iOS/integer/meters/optional) + , locationVelocity :: Maybe Int + -- ^ velocity (iOS,Android/integer/kmh/optional) + , locationBarometricPressure :: Maybe Double + -- ^ barometric pressure (iOS/float/kPa/optional/extended data) + , locationPointOfInterestName :: Maybe Text + -- ^ point of interest name (iOS/string/optional) + , locationImage :: Maybe ByteString + -- ^ Base64 encoded image associated with the poi (iOS/string/optional) + , locationImageName :: Maybe Text + -- ^ Name of the image associated with the poi (iOS/string/optional) + , locationConnection :: Maybe Connection + -- ^ Internet connectivity status (route to host) when the message is created (iOS,Android/string/optional/extended data) + , locationTag :: Maybe Text + -- ^ name of the tag (iOS/string/optional) + , locationTopic :: Maybe Text + -- ^ (only in HTTP payloads) contains the original publish topic (e.g. owntracks/jane/phone). (iOS,Android >= 2.4,string) + , locationInRegions :: Maybe [Text] + -- ^ contains a list of regions the device is currently in (e.g. ["Home","Garage"]). Might be empty. (iOS,Android/list of strings/optional) + , locationInRegionIds :: Maybe [Text] + -- ^ contains a list of region IDs the device is currently in (e.g. ["6da9cf","3defa7"]). Might be empty. (iOS,Android/list of strings/optional) + , locationCreatedAt :: Maybe UTCTime + -- ^ identifies the time at which the message is constructed (if it differs from locationTimestamp, which is the timestamp of the GPS fix) (iOS,Android/integer/epoch/optional) + , locationMonitoringMode :: Maybe MonitoringMode + -- ^ identifies the monitoring mode at which the message is constructed (significant=1, move=2) (iOS/integer/optional) + , locationRandomId :: Maybe Text + -- ^ random identifier to be used by consumers to correlate & distinguish send/return messages (Android/string) + , locationMotionActivities :: Maybe Text + -- ^ contains a list of motion states detected by iOS' motion manager (a combination of stationary, walking, running, automotive, cycling, and/or unknown, e.g. ["cycling"]). (iOS/list of strings/optional) + } deriving (Generic, Show, Eq) + +instance FromJSON Location where + parseJSON (Object v) = Location + <$> v .:? "acc" + <*> v .:? "alt" + <*> v .:? "batt" + <*> (v .:? "bs" <&> fmap toEnum) + <*> v .:? "cog" + <*> v .: "lat" + <*> v .: "lon" + <*> v .:? "rad" + <*> v .:? "t" + <*> v .:? "tid" + <*> (v .: "tst" >>= parseUnixTime) + <*> v .:? "vac" + <*> v .:? "vel" + <*> v .:? "p" + <*> v .:? "poi" + <*> (v .:? "image" >>= mapM fromBase64) + <*> v .:? "imagename" + <*> (v .:? "conn" >>= mapM parseConnection) + <*> v .:? "tag" + <*> v .:? "topic" + <*> v .:? "inregions" + <*> v .:? "inrids" + <*> (v .:? "created_at" >>= mapM parseUnixTime) + <*> v .:? "m" + <*> v .:? "_id" + <*> v .:? "motionactivities" + where parseUnixTime :: Int -> Parser UTCTime + parseUnixTime = parseTimeM False defaultTimeLocale "%s" . show + parseConnection = withText "Connection" \case + "o" -> pure Offline + "m" -> pure Mobile + "w" -> Wifi <$> v .:? "SSID" <*> v .:? "BSSID" + fromBase64 v = case decodeBase64Untyped (encodeUtf8 v) of + Right bytes -> pure bytes + Left err -> fail $ "image field could not be read: " <> T.unpack err diff --git a/lib/OwnTracks/Status.hs b/lib/OwnTracks/Status.hs new file mode 100644 index 0000000..c87e28b --- /dev/null +++ b/lib/OwnTracks/Status.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE RecordWildCards #-} + + +module OwnTracks.Status +-- | https://owntracks.org/booklet/tech/json/ + (Status(..)) where + +import Data.Aeson +import Data.Aeson.Types (Parser) +import Data.ByteString (ByteString) +import Data.ByteString.Base64 +import Data.Data (Proxy (..)) +import Data.Functor ((<&>)) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Data.Time (UTCTime, defaultTimeLocale, parseTimeM) +import GHC.Generics (Generic) + + +-- | An owntracks message with _type=status. +-- +-- Currently only implements android-specific fields. +data Status = Status + { statusId :: Maybe Text + -- ^ random identifier to be used by consumers to correlate & distinguish send/return messages (Android/string) + , statusCanHibernate :: Maybe Int + -- ^ app can hibernate if not used (Android/integer) + , statusBatteryOptimizations :: Maybe Int + -- ^ app is configured with battery optimizations (Android/integer) + , statusLocationPermission :: Maybe Int + -- ^ app location permissions (Android/integer) + , statusPhonePowerSaveMode :: Maybe Int + -- ^ phone power save mode (Android/integer) + , statusWifiOnOff :: Maybe Int + -- ^ wifi is on/off (Android/integer) + } deriving (Generic, Eq, Show) + +instance FromJSON Status where + parseJSON (Object v) = do + a <- v .:? "android" + Status + <$> v .:? "_id" + <*> a .:?? "hib" + <*> a .:?? "bo" + <*> a .:?? "loc" + <*> a .:?? "ps" + <*> a .:?? "wifi" + where + (.:??) :: FromJSON a => Maybe Object -> Data.Aeson.Key -> Parser (Maybe a) + (.:??) Nothing = const $ pure Nothing + (.:??) (Just a) = (.:?) a + +instance ToJSON Status where + toJSON Status{..} = object + [ "_id" .= statusId + , "hib" .= statusCanHibernate + , "bo" .= statusBatteryOptimizations + , "loc" .= statusLocationPermission + , "ps" .= statusPhonePowerSaveMode + , "wifi" .= statusWifiOnOff + ] + + toEncoding Status{..} = + pairs ("_id" .= statusId + <> "hib" .= statusCanHibernate + <> "bo" .= statusBatteryOptimizations + <> "loc" .= statusLocationPermission + <> "ps" .= statusPhonePowerSaveMode + <> "wifi" .= statusWifiOnOff + ) diff --git a/lib/OwnTracks/Waypoint.hs b/lib/OwnTracks/Waypoint.hs new file mode 100644 index 0000000..002baa0 --- /dev/null +++ b/lib/OwnTracks/Waypoint.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} + +module OwnTracks.Waypoint +-- | https://owntracks.org/booklet/tech/json/ + (Waypoint(..)) where + +import Data.Aeson +import Data.Aeson.Types (Parser) +import Data.ByteString (ByteString) +import Data.ByteString.Base64 +import Data.Functor ((<&>)) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import Data.Time (UTCTime, defaultTimeLocale, formatTime, + parseTimeM) +import Database.Persist +import GHC.Generics (Generic) + + +data Waypoint = Waypoint + { waypointDescription :: Text + -- ^ Name of the waypoint that is included in the sent transition message, copied into the location message inregions array when a current position is within a region. (iOS,Android,string/required) + , waypointLatitude :: Maybe Double + -- ^ Latitude (iOS,Android/float/degree/optional) + , waypointLongitude :: Maybe Double + -- ^ Longitude (iOS,Android/float/degree/optional) + , waypointRadius :: Maybe Int + -- ^ Radius around the latitude and longitude coordinates (iOS,Android/integer/meters/optional) + , waypointTimestamp :: UTCTime + -- ^ Timestamp of creation of region, copied into the wtst element of the transition message (iOS,Android/integer/epoch/required) + , waypointUUID :: Maybe Text + -- ^ UUID of the BLE Beacon (iOS/string/optional) + , waypointBLEMajor :: Maybe Int + -- ^ Major number of the BLE Beacon (iOS/integer/optional) + , waypointBLEMinor :: Maybe Int + -- ^ Minor number of the BLE Beacon_(iOS/integer/optional)_ + , waypointRegionId :: Maybe Text + -- ^ region ID, created automatically, copied into the location payload inrids array (iOS/string) + } deriving (Show, Eq, Generic) + +instance FromJSON Waypoint where + parseJSON (Object o) = Waypoint + <$> o .: "desc" + <*> o .:? "lat" + <*> o .:? "lon" + <*> o .:? "rad" + <*> (o .: "tst" >>= parseUnixTime) + <*> o .:? "uuid" + <*> o .:? "major" + <*> o .:? "minor" + <*> o .:? "rid" + where parseUnixTime :: Int -> Parser UTCTime + parseUnixTime = parseTimeM False defaultTimeLocale "%s" . show + +instance ToJSON Waypoint where + toJSON Waypoint{..} = object + [ "desc" .= waypointDescription + , "lat" .= waypointLatitude + , "lon" .= waypointLongitude + , "rad" .= waypointRadius + , "tst" .= formatTime defaultTimeLocale "%s" waypointTimestamp + , "uuid" .= waypointUUID + , "major" .= waypointBLEMajor + , "minor" .= waypointBLEMinor + , "rid" .= waypointRegionId + ] diff --git a/lib/Persist.hs b/lib/Persist.hs index a8ed15e..6f459fc 100644 --- a/lib/Persist.hs +++ b/lib/Persist.hs @@ -1,42 +1,42 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- | Data types that are or might yet be saved in the database, and possibly -- also a few little convenience functions for using persistent. module Persist where -import Data.Aeson (FromJSON, ToJSON, ToJSONKey) +import Data.Aeson (FromJSON, ToJSON, ToJSONKey, + Value) import Data.Swagger (ToParamSchema (..), ToSchema (..), genericDeclareNamedSchema) import Data.Text (Text) import Data.UUID (UUID) import Database.Persist -import Database.Persist.Sql (PersistFieldSql, +import Database.Persist.Sql (PersistFieldSql (..), runSqlPersistMPool) import Database.Persist.TH -import GTFS +import qualified GTFS import PersistOrphans -import Servant (FromHttpApiData (..), +import Servant (FromHttpApiData (..), Handler, ToHttpApiData) -import Conduit (ResourceT) +import Conduit (MonadTrans (lift), MonadUnliftIO, + ResourceT, runResourceT) +import Config (LoggingConfig) import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Logger (NoLoggingT) -import Control.Monad.Reader (ReaderT) +import Control.Monad.Logger (LoggingT, MonadLogger, NoLoggingT, + runNoLoggingT, runStderrLoggingT) +import Control.Monad.Reader (MonadReader (ask), + ReaderT (runReaderT), runReader) +import Control.Monad.Trans.Control (MonadBaseControl (liftBaseWith), + MonadTransControl (liftWith, restoreT)) import Data.Data (Proxy (..)) +import Data.Map (Map) import Data.Pool (Pool) import Data.Time (NominalDiffTime, TimeOfDay, UTCTime (utctDay), addUTCTime, @@ -44,91 +44,204 @@ import Data.Time (NominalDiffTime, TimeOfDay, getCurrentTime, nominalDay) import Data.Time.Calendar (Day, DayOfWeek (..)) import Data.Vector (Vector) -import Database.Persist.Postgresql (SqlBackend) +import Database.Persist.Postgresql (SqlBackend, runSqlPool) import Fmt import GHC.Generics (Generic) +import MultiLangText (MultiLangText) +import qualified OwnTracks +import Server.Util (runLogging) import Web.PathPieces (PathPiece) +import Yesod (Lang) -newtype Token = Token UUID - deriving newtype - ( Show, ToJSON, FromJSON, Eq, Ord, FromHttpApiData - , ToJSONKey, PersistField, PersistFieldSql, PathPiece - , ToHttpApiData, Read ) -instance ToSchema Token where - declareNamedSchema _ = declareNamedSchema (Proxy @String) -instance ToParamSchema Token where - toParamSchema _ = toParamSchema (Proxy @String) +-- newtype TrackerId = TrackerId UUID +-- deriving newtype +-- ( Show, ToJSON, FromJSON, Eq, Ord, FromHttpApiData +-- , ToJSONKey, PersistField, PersistFieldSql, PathPiece +-- , ToHttpApiData, Read ) +-- instance ToSchema TrackerId where +-- declareNamedSchema _ = declareNamedSchema (Proxy @String) +-- instance ToParamSchema TrackerId where +-- toParamSchema _ = toParamSchema (Proxy @String) -deriving newtype instance PersistField Seconds -deriving newtype instance PersistFieldSql Seconds --- deriving newtype instance PathPiece Seconds --- deriving newtype instance ToParamSchema Seconds +deriving newtype instance PersistField GTFS.Seconds +deriving newtype instance PersistFieldSql GTFS.Seconds -data AmendmentStatus = Cancelled | Added | PartiallyCancelled Int Int - deriving (ToJSON, FromJSON, Generic, Show, Read, Eq) -derivePersistField "AmendmentStatus" +instance PersistField GTFS.Time where + toPersistValue :: GTFS.Time -> PersistValue + toPersistValue (GTFS.Time seconds zone) = toPersistValue (seconds, zone) + fromPersistValue :: PersistValue -> Either Text GTFS.Time + fromPersistValue = fmap (uncurry GTFS.Time) . fromPersistValue + +instance PersistFieldSql GTFS.Time where + sqlType :: Proxy GTFS.Time -> SqlType + sqlType _ = sqlType (Proxy @(Int, Text)) + + +-- TODO: postgres actually has a native type for this +newtype Geopos = Geopos { unGeoPos :: (Double, Double) } + deriving newtype (PersistField, PersistFieldSql, Show, Eq, FromJSON, ToJSON, ToSchema) + +latitude :: Geopos -> Double +latitude = fst . unGeoPos + +longitude :: Geopos -> Double +longitude = snd . unGeoPos + +-- TODO: this is horrible. make a custom status msg type instead? +derivePersistFieldJSON "Value" + +-- We derive these here so that OwnTracks.* can become its own package eventually +derivePersistFieldJSON "OwnTracks.Status" +derivePersistFieldJSON "OwnTracks.Command" +derivePersistFieldJSON "OwnTracks.Configuration" + + +data CommandStatus = Queued | Sent + deriving (Eq, Show, Read, Generic) + +derivePersistField "CommandStatus" share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| --- | tokens which have been issued -Running sql=tt_tracker_token - Id Token default=uuid_generate_v4() - expires UTCTime - blocked Bool - trip Text +Ticket sql=tt_ticket + Id UUID default=uuid_generate_v4() + tripName Text day Day + imported UTCTime + schedule_version ImportId Maybe vehicle Text Maybe + completed Bool + headsign Text + shape ShapeId + +Import sql=tt_imports + url Text + date UTCTime + +Stop sql=tt_stop + ticket TicketId OnDeleteCascade OnUpdateCascade + station StationId + arrival GTFS.Time + departure GTFS.Time + sequence Int + +Station sql=tt_station + geopos Geopos + shortName Text + name Text + +ShapePoint sql=tt_shape_point + geopos Geopos + index Int + shape ShapeId + +Shape sql=tt_shape + +-- | trackerIds which have been issued +Tracker sql=tt_tracker + Id UUID default=uuid_generate_v4() + name Text Unique +-- expires UTCTime + blocked Bool agent Text + currentTicket TicketId Maybe + configVersion Int Maybe deriving Eq Show Generic +TrackerStatus sql=tt_tracker_status + tracker TrackerId + timestamp UTCTime + status OwnTracks.Status + +TrackerTicket + ticket TicketId OnDeleteCascade OnUpdateCascade + tracker TrackerId OnDeleteCascade OnUpdateCascade + UniqueTrackerTicket ticket tracker + +-- owntracks commands enqueued, to be sent to a tracker on next contact +TrackerCommand sql=tt_tracker_command + tracker TrackerId + timestamp UTCTime + status CommandStatus + command OwnTracks.Command + deriving Show Eq + +TrackerConfig sql=tt_tracker_config + tracker TrackerId + timestamp UTCTime + seen Bool + configuration OwnTracks.Configuration + deriving Show Eq + -- raw frames as received from OBUs -TrainPing json sql=tt_trip_ping - token RunningId - lat Double - long Double +Ping json sql=tt_trip_ping + ticket TicketId Maybe OnDeleteCascade OnUpdateCascade + trackerId TrackerId OnDeleteSetNull OnUpdateCascade + geopos Geopos + -- accuracy Int Maybe + -- altitute Int Maybe + -- battery Int Maybe + -- TODO timestamp UTCTime + sequence Double Maybe deriving Show Generic Eq -- status of a train somewhen in time (may be in the future), -- inferred from trainpings / entered via controlRoom TrainAnchor json sql=tt_trip_anchor - trip TripID - day Day + ticket TicketId OnDeleteCascade OnUpdateCascade created UTCTime - when Seconds + when GTFS.Seconds sequence Double - delay Seconds - msg Text Maybe + delay GTFS.Seconds + msg MultiLangText Maybe deriving Show Generic Eq -- TODO: multi-language support? +-- announcements for the gtfs realtime Announcement json sql=tt_announcements Id UUID default=uuid_generate_v4() - trip TripID + ticket TicketId OnDeleteCascade OnUpdateCascade header Text message Text - day Day url Text Maybe announcedAt UTCTime Maybe deriving Generic Show --- | this table works as calendar_dates.txt in GTFS -ScheduleAmendment json sql=tt_schedule_amendement - trip TripID - day Day - status AmendmentStatus - -- only one special rule per TripID and Day (else incoherent) - TripAndDay trip day +TickerAnnouncement json sql=tt_ticker + header Text + message Text + archived Bool + created UTCTime + deriving Generic Show |] -instance ToSchema RunningId where +instance ToSchema TicketId where + declareNamedSchema _ = declareNamedSchema (Proxy @UUID) +instance ToSchema TrackerId where declareNamedSchema _ = declareNamedSchema (Proxy @UUID) -instance ToSchema TrainPing where - declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "trainPing") +instance ToSchema Ping where + declareNamedSchema = genericDeclareNamedSchema (GTFS.swaggerOptions "ping") instance ToSchema TrainAnchor where - declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "trainAnchor") + declareNamedSchema = genericDeclareNamedSchema (GTFS.swaggerOptions "trainAnchor") instance ToSchema Announcement where - declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "announcement") + declareNamedSchema = genericDeclareNamedSchema (GTFS.swaggerOptions "announcement") + +type InSql a = ReaderT SqlBackend (LoggingT (ResourceT IO)) a + +runSqlWithoutLog :: MonadIO m + => Pool SqlBackend + -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a + -> m a +runSqlWithoutLog pool = liftIO . flip runSqlPersistMPool pool -runSql :: MonadIO m => Pool SqlBackend -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> m a -runSql pool = liftIO . flip runSqlPersistMPool pool +-- It's a bit unfortunate that we have an extra reader here for just the +-- logging config, but since Handler is not MonadUnliftIO there seems to be (?) +-- no better way than to nest logger monads … +runSql :: (MonadLogger m, MonadIO m, MonadReader LoggingConfig m) + => Pool SqlBackend + -> InSql a + -> m a +runSql pool x = do + conf <- ask + liftIO $ runResourceT $ runLogging conf $ runSqlPool x pool diff --git a/lib/Server.hs b/lib/Server.hs index eff1807..3cff4c5 100644 --- a/lib/Server.hs +++ b/lib/Server.hs @@ -1,231 +1,125 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} -- Implementation of the API. This module is the main point of the program. module Server (application) where -import Control.Concurrent.STM (TQueue, TVar, atomically, - newTQueue, newTVar, newTVarIO, - readTQueue, readTVar, writeTQueue, - writeTVar) -import Control.Monad (forever, unless, void, when) -import Control.Monad.Catch (handle) -import Control.Monad.Extra (ifM, maybeM, unlessM, whenJust, - whenM) +import API (API, CompleteAPI, Metrics (..)) +import Conduit (ResourceT) +import Config (LoggingConfig, ServerConfig (..)) +import Control.Concurrent.STM (newTVarIO) +import Control.Monad.Extra (forM, when) import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Logger (LoggingT, logWarnN) -import Control.Monad.Reader (forM) -import Control.Monad.Trans (lift) -import Data.Aeson ((.=)) +import Control.Monad.Logger (MonadLogger, logWarnN) +import Control.Monad.Reader (ReaderT) import qualified Data.Aeson as A -import qualified Data.ByteString.Char8 as C8 -import Data.Coerce (coerce) +import Data.ByteString.Lazy (toStrict) import Data.Functor ((<&>)) import qualified Data.Map as M import Data.Pool (Pool) import Data.Proxy (Proxy (Proxy)) -import Data.Swagger (toSchema) -import Data.Text (Text) import Data.Text.Encoding (decodeUtf8) -import Data.Time (NominalDiffTime, - UTCTime (utctDay), addUTCTime, - diffUTCTime, getCurrentTime, - nominalDay) -import qualified Data.Vector as V -import Database.Persist -import Database.Persist.Postgresql (SqlBackend, runMigration) +import Data.Time (getCurrentTime) +import Data.UUID (UUID) +import Database.Persist (Entity (..), + PersistQueryRead (selectFirst), + SelectOpt (Desc), selectList, + (<-.), (==.), (>=.), (||.)) +import Database.Persist.Postgresql (SqlBackend, + migrateEnableExtension, + runMigration) import Fmt ((+|), (|+)) -import qualified Network.WebSockets as WS -import Servant (Application, - ServerError (errBody), err401, - err404, serve, - serveDirectoryFileServer, +import qualified GTFS +import Persist +import Prometheus (Info (Info), exportMetricsAsText, + gauge, register) +import Prometheus.Metric.GHC (ghcMetrics) +import Servant (Application, err401, serve, throwError) -import Servant.API (NoContent (..), (:<|>) (..)) -import Servant.Server (Handler, hoistServer) +import Servant.API ((:<|>) (..)) +import Servant.Server (hoistServer) import Servant.Swagger (toSwagger) - -import API -import GTFS -import Persist -import Server.ControlRoom +import Server.Base (ServerState) +import Server.Frontend (Frontend (..)) import Server.GTFS_RT (gtfsRealtimeServer) -import Server.Util (Service, ServiceM, runService, - sendErrorMsg) +import Server.Ingest (handleOwntracksMessage, + handlePing, handleTrackerRegister, + handleWS) +import Server.Subscribe (handleSubscribe) +import Server.Util (Service, runLogging, runService, + serveDirectoryFileServer) +import System.IO.Unsafe (unsafePerformIO) import Yesod (toWaiAppPlain) -import Extrapolation (Extrapolator (..), - LinearExtrapolator (..)) -import System.IO.Unsafe - -import Config (ServerConfig (serverConfigAssets)) -import Data.ByteString (ByteString) -import Data.ByteString.Lazy (toStrict) -import Prometheus -import Prometheus.Metric.GHC -application :: GTFS -> Pool SqlBackend -> ServerConfig -> IO Application +application :: GTFS.GTFS -> Pool SqlBackend -> ServerConfig -> IO Application application gtfs dbpool settings = do + when (serverConfigDebugMode settings) $ + runLogging (serverConfigLogging settings) $ + logWarnN "warning: tracktrain running in debug mode" doMigration dbpool metrics <- Metrics <$> register (gauge (Info "ws_connections" "Number of WS Connections")) register ghcMetrics + subscribers <- newTVarIO mempty - pure $ serve (Proxy @CompleteAPI) $ hoistServer (Proxy @CompleteAPI) runService $ server gtfs metrics subscribers dbpool settings + pure $ serve (Proxy @CompleteAPI) + $ hoistServer (Proxy @CompleteAPI) (runService (serverConfigLogging settings)) + $ server gtfs metrics subscribers dbpool settings --- databaseMigration :: ConnectionString -> IO () -doMigration pool = runSql pool $ - -- TODO: before that, check if the uuid module is enabled - -- in sql: check if SELECT * FROM pg_extension WHERE extname = 'uuid-ossp'; - -- returns an empty list - runMigration migrateAll +doMigration pool = runSqlWithoutLog pool $ runMigration $ do + migrateEnableExtension "uuid-ossp" + migrateAll -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 :<|> handleTimetableStops :<|> handleTrip - :<|> handleRegister :<|> handleTrainPing (throwError err401) :<|> handleWS - :<|> handleSubscribe :<|> handleDebugState :<|> handleDebugTrain - :<|> handleDebugRegister :<|> pure gtfsFile :<|> gtfsRealtimeServer gtfs dbpool) - :<|> metrics +server + :: GTFS.GTFS + -> Metrics + -> ServerState + -> Pool SqlBackend + -> ServerConfig + -> Service CompleteAPI +server gtfs metrics@Metrics{..} subscribers dbpool settings = {- handleDebugAPI + :<|> -} (handleTrackerRegister dbpool + :<|> handlePing dbpool subscribers settings (throwError err401) + :<|> handleWS dbpool subscribers settings metrics + :<|> handleCurrentTicker + :<|> handleSubscribe dbpool subscribers + :<|> handleDebugState :<|> handleDebugTrain + :<|> pure (GTFS.gtfsFile gtfs) :<|> gtfsRealtimeServer settings gtfs dbpool + :<|> owntracksServer) + :<|> handleMetrics :<|> serveDirectoryFileServer (serverConfigAssets settings) - :<|> pure (unsafePerformIO (toWaiAppPlain (ControlRoom gtfs dbpool settings))) - where handleStations = pure stations - 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 - , "sequencelength" .= (stopSequence . V.last) tripStops - , "stops" .= fmap (\Stop{..} -> A.object - [ "departure" .= toUTC stopDeparture tzseries day - , "arrival" .= toUTC stopArrival tzseries day - , "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 - handleRegister tripID RegisterJson{..} = do - today <- liftIO getCurrentTime <&> utctDay - unless (runsOnDay gtfs tripID today) - $ sendErrorMsg "this trip does not run today." - expires <- liftIO $ getCurrentTime <&> addUTCTime validityPeriod - RunningKey token <- runSql dbpool $ insert (Running expires False tripID today Nothing registerAgent) - pure token - handleDebugRegister tripID day = do - expires <- liftIO $ getCurrentTime <&> addUTCTime validityPeriod - RunningKey token <- runSql dbpool $ insert (Running expires False tripID day Nothing "debug key") - pure token - handleTrainPing onError ping = isTokenValid dbpool (coerce $ trainPingToken ping) >>= \case - Nothing -> do - onError - pure Nothing - Just running@Running{..} -> do - let anchor = extrapolateAnchorFromPing LinearExtrapolator gtfs running ping - -- TODO: are these always inserted in order? - runSql dbpool $ do - insert ping - last <- selectFirst - [TrainAnchorTrip ==. runningTrip, TrainAnchorDay ==. runningDay] - [Desc TrainAnchorWhen] - -- only insert new estimates if they've actually changed anything - when (fmap (trainAnchorDelay . entityVal) last /= Just (trainAnchorDelay anchor)) - $ void $ insert anchor - queues <- liftIO $ atomically $ do - queues <- readTVar subscribers <&> M.lookup runningTrip - whenJust queues $ - mapM_ (\q -> writeTQueue q (Just ping)) - pure queues - pure (Just anchor) - handleWS conn = do - liftIO $ WS.forkPingThread conn 30 - incGauge metricsWSGauge - handle (\(e :: WS.ConnectionException) -> decGauge metricsWSGauge) $ forever $ do - msg <- liftIO $ WS.receiveData conn - case A.eitherDecode msg of - Left err -> do - logWarnN ("stray websocket message: "+|show msg|+" (could not decode: "+|err|+")") - liftIO $ WS.sendClose conn (C8.pack err) - -- TODO: send a close msg (Nothing) to the subscribed queues? decGauge metricsWSGauge - Right ping -> - -- if invalid token, send a "polite" close request. Note that the client may - -- ignore this and continue sending messages, which will continue to be handled. - liftIO $ handleTrainPing (WS.sendClose conn ("" :: ByteString)) ping >>= \case - Just anchor -> WS.sendTextData conn (A.encode anchor) - Nothing -> pure () - handleSubscribe tripId day conn = liftIO $ WS.withPingThread conn 30 (pure ()) $ do - queue <- atomically $ do - queue <- newTQueue - qs <- readTVar subscribers - writeTVar subscribers - $ M.insertWith (<>) tripId [queue] qs - pure queue - -- send most recent ping, if any (so we won't have to wait for movement) - lastPing <- runSql dbpool $ do - tokens <- selectList [RunningDay ==. day, RunningTrip ==. tripId] [] - <&> fmap entityKey - selectFirst [TrainPingToken <-. tokens] [Desc TrainPingTimestamp] - <&> fmap entityVal - whenJust lastPing $ \ping -> - WS.sendTextData conn (A.encode lastPing) - handle (\(e :: WS.ConnectionException) -> removeSubscriber queue) $ forever $ do - res <- atomically $ readTQueue queue - case res of - Just ping -> WS.sendTextData conn (A.encode ping) - Nothing -> do - removeSubscriber queue - WS.sendClose conn (C8.pack "train ended") - where removeSubscriber queue = atomically $ do - qs <- readTVar subscribers - writeTVar subscribers - $ M.adjust (filter (/= queue)) tripId qs - handleDebugState = do - now <- liftIO getCurrentTime - runSql dbpool $ do - running <- selectList [RunningBlocked ==. False, RunningExpires >=. now] [] - pairs <- forM running $ \(Entity token@(RunningKey uuid) _) -> do - entities <- selectList [TrainPingToken ==. token] [] - pure (uuid, fmap entityVal entities) - pure (M.fromList pairs) - handleDebugTrain tripId day = do - unless (runsOnDay gtfs tripId day) - $ sendErrorMsg ("this trip does not run on "+|day|+".") - runSql dbpool $ do - tokens <- selectList [RunningTrip ==. tripId, RunningDay ==. day] [] - pings <- forM tokens $ \(Entity token _) -> do - selectList [TrainPingToken ==. token] [] <&> fmap entityVal - pure (concat pings) - handleDebugAPI = pure $ toSwagger (Proxy @API) - metrics = exportMetricsAsText <&> (decodeUtf8 . toStrict) - - --- TODO: proper debug logging for expired tokens -isTokenValid :: MonadIO m => Pool SqlBackend -> Token -> m (Maybe Running) -isTokenValid dbpool token = runSql dbpool $ get (coerce token) >>= \case - Just trip | not (runningBlocked trip) -> do - ifM (hasExpired (runningExpires trip)) - (pure Nothing) - (pure (Just trip)) - _ -> pure Nothing - -hasExpired :: MonadIO m => UTCTime -> m Bool -hasExpired limit = do - now <- liftIO getCurrentTime - pure (now > limit) + :<|> pure (unsafePerformIO (toWaiAppPlain (Frontend gtfs dbpool settings))) + where + handleDebugState = do + now <- liftIO getCurrentTime + runSql dbpool $ do + tracker <- selectList [TrackerBlocked ==. False] [] --, TrackerExpires >=. now] [] + pairs <- forM tracker $ \(Entity trackerId@(TrackerKey uuid) _) -> do + entities <- selectList [PingTrackerId ==. trackerId] [] + pure (uuid, fmap entityVal entities) + pure (M.fromList pairs) + handleCurrentTicker = runSql dbpool $ do + selectFirst [ TickerAnnouncementArchived ==. False ] [] <&> \case + Nothing -> A.object [ "error" A..= A.String "no message" ] + Just (Entity _ TickerAnnouncement{..}) -> A.object + [ "error" A..= A.Null + , "message" A..= tickerAnnouncementMessage + , "header" A..= tickerAnnouncementHeader + ] + handleDebugTrain ticketId = runSql dbpool $ do + trackers <- getTicketTrackers ticketId + pings <- forM trackers $ \(Entity trackerId _) -> do + selectList [PingTrackerId ==. trackerId] [] <&> fmap entityVal + pure (concat pings) + -- handleDebugAPI = pure $ toSwagger (Proxy @API) + handleMetrics = exportMetricsAsText <&> (decodeUtf8 . toStrict) + owntracksServer u d location = handleOwntracksMessage dbpool subscribers settings u d location -validityPeriod :: NominalDiffTime -validityPeriod = nominalDay +getTicketTrackers :: (MonadLogger (t (ResourceT IO)), MonadIO (t (ResourceT IO))) + => UUID -> ReaderT SqlBackend (t (ResourceT IO)) [Entity Tracker] +getTicketTrackers ticketId = do + joins <- selectList [TrackerTicketTicket ==. TicketKey ticketId] [] + <&> fmap (trackerTicketTracker . entityVal) + selectList ([TrackerId <-. joins] ||. [TrackerCurrentTicket ==. Just (TicketKey ticketId)]) [] diff --git a/lib/Server/Base.hs b/lib/Server/Base.hs new file mode 100644 index 0000000..17b5b4a --- /dev/null +++ b/lib/Server/Base.hs @@ -0,0 +1,9 @@ + +module Server.Base (ServerState) where + +import Control.Concurrent.STM (TQueue, TVar) +import qualified Data.Map as M +import Data.UUID (UUID) +import Persist (Ping) + +type ServerState = TVar (M.Map UUID [TQueue (Maybe Ping)]) diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs deleted file mode 100644 index 402f0b8..0000000 --- a/lib/Server/ControlRoom.hs +++ /dev/null @@ -1,446 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -module Server.ControlRoom (ControlRoom(..)) where - -import Control.Monad (forM_, join) -import Control.Monad.Extra (maybeM) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import qualified Data.Aeson as A -import qualified Data.ByteString.Char8 as C8 -import qualified Data.ByteString.Lazy as LB -import Data.Functor ((<&>)) -import Data.List (lookup) -import Data.List.NonEmpty (nonEmpty) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Pool (Pool) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time (UTCTime (..), addDays, - getCurrentTime, utctDay) -import Data.Time.Calendar (Day) -import Data.Time.Format.ISO8601 (iso8601Show) -import Data.UUID (UUID) -import qualified Data.UUID as UUID -import qualified Data.Vector as V -import Database.Persist (Entity (..), delete, entityVal, get, - insert, selectList, (==.)) -import Database.Persist.Sql (PersistFieldSql, SqlBackend, - runSqlPool) -import Fmt ((+|), (|+)) -import GHC.Float (int2Double) -import GHC.Generics (Generic) -import Server.Util (Service, secondsNow) -import Text.Blaze.Html (ToMarkup (..)) -import Text.Blaze.Internal (MarkupM (Empty)) -import Text.Read (readMaybe) -import Text.Shakespeare.Text -import Yesod -import Yesod.Auth -import Yesod.Auth.OAuth2.Prelude -import Yesod.Form - -import Config (ServerConfig (..), UffdConfig (..)) -import Extrapolation (Extrapolator (..), - LinearExtrapolator (..)) -import GTFS -import Numeric (showFFloat) -import Persist -import Yesod.Auth.OpenId (IdentifierType (..), authOpenId) -import Yesod.Auth.Uffd (UffdUser (..), uffdClient) -import Yesod.Orphans () - - -data ControlRoom = ControlRoom - { getGtfs :: GTFS - , getPool :: Pool SqlBackend - , getSettings :: ServerConfig - } - -mkMessage "ControlRoom" "messages" "en" - -mkYesod "ControlRoom" [parseRoutes| -/ RootR GET -/auth AuthR Auth getAuth -/trains TrainsR GET -/train/id/#TripID/#Day TrainViewR GET -/train/map/#TripID/#Day TrainMapViewR GET -/train/announce/#TripID/#Day AnnounceR POST -/train/del-announce/#UUID DelAnnounceR GET -/token/block/#Token TokenBlock GET -/trips TripsViewR GET -/trip/#TripID TripViewR GET -/obu OnboardUnitMenuR GET -/obu/#TripID/#Day OnboardUnitR GET -|] - -emptyMarkup :: MarkupM a -> Bool -emptyMarkup (Empty _) = True -emptyMarkup _ = False - -instance Yesod ControlRoom where - authRoute _ = Just $ AuthR LoginR - isAuthorized OnboardUnitMenuR _ = pure Authorized - isAuthorized (OnboardUnitR _ _) _ = pure Authorized - isAuthorized (AuthR _) _ = pure Authorized - isAuthorized _ _ = do - UffdConfig{..} <- getYesod <&> getSettings <&> serverConfigLogin - if uffdConfigEnable then maybeAuthId >>= \case - Just _ -> pure Authorized - Nothing -> pure AuthenticationRequired - else pure Authorized - - - defaultLayout w = do - PageContent{..} <- widgetToPageContent w - msgs <- getMessages - - withUrlRenderer [hamlet| - $newline never - $doctype 5 - <html> - <head> - <title> - $if emptyMarkup pageTitle - Tracktrain - $else - #{pageTitle} - $maybe description <- pageDescription - <meta name="description" content="#{description}"> - ^{pageHead} - <link rel="stylesheet" href="/assets/style.css"> - <body> - $forall (status, msg) <- msgs - <!-- <p class="message #{status}">#{msg} --> - ^{pageBody} - |] - - -instance RenderMessage ControlRoom FormMessage where - renderMessage _ _ = defaultFormMessage - -instance YesodPersist ControlRoom where - type YesodPersistBackend ControlRoom = SqlBackend - runDB action = do - pool <- getYesod <&> getPool - runSqlPool action pool - - --- this instance is only slightly cursed (it keeps login information --- as json in a session cookie and hopes nothing will ever go wrong) -instance YesodAuth ControlRoom where - type AuthId ControlRoom = UffdUser - - authPlugins cr = case config of - UffdConfig {..} -> if uffdConfigEnable - then [ uffdClient uffdConfigUrl uffdConfigClientName uffdConfigClientSecret ] - else [] - where config = serverConfigLogin (getSettings cr) - - maybeAuthId = do - e <- lookupSession "json" - pure $ case e of - Nothing -> Nothing - Just extra -> A.decode (LB.fromStrict $ C8.pack $ T.unpack extra) - - authenticate creds = do - forM_ (credsExtra creds) (uncurry setSession) - -- extra <- lookupSession "extra" - -- pure (Authenticated ( undefined)) - e <- lookupSession "json" - case e of - Nothing -> error "no session information" - Just extra -> case A.decode (LB.fromStrict $ C8.pack $ T.unpack extra) of - Nothing -> error "malformed session information" - Just user -> pure $ Authenticated user - - loginDest _ = RootR - logoutDest _ = RootR - -- hardcode redirecting to uffd directly; showing the normal login - -- screen is kinda pointless when there's only one option - loginHandler = do - redirect ("/auth/page/uffd/forward" :: Text) - onLogout = do - clearSession - - - - -getRootR :: Handler Html -getRootR = redirect TrainsR - -getTrainsR :: Handler Html -getTrainsR = do - req <- getRequest - let maybeDay = lookup "day" (reqGetParams req) >>= (readMaybe . T.unpack) - mdisplayname <- maybeAuthId <&> fmap uffdDisplayName - - (day, isToday) <- liftIO $ getCurrentTime <&> utctDay <&> \today -> - case maybeDay of - Just day -> (day, day == today) - Nothing -> (today, True) - - let prevday = (T.pack . iso8601Show . addDays (-1)) day - let nextday = (T.pack . iso8601Show . addDays 1) day - gtfs <- getYesod <&> getGtfs - let trips = tripsOnDay gtfs day - defaultLayout $ do - [whamlet| -<h1> _{MsgTrainsOnDay (iso8601Show day)} -$maybe name <- mdisplayname - <p>_{MsgLoggedInAs name} - <a href="@{AuthR LogoutR}">_{MsgLogout}</a> -<nav> - <a class="nav-left" href="@?{(TrainsR, [("day", prevday)])}">← #{prevday} - $if isToday - _{Msgtoday} - $else - <a href="@{TrainsR}">_{Msgtoday} - <a class="nav-right" href="@?{(TrainsR, [("day", nextday)])}">#{nextday} → -<section> - <ol> - $forall trip@Trip{..} <- trips - <li><a href="@{TrainViewR tripTripID day}">_{MsgTrip} #{tripName trip}</a> - : _{Msgdep} #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))} - $if null trips - <li style="text-align: center"><em>(_{MsgNone}) -|] - -getTrainViewR :: TripID -> Day -> Handler Html -getTrainViewR trip day = do - GTFS{..} <- getYesod <&> getGtfs - (widget, enctype) <- generateFormPost (announceForm day trip) - case M.lookup trip trips of - Nothing -> notFound - Just res@Trip{..} -> do - anns <- runDB $ selectList [ AnnouncementTrip ==. trip, AnnouncementDay ==. day ] [] - tokens <- runDB $ selectList [ RunningTrip ==. trip, RunningDay ==. day ] [Asc RunningExpires] - lastPing <- runDB $ selectFirst [ TrainPingToken <-. fmap entityKey tokens ] [Desc TrainPingTimestamp] - anchors <- runDB $ selectList [ TrainAnchorTrip ==. trip, TrainAnchorDay ==. day ] [] - <&> nonEmpty . fmap entityVal - nowSeconds <- secondsNow day - defaultLayout $ do - mr <- getMessageRender - setTitle (toHtml (""+|mr MsgTrip|+" "+|tripTripID|+" "+|mr Msgon|+" "+|day|+"" :: Text)) - [whamlet| -<h1>_{MsgTrip} <a href="@{TripViewR tripTripID}">#{tripName res}</a> _{Msgon} <a href="@?{(TrainsR, [("day", T.pack (iso8601Show day))])}">#{day}</a> -<section> - <h2>_{MsgLive} - <p><strong>_{MsgLastPing}: </strong> - $maybe Entity _ TrainPing{..} <- lastPing - _{MsgTrainPing trainPingLat trainPingLong trainPingTimestamp} - (<a href="/api/debug/pings/#{trip}/#{day}">_{Msgraw}</a>) - $nothing - <em>(_{MsgNoTrainPing}) - <p><strong>_{MsgEstimatedDelay}</strong>: - $maybe history <- anchors - $maybe TrainAnchor{..} <- guessAtSeconds history nowSeconds - \ #{trainAnchorDelay} (_{MsgOnStationSequence (showFFloat (Just 3) trainAnchorSequence "")}) - $nothing - <em> (_{MsgNone}) - <p><a href="@{TrainMapViewR tripTripID day}">_{MsgMap}</a> -<section> - <h2>_{MsgStops} - <ol> - $forall Stop{..} <- tripStops - <li value="#{stopSequence}"> #{stopArrival} #{stationName stopStation} - $maybe history <- anchors - $maybe delay <- guessDelay history (int2Double stopSequence) - \ (#{delay}) -<section> - <h2>_{MsgAnnouncements} - <ul> - $forall Entity (AnnouncementKey uuid) Announcement{..} <- anns - <li><em>#{announcementHeader}: #{announcementMessage}</em> <a href="@{DelAnnounceR uuid}">_{Msgdelete}</a> - $if null anns - <li><em>(_{MsgNone})</em> - <h3>_{MsgNewAnnouncement} - <form method=post action=@{AnnounceR trip day} enctype=#{enctype}> - ^{widget} - <button>_{MsgSubmit} -<section> - <h2>_{MsgTokens} - <table> - <tr><th style="width: 20%">_{MsgAgent}</th><th style="width: 50%">_{MsgToken}</th><th>_{MsgExpires}</th><th>_{MsgStatus}</th> - $if null tokens - <tr><td></td><td style="text-align:center"><em>(_{MsgNone}) - $forall Entity (RunningKey key) Running{..} <- tokens - <tr :runningBlocked:.blocked> - <td title="#{runningAgent}">#{runningAgent} - <td title="#{key}">#{key} - <td title="#{runningExpires}">#{runningExpires} - $if runningBlocked - <td title="_{MsgUnblockToken}"><a href="@?{(TokenBlock key, [("unblock", "true")])}">_{MsgUnblockToken}</a> - $else - <td title="_{MsgBlockToken}"><a href="@{TokenBlock key}">_{MsgBlockToken}</a> -|] - where guessDelay history = fmap trainAnchorDelay . extrapolateAtPosition LinearExtrapolator history - guessAtSeconds = extrapolateAtSeconds LinearExtrapolator - - -getTrainMapViewR :: TripID -> Day -> Handler Html -getTrainMapViewR tripId day = do - GTFS{..} <- getYesod <&> getGtfs - (widget, enctype) <- generateFormPost (announceForm day tripId) - case M.lookup tripId trips of - Nothing -> notFound - Just res@Trip{..} -> do defaultLayout [whamlet| -<h1>_{MsgTrip} <a href="@{TrainViewR tripTripID day}">#{tripName res} _{Msgon} #{day}</a> -<link rel="stylesheet" href="https://unpkg.com/leaflet@1.9.3/dist/leaflet.css" - integrity="sha256-kLaT2GOSpHechhsozzB+flnD+zUyjE2LlfWPgU04xyI=" - crossorigin=""/> -<script src="https://unpkg.com/leaflet@1.9.3/dist/leaflet.js" - integrity="sha256-WBkoXOwTeyKclOHuWtc+i2uENFpDZ9YPdf5Hf+D7ewM=" - crossorigin=""></script> -<div id="map"> -<p id="status"> -<script> - let map = L.map('map'); - - L.tileLayer('https://tile.openstreetmap.org/{z}/{x}/{y}.png', { - attribution: '© <a href="https://www.openstreetmap.org/copyright">OpenStreetMap</a> contributors' - }).addTo(map); - - ws = new WebSocket((location.protocol == "http:" ? "ws" : "wss") + "://" + location.host + "/api/train/subscribe/#{tripTripID}/#{day}"); - - var marker = null; - - ws.onmessage = (msg) => { - let json = JSON.parse(msg.data); - if (marker === null) { - marker = L.marker([json.lat, json.long]); - marker.addTo(map); - } else { - marker.setLatLng([json.lat, json.long]); - } - map.setView([json.lat, json.long], 13); - document.getElementById("status").innerText = "_{MsgLastPing}: "+json.lat+","+json.long+" ("+json.timestamp+")"; - } -|] - - - -getTripsViewR :: Handler Html -getTripsViewR = do - GTFS{..} <- getYesod <&> getGtfs - defaultLayout $ do - setTitle "List of Trips" - [whamlet| -<h1>List of Trips -<section><ul> - $forall trip@Trip{..} <- trips - <li><a href="@{TripViewR tripTripID}">#{tripName trip}</a> - : #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))} -|] - - -getTripViewR :: TripID -> Handler Html -getTripViewR tripId = do - GTFS{..} <- getYesod <&> getGtfs - case M.lookup tripId trips of - Nothing -> notFound - Just trip@Trip{..} -> defaultLayout [whamlet| -<h1>_{MsgTrip} #{tripName trip} -<section> - <h2>_{MsgInfo} - <p><strong>_{MsgtripId}:</strong> #{tripTripID} - <p><strong>_{MsgtripHeadsign}:</strong> #{mightbe tripHeadsign} - <p><strong>_{MsgtripShortname}:</strong> #{mightbe tripShortName} -<section> - <h2>_{MsgStops} - <ol> - $forall Stop{..} <- tripStops - <div>(#{stopSequence}) #{stopArrival} #{stationName stopStation} -<section> - <h2>Dates - <ul> - TODO! -|] - - -postAnnounceR :: TripID -> Day -> Handler Html -postAnnounceR trip day = do - ((result, widget), enctype) <- runFormPost (announceForm day trip) - case result of - FormSuccess ann -> do - runDB $ insert ann - redirect (TrainViewR trip day) - _ -> defaultLayout - [whamlet| - <p>_{MsgInvalidInput}. - <form method=post action=@{AnnounceR trip day} enctype=#{enctype}> - ^{widget} - <button>_{MsgSubmit} - |] - -getDelAnnounceR :: UUID -> Handler Html -getDelAnnounceR uuid = do - ann <- runDB $ do - a <- get (AnnouncementKey uuid) - delete (AnnouncementKey uuid) - pure a - case ann of - Nothing -> notFound - Just Announcement{..} -> - redirect (TrainViewR announcementTrip announcementDay) - -getTokenBlock :: Token -> Handler Html -getTokenBlock token = do - YesodRequest{..} <- getRequest - let blocked = lookup "unblock" reqGetParams /= Just "true" - maybe <- runDB $ do - update (RunningKey token) [ RunningBlocked =. blocked ] - get (RunningKey token) - case maybe of - Just r@Running{..} -> do - liftIO $ print r - redirect (TrainViewR runningTrip runningDay) - Nothing -> notFound - -getOnboardUnitMenuR :: Handler Html -getOnboardUnitMenuR = do - day <- liftIO getCurrentTime <&> utctDay - gtfs <- getYesod <&> getGtfs - let trips = tripsOnDay gtfs day - defaultLayout $ do - [whamlet| -<h1>_{MsgOBU} -<section> - _{MsgChooseTrain} - $forall Trip{..} <- trips - <hr> - <a href="@{OnboardUnitR tripTripID day}"> - #{tripTripID}: #{stationName (stopStation (V.head tripStops))} #{stopDeparture (V.head tripStops)} -|] - -getOnboardUnitR :: TripID -> Day -> Handler Html -getOnboardUnitR tripId day = - defaultLayout $(whamletFile "site/obu.hamlet") - -announceForm :: Day -> TripID -> Html -> MForm Handler (FormResult Announcement, Widget) -announceForm day tripId = renderDivs $ Announcement - <$> pure tripId - <*> areq textField (fieldSettingsLabel MsgHeader) Nothing - <*> areq textField (fieldSettingsLabel MsgText) Nothing - <*> pure day - <*> aopt urlField (fieldSettingsLabel MsgMaybeWeblink) Nothing - <*> lift (liftIO getCurrentTime <&> Just) - -mightbe :: Maybe Text -> Text -mightbe (Just a) = a -mightbe Nothing = "" - diff --git a/lib/Server/Frontend.hs b/lib/Server/Frontend.hs new file mode 100644 index 0000000..9742c3e --- /dev/null +++ b/lib/Server/Frontend.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Server.Frontend (Frontend(..), Handler) where + +import Server.Frontend.Gtfs +import Server.Frontend.OnboardUnit +import Server.Frontend.Routes +import Server.Frontend.SpaceTime +import Server.Frontend.Ticker +import Server.Frontend.Tickets +import Server.Frontend.Tracker + +import Yesod +import Yesod.Auth + + +mkYesodDispatch "Frontend" resourcesFrontend + + +getRootR :: Handler Html +getRootR = redirect TicketsR + + diff --git a/lib/Server/Frontend/Gtfs.hs b/lib/Server/Frontend/Gtfs.hs new file mode 100644 index 0000000..bc21ab7 --- /dev/null +++ b/lib/Server/Frontend/Gtfs.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} + +module Server.Frontend.Gtfs (getGtfsTripViewR, getGtfsTripsViewR) where + +import Server.Frontend.Routes + +import Data.Functor ((<&>)) +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Vector as V +import qualified GTFS +import Text.Blaze.Html (Html) +import Yesod + +getGtfsTripsViewR :: Handler Html +getGtfsTripsViewR = do + GTFS.GTFS{..} <- getYesod <&> getGtfs + defaultLayout $ do + setTitle "List of Trips" + [whamlet| +<h1>List of Trips +<section><ul> + $forall trip@GTFS.Trip{..} <- trips + <li><a href="@{GtfsTripViewR tripTripId}">#{GTFS.tripName trip}</a> + : #{GTFS.stopDeparture (V.head tripStops)} #{GTFS.stationName (GTFS.stopStation (V.head tripStops))} +|] + + +getGtfsTripViewR :: GTFS.TripId -> Handler Html +getGtfsTripViewR tripId = do + GTFS.GTFS{..} <- getYesod <&> getGtfs + case M.lookup tripId trips of + Nothing -> notFound + Just trip@GTFS.Trip{..} -> defaultLayout [whamlet| +<h1>_{MsgTrip} #{GTFS.tripName trip} +<section> + <h2>_{MsgInfo} + <p><strong>_{MsgtripId}:</strong> #{tripTripId} + <p><strong>_{MsgtripHeadsign}:</strong> #{mightbe tripHeadsign} + <p><strong>_{MsgtripShortname}:</strong> #{mightbe tripShortName} +<section> + <h2>_{MsgStops} + <ol> + $forall GTFS.Stop{..} <- tripStops + <div>(#{stopSequence}) #{stopArrival} #{GTFS.stationName stopStation} +<section> + <h2>Dates + <ul> + TODO! +|] + +mightbe :: Maybe Text -> Text +mightbe (Just a) = a +mightbe Nothing = "" diff --git a/lib/Server/Frontend/OnboardUnit.hs b/lib/Server/Frontend/OnboardUnit.hs new file mode 100644 index 0000000..967cb6c --- /dev/null +++ b/lib/Server/Frontend/OnboardUnit.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} + +module Server.Frontend.OnboardUnit (getOnboardTrackerR) where + +import Server.Frontend.Routes + +import Data.Functor ((<&>)) +import qualified Data.Map as M +import Data.Maybe (fromJust) +import Data.Text (Text) +import Data.Time (UTCTime (..), getCurrentTime) +import Data.UUID (UUID) +import qualified Data.UUID as UUID +import qualified Data.Vector as V +import qualified GTFS +import Persist (EntityField (..), Key (..), Stop (..), + Ticket (..)) +import Text.Blaze.Html (Html) +import Yesod + + +getOnboardTrackerR :: Handler Html +getOnboardTrackerR = do defaultLayout [whamlet| + <h1>_{MsgOBU} + + <section> + <h2>Tracker + <strong>TrackerId:</strong> <span id="trackerId"> + <section> + <h2>Status + <p id="status">_{MsgNone} + <p id>_{MsgError}: <span id="error"> + <section> + <h2>_{MsgLive} + <p><strong>Position: </strong><span id="lat"></span>, <span id="long"></span> + <p><strong>Accuracy: </strong><span id="acc"> + <section> + <h2>_{MsgEstimated} + <p><strong>_{MsgDelay}</strong>: <span id="delay"> + <p><strong>_{MsgSequence}</strong>: <span id="sequence"> + + + <script> + var trackerId = null; + + let euclid = (a,b) => { + let x = a[0]-b[0]; + let y = a[1]-b[1]; + return x*x+y*y; + } + + let minimalDist = (point, list, proj, norm) => { + return list.reduce ( + (min, x) => { + let dist = norm(point, proj(x)); + return dist < min[0] ? [dist,x] : min + }, + [norm(point, proj(list[0])), list[0]] + )[1] + } + + let counter = 0; + let ws; + let id; + + function setStatus(msg) { + document.getElementById("status").innerText = msg + } + + async function geoError(error) { + setStatus("error"); + alert(`_{MsgPermissionFailed}: \n${error.message}`); + console.error(error); + main(); + } + + async function wsError(error) { + // alert(`_{MsgWebsocketError}: \n${error.message === undefined ? error.reason : error.message}`); + console.log(error); + navigator.geolocation.clearWatch(id); + } + + async function wsClose(error) { + console.log(error); + document.getElementById("error").innerText = `websocket closed (reason: ${error.reason}). reconnecting …`; + navigator.geolocation.clearWatch(id); + setTimeout(openWebsocket, 1000); + } + + function wsMsg(msg) { + let json = JSON.parse(msg.data); + console.log(json); + document.getElementById("delay").innerText = + `${json.delay}s (${Math.floor(json.delay / 60)}min)`; + document.getElementById("sequence").innerText = json.sequence; + } + + + function initGeopos() { + document.getElementById("error").innerText = ""; + id = navigator.geolocation.watchPosition( + geoPing, + geoError, + {enableHighAccuracy: true} + ); + } + + + function openWebsocket () { + ws = new WebSocket((location.protocol == "http:" ? "ws" : "wss") + "://" + location.host + "/api/tracker/ping/ws"); + ws.onerror = wsError; + ws.onclose = wsClose; + ws.onmessage = wsMsg; + ws.onopen = (event) => { + setStatus("connected"); + }; + } + + async function geoPing(geoloc) { + console.log("got position update " + counter); + document.getElementById("lat").innerText = geoloc.coords.latitude; + document.getElementById("long").innerText = geoloc.coords.longitude; + document.getElementById("acc").innerText = geoloc.coords.accuracy; + + if (ws !== undefined && ws.readyState == 1) { + ws.send(JSON.stringify({ + trackerId: trackerId, + geopos: [ geoloc.coords.latitude, geoloc.coords.longitude ], + timestamp: (new Date()).toISOString() + })); + counter += 1; + setStatus(`sent ${counter} pings`); + } else { + setStatus(`websocket readystate ${ws.readyState}`); + } + } + + + async function main() { + initGeopos(); + + let urlparams = new URLSearchParams(window.location.search); + + trackerId = urlparams.get("trackerId"); + + if (trackerId === null) { + trackerId = await (await fetch("/api/tracker/register/", { + method: "POST", + body: JSON.stringify({agent: "tracktrain-website"}), + headers: {"Content-Type": "application/json"} + })).json(); + + if (trackerId.error) { + alert("could not obtain trackerId: \n" + trackerId.msg); + setStatus("_{MsgTrackerIdFailed}"); + } else { + console.log("got trackerId"); + window.location.search = `?trackerId=${trackerId}`; + } + } + + console.log(trackerId) + + if (trackerId !== null) { + document.getElementById("trackerId").innerText = trackerId; + openWebsocket(); + } + } + + main() + |] diff --git a/lib/Server/Frontend/Routes.hs b/lib/Server/Frontend/Routes.hs new file mode 100644 index 0000000..684d69d --- /dev/null +++ b/lib/Server/Frontend/Routes.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Server.Frontend.Routes where + +import Config (ServerConfig (..), UffdConfig (..)) +import Control.Monad (forM_) +import qualified Data.Aeson as A +import qualified Data.ByteString.Char8 as C8 +import qualified Data.ByteString.Lazy as LB +import Data.Functor ((<&>)) +import Data.Pool (Pool) +import qualified Data.Text as T +import Data.Time (UTCTime) +import Data.Time.Calendar (Day) +import Data.UUID (UUID) +import Database.Persist.Sql (SqlBackend, runSqlPool) +import qualified GTFS +import Persist (TrackerId) +import Text.Blaze.Internal (MarkupM (Empty)) +import Yesod +import Yesod.Auth +import Yesod.Auth.OAuth2.Prelude +import Yesod.Auth.Uffd (UffdUser (..), uffdClient) +import Yesod.Orphans () + +data Frontend = Frontend + { getGtfs :: GTFS.GTFS + , getPool :: Pool SqlBackend + , getSettings :: ServerConfig + } + +mkMessage "Frontend" "messages" "en" + +mkYesodData "Frontend" [parseRoutes| +/ RootR GET +/auth AuthR Auth getAuth + +/tickets TicketsR GET +/ticket/#UUID TicketViewR GET +/ticket/map/#UUID TicketMapViewR GET +/ticket/announce/#UUID AnnounceR POST +/ticket/del-announce/#UUID DelAnnounceR GET + +/trackers TrackersR GET POST +/tracker/#Text TrackerViewR GET +/tracker/#Text/delete TrackerDeleteR POST +/tracker/#Text/command TrackerCommandR POST +/tracker/#Text/config TrackerConfigR POST + +/ticker/announce TickerAnnounceR POST +/ticker/delete TickerDeleteR POST + +/spacetime SpaceTimeDiagramR GET + +/trackerId/block/#TrackerId TrackerIdBlock GET + +/gtfs/trips GtfsTripsViewR GET +/gtfs/trip/#GTFS.TripId GtfsTripViewR GET +/gtfs/import/#Day GtfsTicketImportR POST + +/tracker OnboardTrackerR GET +|] + +emptyMarkup :: MarkupM a -> Bool +emptyMarkup (Empty _) = True +emptyMarkup _ = False + + +instance Yesod Frontend where + authRoute _ = Just $ AuthR LoginR + isAuthorized OnboardTrackerR _ = pure Authorized + isAuthorized (AuthR _) _ = pure Authorized + isAuthorized _ _ = do + maybeUffd <- getYesod <&> serverConfigLogin . getSettings + case maybeUffd of + Nothing -> pure Authorized + Just UffdConfig{..} -> maybeAuthId >>= \case + Just _ -> pure Authorized + Nothing -> pure AuthenticationRequired + + + defaultLayout w = do + PageContent{..} <- widgetToPageContent w + msgs <- getMessages + + withUrlRenderer [hamlet| + $newline never + $doctype 5 + <html> + <head> + <title> + $if emptyMarkup pageTitle + Tracktrain + $else + #{pageTitle} + $maybe description <- pageDescription + <meta name="description" content="#{description}"> + ^{pageHead} + <link rel="stylesheet" href="/assets/style.css"> + <meta name="viewport" content="width=device-width, initial-scale=1"> + <body> + $forall (status, msg) <- msgs + <!-- <p class="message #{status}">#{msg} --> + ^{pageBody} + |] + + +instance RenderMessage Frontend FormMessage where + renderMessage _ _ = defaultFormMessage + +instance YesodPersist Frontend where + type YesodPersistBackend Frontend = SqlBackend + runDB action = do + pool <- getYesod <&> getPool + runSqlPool action pool + + +-- this instance is only slightly cursed (it keeps login information +-- as json in a session cookie and hopes nothing will ever go wrong) +instance YesodAuth Frontend where + type AuthId Frontend = UffdUser + + authPlugins cr = case config of + Just UffdConfig {..} -> + [ uffdClient uffdConfigUrl uffdConfigClientName uffdConfigClientSecret ] + Nothing -> [] + where config = serverConfigLogin (getSettings cr) + + maybeAuthId = do + e <- lookupSession "json" + pure $ case e of + Nothing -> Nothing + Just extra -> A.decode (LB.fromStrict $ C8.pack $ T.unpack extra) + + authenticate creds = do + forM_ (credsExtra creds) (uncurry setSession) + -- extra <- lookupSession "extra" + -- pure (Authenticated ( undefined)) + e <- lookupSession "json" + case e of + Nothing -> error "no session information" + Just extra -> case A.decode (LB.fromStrict $ C8.pack $ T.unpack extra) of + Nothing -> error "malformed session information" + Just user -> pure $ Authenticated user + + loginDest _ = RootR + logoutDest _ = RootR + -- hardcode redirecting to uffd directly; showing the normal login + -- screen is kinda pointless when there's only one option + loginHandler = do + redirect ("/auth/page/uffd/forward" :: Text) + onLogout = do + clearSession + diff --git a/lib/Server/Frontend/SpaceTime.hs b/lib/Server/Frontend/SpaceTime.hs new file mode 100644 index 0000000..16e8205 --- /dev/null +++ b/lib/Server/Frontend/SpaceTime.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} + +module Server.Frontend.SpaceTime (getSpaceTimeDiagramR, mkSpaceTimeDiagram, mkSpaceTimeDiagramHandler) where + +import Server.Frontend.Routes + +import Control.Monad (forM, when) +import Data.Coerce (coerce) +import Data.Function (on, (&)) +import Data.Functor ((<&>)) +import Data.Graph (path) +import Data.List +import qualified Data.Map as M +import Data.Maybe (catMaybes, mapMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (Day, UTCTime (..), getCurrentTime) +import qualified Data.Vector as V +import Fmt ((+|), (|+)) +import GHC.Float (double2Int, int2Double) +import GTFS (Seconds (unSeconds)) +import qualified GTFS +import Persist +import Server.Util (getTzseries) +import Text.Blaze.Html (Html) +import Text.Read (readMaybe) +import Yesod + +getSpaceTimeDiagramR :: Handler Html +getSpaceTimeDiagramR = do + req <- getRequest + day <- case lookup "day" (reqGetParams req) >>= (readMaybe . T.unpack) of + Just day -> pure day + Nothing -> liftIO $ getCurrentTime <&> utctDay + + mkSpaceTimeDiagramHandler 1 day [ TicketDay ==. day ] >>= \case + Nothing -> notFound + Just widget -> defaultLayout [whamlet| + <h1>_{MsgSpaceTimeDiagram} + <section> + ^{widget} + |] + +mkSpaceTimeDiagramHandler :: Double -> Day -> [Filter Ticket] -> Handler (Maybe Widget) +mkSpaceTimeDiagramHandler scale day filter = do + tickets <- runDB $ selectList filter [ Asc TicketId ] >>= mapM (\ticket -> do + stops <- selectList [StopTicket ==. entityKey ticket] [] >>= mapM (\(Entity _ stop@Stop{..}) -> do + arrival <- lift $ timeToPos scale day stopArrival + departure <- lift $ timeToPos scale day stopDeparture + pure (stop, arrival, departure)) + anchors <- selectList [TrainAnchorTicket ==. entityKey ticket] [Desc TrainAnchorSequence] + pure (ticket, stops, anchors)) + + case tickets of + [] -> + pure Nothing + _ -> + mkSpaceTimeDiagram scale day tickets + <&> Just + +-- | Safety: tickets may not be empty +mkSpaceTimeDiagram + :: Double + -> Day + -> [(Entity Ticket, [(Stop, Double, Double)], [Entity TrainAnchor])] + -> Handler Widget +mkSpaceTimeDiagram scale day tickets = do + -- we take the longest trip of the day. This will lead to unreasonable results + -- if there's more than one shape (this whole route should probably take a shape id tbh) + stations <- runDB $ fmap (\(_,stops,_) -> stops) tickets + & maximumBy (compare `on` length) + & fmap (\(stop, _, _) -> stop) + & sortOn stopSequence + & zip [0..] + & mapM (\(idx, stop) -> do + station <- getJust (stopStation stop) + pure (station, stop { stopSequence = idx })) + + let reference = stations + <&> \(_, stop) -> stop + let maxSequence = stopSequence (last reference) + let scaleSequence a = a * 100 / int2Double maxSequence + + + (minY, maxY) <- tickets + <&> (\(_,stops,_) -> stops) + & concat + & mapM (timeToPos scale day . stopDeparture . (\(stop, _, _) -> stop)) + <&> (\ys -> (minimum ys - 10, maximum ys + 30)) + + let timezone = head reference + & stopArrival + & GTFS.tzname + + timeLines <- ([0,(double2Int $ 3600 / scale)..(24*3600)] + & mapM ((\a -> timeToPos scale day a <&> (,a)) . \seconds -> GTFS.Time seconds timezone)) + <&> takeWhile ((< maxY - 20) . fst) . filter ((> minY) . fst) + + pure [whamlet| + <svg viewBox="-6 #{minY} 108 #{maxY - minY}" width="100%"> + + -- horizontal lines per hour + $forall (y, time) <- timeLines + <path + style="fill:none;stroke:grey;stroke-width:0.2;stroke-dasharray:1" + d="M 0,#{y} 100,#{y}" + > + <text style="font-size:1pt;"> + <tspan x="-5" y="#{y + 0.1}">#{time} + + -- vertical lines per station + $forall (station, Stop{..}) <- stations + <path + style="fill:none;stroke:#79797a;stroke-width:0.3" + d="M #{scaleSequence (int2Double stopSequence)},#{minY} #{scaleSequence (int2Double stopSequence)},#{maxY}" + > + <text style="font-size:2pt;" transform="rotate(-90)"> + <tspan + x="#{0 - maxY}" + y="#{scaleSequence (int2Double stopSequence) - 0.5}" + >#{stationName station} + + -- trips + $forall (ticket, stops, anchors) <- tickets + <path + style="fill:none;stroke:blueviolet;stroke-width:0.3;stroke-dasharray:1.5" + d="M #{mkStopsline scaleSequence reference stops}" + > + <path + style="fill:none;stroke:red;stroke-width:0.3;" + d="M #{mkAnchorline scale scaleSequence reference stops anchors}" + > + |] + +mkStopsline :: (Double -> Double) -> [Stop] -> [(Stop, Double, Double)] -> Text +mkStopsline scaleSequence reference stops = stops + <&> mkStop + & T.concat + where mkStop (stop, arrival, departure) = + " "+|scaleSequence s|+","+|arrival|+" " + +|scaleSequence s|+","+|departure|+"" + where s = mapSequenceWith reference stop & int2Double + +mkAnchorline :: Double -> (Double -> Double) -> [Stop] -> [(Stop, Double, Double)] -> [Entity TrainAnchor] -> Text +mkAnchorline scale scaleSequence reference stops anchors = + anchors + <&> (mkAnchor . entityVal) + & T.concat + where + mkAnchor TrainAnchor{..} = + " "+|scaleSequence transformed|+"," + -- this use of secondsToPos is correct; trainAnchorWhen saves in the correct timezone already + +|secondsToPos scale trainAnchorWhen|+"" + where + transformed = int2Double (mapSequence lastStop) + offset + + offset = + abs (trainAnchorSequence - int2Double (stopSequence lastStop)) + / int2Double (stopSequence lastStop - stopSequence nextStop) + -- the below is necessary to flip if necessary (it can be either -1 or +1) + * int2Double (mapSequence lastStop - mapSequence nextStop) + + mapSequence = mapSequenceWith reference + + lastStop = stops + & filter (\(Stop{..},_,_) -> + int2Double stopSequence <= trainAnchorSequence) + & last + & \(stop,_,_) -> stop + nextStop = stops + & filter (\(Stop{..},_,_) -> + int2Double stopSequence > trainAnchorSequence) + & head + & \(stop,_,_) -> stop + +-- | map a stop sequence number into the graph's space +mapSequenceWith :: [Stop] -> Stop -> Int +mapSequenceWith reference stop = filter + (\referenceStop -> stopStation referenceStop == stopStation stop) reference + & head + & stopSequence + +-- | SAFETY: ignores time zones +secondsToPos :: Double -> Seconds -> Double +secondsToPos scale = (* scale) . (/ 600) . int2Double . GTFS.unSeconds + +timeToPos :: Double -> Day -> GTFS.Time -> Handler Double +timeToPos scale day time = do + settings <- getYesod <&> getSettings + tzseries <- liftIO $ getTzseries settings (GTFS.tzname time) + pure $ secondsToPos scale (GTFS.toSeconds time tzseries day) diff --git a/lib/Server/Frontend/Ticker.hs b/lib/Server/Frontend/Ticker.hs new file mode 100644 index 0000000..8813200 --- /dev/null +++ b/lib/Server/Frontend/Ticker.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE QuasiQuotes #-} + +module Server.Frontend.Ticker (tickerWidget, postTickerAnnounceR, postTickerDeleteR) where +import Data.Functor ((<&>)) +import Data.Time (getCurrentTime) +import Database.Esqueleto.Experimental hiding ((<&>)) +import Persist (EntityField (TickerAnnouncementArchived), + TickerAnnouncement (..)) +import Server.Frontend.Routes (FrontendMessage (..), Handler, + Route (..), Widget) +import Yesod hiding (update, (=.), (==.)) + + +tickerAnnounceForm + :: Maybe TickerAnnouncement + -> Html + -> MForm Handler (FormResult TickerAnnouncement, Widget) +tickerAnnounceForm maybeCurrent = renderDivs $ TickerAnnouncement + <$> areq textField (fieldSettingsLabel MsgHeader) + (maybeCurrent <&> tickerAnnouncementHeader) + <*> fmap unTextarea (areq textareaField (fieldSettingsLabel MsgText) + (maybeCurrent <&> (Textarea . tickerAnnouncementMessage))) + <*> pure False + <*> lift (liftIO getCurrentTime) + +tickerWidget :: Handler Html +tickerWidget = do + current <- runDB $ selectOne do + ann <- from (table @TickerAnnouncement) + where_ (ann ^. TickerAnnouncementArchived ==. val False) + pure ann + + (widget, enctype) <- + generateFormPost (tickerAnnounceForm (current <&> entityVal)) + + defaultLayout [whamlet| + <h2>_{Msgincident} + <form method=post action=@{TickerAnnounceR} enctype=#{enctype}> + ^{widget} + <button>_{MsgSubmit} + <form method=post action=@{TickerDeleteR}> + <button>_{Msgdelete} + |] + +postTickerAnnounceR :: Handler Html +postTickerAnnounceR = do + current <- runDB $ selectOne do + ann <- from (table @TickerAnnouncement) + where_ (ann ^. TickerAnnouncementArchived ==. val False) + pure ann + + ((result, widget), enctype) <- + runFormPost (tickerAnnounceForm (fmap entityVal current)) + + case result of + FormSuccess ann -> do + runDB do + update \t -> + set t [ TickerAnnouncementArchived =. val True ] + insert ann + redirect RootR + _ -> defaultLayout + [whamlet| + <p>_{MsgInvalidInput}. + <form method=post action=@{TickerAnnounceR} enctype=#{enctype}> + ^{widget} + <button>_{MsgSubmit} + |] + +postTickerDeleteR :: Handler Html +postTickerDeleteR = do + runDB $ update \t -> + set t [TickerAnnouncementArchived =. val True] + redirect RootR diff --git a/lib/Server/Frontend/Tickets.hs b/lib/Server/Frontend/Tickets.hs new file mode 100644 index 0000000..915521d --- /dev/null +++ b/lib/Server/Frontend/Tickets.hs @@ -0,0 +1,459 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} + +module Server.Frontend.Tickets + ( getTicketsR + , postGtfsTicketImportR + , getTicketViewR + , getTicketMapViewR + , getDelAnnounceR + , postAnnounceR + , getTrackerIdBlock + ) where + +import Server.Frontend.Routes + +import Config (ServerConfig (..), + UffdConfig (..)) +import Control.Monad (forM, forM_, join) +import Control.Monad.Extra (maybeM) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Coerce (coerce) +import Data.Function (on, (&)) +import Data.Functor ((<&>)) +import Data.List (lookup, nubBy) +import Data.List.NonEmpty (nonEmpty) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (catMaybes, fromJust, isJust) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (UTCTime (..), addDays, + getCurrentTime, utctDay) +import Data.Time.Calendar (Day) +import Data.Time.Format.ISO8601 (iso8601Show) +import Data.UUID (UUID) +import qualified Data.UUID as UUID +import qualified Data.Vector as V +import Extrapolation (Extrapolator (..), + LinearExtrapolator (..)) +import Fmt ((+|), (|+)) +import GHC.Float (int2Double) +import qualified GTFS +import Numeric (showFFloat) +import Persist +import Server.Frontend.SpaceTime (mkSpaceTimeDiagram, + mkSpaceTimeDiagramHandler) +import Server.Frontend.Ticker (tickerWidget) +import Server.Util (Service, secondsNow) +import Text.Read (readMaybe) +import qualified Yesod +import Yesod hiding (delete, update, (=.), + (==.), (||.)) +import Yesod.Auth +import Yesod.Auth.Uffd (UffdUser (..), uffdClient) + +import Database.Esqueleto.Experimental (asc, associateJoin, orderBy, + where_, (:&) (..), (^.)) +import Database.Esqueleto.Experimental hiding (on, (<&>)) +import qualified Database.Esqueleto.Experimental as E + +getTicketsR :: Handler Html +getTicketsR = do + req <- getRequest + let maybeDay = lookup "day" (reqGetParams req) >>= (readMaybe . T.unpack) + mdisplayname <- maybeAuthId <&> fmap uffdDisplayName + + (day, isToday) <- liftIO $ getCurrentTime <&> utctDay <&> \today -> + case maybeDay of + Just day -> (day, day == today) + Nothing -> (today, True) + + maybeSpaceTime <- mkSpaceTimeDiagramHandler 1 day [ TicketDay Yesod.==. day ] + + let prevday = (T.pack . iso8601Show . addDays (-1)) day + let nextday = (T.pack . iso8601Show . addDays 1) day + gtfs <- getYesod <&> getGtfs + + -- TODO: tickets should have all trip information saved + + tickets <- runDB $ E.select do + ((ticket :& stop) :& station) <- E.from $ + (E.table @Ticket `E.InnerJoin` E.table @Stop + `E.on` \(ticket :& stop) -> ticket ^. TicketId E.==. stop E.^. StopTicket) + `E.InnerJoin` E.table @Station `E.on` \((_ :& stop) :& station) -> stop E.^. StopStation E.==. station ^. StationId + where_ (ticket ^. TicketDay E.==. (E.val day)) + orderBy [asc (ticket ^. TicketTripName)] + pure (ticket, (stop, station)) + & fmap associateJoin + + let trips = GTFS.tripsOnDay gtfs day + + tickerAnnounceWidget <- tickerWidget + + (widget, enctype) <- generateFormPost (tripImportForm (fmap (,day) (M.elems trips))) + defaultLayout $ do + [whamlet| +<h1> _{MsgTrainsOnDay (iso8601Show day)} +$maybe name <- mdisplayname + <p>_{MsgLoggedInAs name} - <a href="@{AuthR LogoutR}">_{MsgLogout}</a> +<nav> + <a class="nav-left" href="@?{(TicketsR, [("day", prevday)])}">← #{prevday} + $if isToday + _{Msgtoday} + $else + <a href="@{TicketsR}">_{Msgtoday} + <a class="nav-right" href="@?{(TicketsR, [("day", nextday)])}">#{nextday} → +<section> + ^{tickerAnnounceWidget} +<section> + <h2>_{MsgTickets} + <ol> + $forall (TicketKey ticketId, (Ticket{..}, stops)) <- M.toList tickets + <li><a href="@{TicketViewR ticketId}">_{MsgTrip} #{ticketTripName}</a> + : _{Msgdep} #{stopDeparture (entityVal (fst (head stops)))} #{stationName (entityVal (snd (head stops)))} → #{ticketHeadsign} + $if null tickets + <li style="text-align: center"><em>(_{MsgNone})</em> +$maybe spaceTime <- maybeSpaceTime + <section> + ^{spaceTime} +<section> + <h2>_{MsgAccordingToGtfs} + <form method=post action="@{GtfsTicketImportR day}" enctype=#{enctype}> + ^{widget} + <button>_{MsgImportTrips} + $if null trips + <li style="text-align: center"><em>(_{MsgNone}) +|] + + +-- TODO: this function should probably look for duplicate imports +postGtfsTicketImportR :: Day -> Handler Html +postGtfsTicketImportR day = do + gtfs <- getYesod <&> getGtfs + let trips = GTFS.tripsOnDay gtfs day + ((result, widget), enctype) <- runFormPost (tripImportForm (fmap (,day) (M.elems trips))) + case result of + FormSuccess selected -> do + now <- liftIO getCurrentTime + + shapeMap <- selected + <&> (\(trip@GTFS.Trip{..}, _) -> (GTFS.shapeId tripShape, tripShape)) + & nubBy ((==) `on` fst) + & mapM (\(shapeId, shape) -> runDB $ do + key <- insert Shape + insertMany + $ shape + & GTFS.shapePoints + & V.indexed + & V.toList + <&> \(idx, pos) -> ShapePoint (Geopos pos) idx key + pure (shapeId, key)) + <&> M.fromList + + stationMap <- selected + <&> (\(trip@GTFS.Trip{..}, _) -> V.toList (tripStops <&> GTFS.stopStation)) + & concat + & nubBy ((==) `on` GTFS.stationId) + & mapM (\GTFS.Station{..} -> runDB $ E.selectOne do + station <- E.from (E.table @Station) + where_ (station ^. StationShortName E.==. E.val stationId) + pure station + >>= \case + Nothing -> do + key <- insert Station + { stationGeopos = Geopos (stationLat, stationLon) + , stationShortName = stationId , stationName } + pure (stationId, key) + Just (Entity key _) -> pure (stationId, key)) + & fmap M.fromList + + selected + <&> (\(trip@GTFS.Trip{..}, day) -> + let + ticket = Ticket + { ticketTripName = tripTripId, ticketDay = day, ticketImported = now + , ticketSchedule_version = Nothing, ticketVehicle = Nothing + , ticketCompleted = False, ticketHeadsign = gtfsHeadsign trip + , ticketShape = fromJust (M.lookup (GTFS.shapeId tripShape) shapeMap)} + stops = V.toList tripStops <&> \GTFS.Stop{..} ticketId -> Stop + { stopTicket = ticketId + , stopStation = fromJust (M.lookup (GTFS.stationId stopStation) stationMap) + , stopArrival, stopDeparture, stopSequence} + in (ticket, stops)) + & unzip + & \(tickets, stops) -> runDB $ do + ticketIds <- insertMany tickets + forM (zip ticketIds stops) $ \(ticketId, unfinishedStops) -> + insertMany (fmap (\s -> s ticketId) unfinishedStops) + + redirect (TicketsR, [("day", T.pack (iso8601Show day))]) + + FormFailure _ -> defaultLayout [whamlet| +<section> + <h2>_{MsgAccordingToGtfs} + <form method=post action="@{GtfsTicketImportR day}" enctype=#{enctype}> + ^{widget} + <button>_{MsgImportTrips} +|] + +getTicketViewR :: UUID -> Handler Html +getTicketViewR ticketId = do + let ticketKey = TicketKey ticketId + Ticket{..} <- runDB $ get ticketKey + >>= \case {Nothing -> notFound; Just a -> pure a} + + stops <- runDB $ select do + (stop :& station) <- from $ table @Stop `innerJoin` table @Station + `E.on` \(stop :& station) -> stop ^. StopStation ==. station ^. StationId + where_ (stop ^. StopTicket ==. val ticketKey) + pure (stop, station) + -- & fmap associateJoin + -- stops <- runDB $ selectList [StopTicket ==. ticketKey] [] >>= mapM (\stop -> do + -- station <- getJust (stopStation (entityVal stop)) + -- pure (entityVal stop, station)) + + anns <- runDB $ select do + ann <- from (table @Announcement) + where_ (ann ^. AnnouncementTicket ==. val ticketKey) + pure ann + + -- anns <- runDB $ selectList [ AnnouncementTicket ==. ticketKey ] [] + + trackers <- runDB $ select do + (tt :& tracker) <- from $ + table @TrackerTicket `innerJoin` table @Tracker + `E.on` \(tt :& tracker) -> tracker ^. TrackerId ==. tt ^. TrackerTicketTracker + where_ (tt ^. TrackerTicketTicket ==. val ticketKey + ||. tracker ^. TrackerCurrentTicket ==. val (Just ticketKey)) + pure tracker + + lastPing <- runDB $ selectOne do + trainping <- from $ table @Ping + where_ (trainping ^. PingTicket ==. val (Just (coerce ticketId))) + orderBy [desc (trainping ^. PingTimestamp)] + pure trainping + + anchors <- runDB $ select do + anchor <- from $ table @TrainAnchor + where_ (anchor ^. TrainAnchorTicket ==. val ticketKey) + pure anchor + <&> nonEmpty . fmap entityVal + -- joins <- runDB $ selectList [ TrackerTicketTicket ==. ticketKey ] [] + -- <&> fmap (trackerTicketTracker . entityVal) + -- trackers <- runDB $ selectList + -- ([ TrackerId <-. joins ] ||. [ TrackerCurrentTicket ==. Just ticketKey ]) + -- [Asc TrackerExpires] + -- lastPing <- runDB $ selectFirst [ PingTicket ==. coerce ticketId ] [Desc PingTimestamp] + -- anchors <- runDB $ selectList [ TrainAnchorTicket ==. ticketKey ] [] + -- <&> nonEmpty . fmap entityVal + + spaceTimeMaybe <- mkSpaceTimeDiagramHandler 2 ticketDay [ TicketId Yesod.==. coerce ticketId ] + + (widget, enctype) <- generateFormPost (announceForm ticketId) + + nowSeconds <- secondsNow ticketDay + defaultLayout $ do + mr <- getMessageRender + setTitle (toHtml (""+|mr MsgTrip|+" "+|ticketTripName|+" "+|mr Msgon|+" "+|ticketDay|+"" :: Text)) + [whamlet| +<h1>_{MsgTrip} # + <a href="@{GtfsTripViewR ticketTripName}">#{ticketTripName} + _{Msgon} + <a href="@?{(TicketsR, [("day", T.pack (iso8601Show ticketDay))])}">#{ticketDay} +<section> + <h2>_{MsgLive} + <p><strong>_{MsgLastPing}: </strong> + $maybe Entity _ Ping{..} <- lastPing + _{MsgPing (latitude pingGeopos) (longitude pingGeopos) pingTimestamp} + (<a href="/api/debug/pings/#{UUID.toString ticketId}/#{ticketDay}">_{Msgraw}</a>) + $nothing + <em>(_{MsgNoPing}) + <p><strong>_{MsgEstimatedDelay}</strong>: + $maybe history <- anchors + $maybe TrainAnchor{..} <- guessAtSeconds history nowSeconds + \ #{trainAnchorDelay} (_{MsgOnStationSequence (showFFloat (Just 3) trainAnchorSequence "")}) + $nothing + <em> (_{MsgNone}) + <p><a href="@{TicketMapViewR ticketId}">_{MsgMap}</a> +<section> + <h2>_{MsgStops} + <ol> + $forall (Entity _ Stop{..}, Entity _ Station{..}) <- stops + <li value="#{stopSequence}"> #{stopArrival} #{stationName} + $maybe history <- anchors + $maybe delay <- guessDelay history (int2Double stopSequence) + \ (#{delay}) +$maybe spaceTime <- spaceTimeMaybe + <section> + ^{spaceTime} +<section> + <h2>_{MsgAnnouncements} + <ul> + $forall Entity (AnnouncementKey uuid) Announcement{..} <- anns + <li><em>#{announcementHeader}: #{announcementMessage}</em> <a href="@{DelAnnounceR uuid}">_{Msgdelete}</a> + $if null anns + <li><em>(_{MsgNone})</em> + <h3>_{MsgNewAnnouncement} + <form method=post action=@{AnnounceR ticketId} enctype=#{enctype}> + ^{widget} + <button>_{MsgSubmit} +<section> + <h2>_{MsgTrackerIds} + <table> + <tr><th style="width: 20%">_{MsgAgent}</th><th style="width: 50%">_{MsgTrackerId}</th><th>_{MsgExpires}</th><th>_{MsgStatus}</th> + $if null trackers + <tr><td></td><td style="text-align:center"><em>(_{MsgNone}) + $forall Entity (TrackerKey key) Tracker{..} <- trackers + <tr :trackerBlocked:.blocked> + <td title="#{trackerAgent}">#{trackerAgent} + <td title="#{key}">#{key} + + $if trackerBlocked + <td title="_{MsgUnblockTrackerId}"><a href="@?{(TrackerIdBlock (TrackerKey key), [("unblock", "true")])}">_{MsgUnblockTrackerId}</a> + $else + <td title="_{MsgBlockTrackerId}"><a href="@{TrackerIdBlock (TrackerKey key)}">_{MsgBlockTrackerId}</a> +|] + where guessDelay history = fmap trainAnchorDelay . extrapolateAtPosition LinearExtrapolator history + guessAtSeconds = extrapolateAtSeconds LinearExtrapolator + + +getTicketMapViewR :: UUID -> Handler Html +getTicketMapViewR ticketId = do + Ticket{..} <- runDB $ get (TicketKey ticketId) + >>= \case { Nothing -> notFound ; Just ticket -> pure ticket } + + -- stops <- runDB $ E.select do + -- (stop :& station) <- E.from $ + -- E.table @Stop `E.InnerJoin` E.table @Station + -- `E.on` \(stop :& station) -> stop ^. StopStation E.==. station E.^. StationId + -- where_ (stop ^. StopTicket E.==. (E.val (TicketKey ticketId))) + -- pure (stop, station) + + (widget, enctype) <- generateFormPost (announceForm ticketId) + + defaultLayout [whamlet| +<h1>_{MsgTrip} <a href="@{TicketViewR ticketId}">#{ticketTripName} _{Msgon} #{ticketDay}</a> +<link rel="stylesheet" href="https://unpkg.com/leaflet@1.9.3/dist/leaflet.css" + integrity="sha256-kLaT2GOSpHechhsozzB+flnD+zUyjE2LlfWPgU04xyI=" + crossorigin=""/> +<script src="https://unpkg.com/leaflet@1.9.3/dist/leaflet.js" + integrity="sha256-WBkoXOwTeyKclOHuWtc+i2uENFpDZ9YPdf5Hf+D7ewM=" + crossorigin=""></script> +<div id="map"> +<p id="status"> +<script> + let map = L.map('map'); + + L.tileLayer('https://tile.openstreetmap.org/{z}/{x}/{y}.png', { + attribution: '© <a href="https://www.openstreetmap.org/copyright">OpenStreetMap</a> contributors' + }).addTo(map); + + ws = new WebSocket((location.protocol == "http:" ? "ws" : "wss") + "://" + location.host + "/api/ticket/subscribe/#{UUID.toText ticketId}"); + + var marker = null; + + ws.onmessage = (msg) => { + let json = JSON.parse(msg.data); + console.log(json) + if (marker === null) { + marker = L.marker(json.geopos); + marker.addTo(map); + } else { + marker.setLatLng(json.geopos); + } + map.setView(json.geopos, 13); + document.getElementById("status").innerText = "_{MsgLastPing}: "+json.geopos[0]+","+json.geopos[1]+" ("+json.timestamp+")"; + } +|] + +tripImportForm + :: [(GTFS.Trip GTFS.Deep GTFS.Deep, Day)] + -> Html + -> MForm Handler (FormResult [(GTFS.Trip GTFS.Deep GTFS.Deep, Day)], Widget) +tripImportForm trips extra = do + forms <- forM trips $ \(trip, day) -> do + (aRes, aView) <- mreq checkBoxField "import" Nothing + let dings = fmap (\res -> if res then Just (trip, day) else Nothing) aRes + pure (trip, day, dings, aView) + + let widget = toWidget [whamlet| + #{extra} + <ol> + $forall (trip@GTFS.Trip{..}, day, res, view) <- forms + <li> + ^{fvInput view} + <label for="^{fvId view}"> + _{MsgTrip} #{GTFS.tripName trip} + : _{Msgdep} #{GTFS.stopDeparture (V.head tripStops)} #{GTFS.stationName (GTFS.stopStation (V.head tripStops))} → #{gtfsHeadsign trip} + |] + + let (a :: FormResult [Maybe (GTFS.Trip GTFS.Deep GTFS.Deep, Day)]) = + sequenceA (fmap (\(_,_,res,_) -> res) forms) + + pure (fmap catMaybes a, widget) + +gtfsHeadsign :: GTFS.Trip GTFS.Deep GTFS.Deep -> Text +gtfsHeadsign GTFS.Trip{..} = + case tripHeadsign of + Just headsign -> headsign + Nothing -> GTFS.stationName (GTFS.stopStation (V.last tripStops)) + + +announceForm :: UUID -> Html -> MForm Handler (FormResult Announcement, Widget) +announceForm ticketId = renderDivs $ Announcement + <$> pure (TicketKey ticketId) + <*> areq textField (fieldSettingsLabel MsgHeader) Nothing + <*> areq textField (fieldSettingsLabel MsgText) Nothing + <*> aopt urlField (fieldSettingsLabel MsgMaybeWeblink) Nothing + <*> lift (liftIO getCurrentTime <&> Just) + +postAnnounceR :: UUID -> Handler Html +postAnnounceR ticketId = do + ((result, widget), enctype) <- runFormPost (announceForm ticketId) + case result of + FormSuccess ann -> do + runDB $ insert ann + redirect RootR -- (TicketViewR trip day) + _ -> defaultLayout + [whamlet| + <p>_{MsgInvalidInput}. + <form method=post action=@{AnnounceR ticketId} enctype=#{enctype}> + ^{widget} + <button>_{MsgSubmit} + |] + +getDelAnnounceR :: UUID -> Handler Html +getDelAnnounceR uuid = do + ann <- runDB $ do + a <- get (AnnouncementKey uuid) + delete do + ann <- from (table @Announcement) + where_ (ann ^. AnnouncementId ==. val (AnnouncementKey uuid)) + pure a + case ann of + Nothing -> notFound + Just Announcement{..} -> + let (TicketKey ticketId) = announcementTicket + in redirect (TicketViewR ticketId) + +getTrackerIdBlock :: TrackerId -> Handler Html +getTrackerIdBlock trackerId = do + YesodRequest{..} <- getRequest + let blocked = lookup "unblock" reqGetParams /= Just "true" + maybe <- runDB do + update \tracker -> do + set tracker [TrackerBlocked =. val blocked] + where_ (tracker ^. TrackerId ==. val trackerId) + -- Yesod.update (TrackerKey trackerId) [ TrackerBlocked Yesod.=. blocked ] + get trackerId + case maybe of + Just r@Tracker{..} -> do + liftIO $ print r + redirect $ case trackerCurrentTicket of + Just ticket -> TicketViewR (coerce ticket) + Nothing -> RootR + Nothing -> notFound diff --git a/lib/Server/Frontend/Tracker.hs b/lib/Server/Frontend/Tracker.hs new file mode 100644 index 0000000..e78e567 --- /dev/null +++ b/lib/Server/Frontend/Tracker.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} + +module Server.Frontend.Tracker + (getTrackerViewR, getTrackersR, postTrackersR, postTrackerDeleteR, + postTrackerCommandR, postTrackerConfigR) +where + +import Data.Aeson (Value, decode, encode) +import Data.ByteString (fromStrict, toStrict) +import Data.Coerce (coerce) +import Data.Function ((&)) +import Data.Functor ((<&>)) +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Time (getCurrentTime) +import qualified Data.UUID as UUID +import Database.Esqueleto.Experimental hiding ((<&>)) +import Persist +import Server.Frontend.Routes (FrontendMessage (..), Handler, + Route (..), Widget) +import Yesod hiding (delete, update, (=.), + (==.)) + +import Fmt +import qualified OwnTracks +import OwnTracks.Command +import OwnTracks.Configuration (configHost) +import OwnTracks.Status + + +getTrackersR :: Handler Html +getTrackersR = do + trackers <- runDB $ select do + (t :& p) <- from $ + (table @Tracker) `LeftOuterJoin` (table @Ping) + `on` \(t :& p) -> just (t ^. TrackerId) ==. p ?. PingTrackerId + pure (t, p) + & fmap associateJoin + + createWidget <- trackerCreateWidget + + defaultLayout [whamlet| + <h1> Trackers + <section> + <ul> + $forall (trackerId, (Tracker{..}, status)) <- M.toList trackers + <li><a href="@{TrackerViewR trackerName}">#{trackerName}</a> + <section> + ^{createWidget} + |] + +trackerCreateForm + :: Html + -> MForm Handler (FormResult Tracker, Widget) +trackerCreateForm = renderDivs $ Tracker + <$> areq textField (fieldSettingsLabel MsgTrackerName) Nothing + <*> pure False + <*> areq textField (fieldSettingsLabel MsgTrackerAgent) Nothing + <*> pure Nothing + <*> pure Nothing + +trackerCreateWidget :: Handler Html +trackerCreateWidget = do + (widget, enctype) <- generateFormPost trackerCreateForm + defaultLayout [whamlet| + <h2> _{MsgCreateTracker} + <form method=post action="@{TrackersR}" enctype=#{enctype}> + ^{widget} + <button>_{MsgSubmit} + |] + +postTrackersR :: Handler Html +postTrackersR = do + ((result, widget), enctype) <- runFormPost trackerCreateForm + case result of + FormSuccess ann -> do + runDB do + insert ann + redirect TrackersR + _ -> defaultLayout + [whamlet| + <p>_{MsgInvalidInput}. + <form method=post action=@{TrackersR} enctype=#{enctype}> + ^{widget} + <button>_{MsgSubmit} + |] + +trackerCommandForm + :: Html -> MForm Handler (FormResult Command, Widget) +trackerCommandForm = renderDivs do + text <- areq textField (fieldSettingsLabel MsgSendCommand) (Just "{\"action\": \"dump\"}") + let Just c = (decode (fromStrict (encodeUtf8 text))) + pure c + +trackerCommandWidget :: Text -> Handler Html +trackerCommandWidget name = do + (widget, enctype) <- generateFormPost trackerCommandForm + defaultLayout [whamlet| + <h2> _{MsgSendCommand} + <form method=post action="@{TrackerCommandR name}" enctype=#{enctype}> + ^{widget} + <button>_{MsgSubmit} + |] + +postTrackerCommandR :: Text -> Handler Html +postTrackerCommandR name = do + ((result, widget), enctype) <- runFormPost trackerCommandForm + case result of + FormSuccess command -> do + now <- liftIO $ getCurrentTime + res <- runDB $ + (selectOne do + tracker <- from (table @Tracker) + where_ (tracker ^. TrackerName ==. val name) + pure tracker) + >>= mapM \tracker -> + insert $ TrackerCommand + { trackerCommandTracker = entityKey tracker + , trackerCommandTimestamp = now + , trackerCommandStatus = Queued + , trackerCommandCommand = command + } + case res of + Just _ -> redirect $ TrackerViewR name + Nothing -> notFound + _ -> defaultLayout + [whamlet| + <p>_{MsgInvalidInput}. + <form method=post action=@{TrackerCommandR name} enctype=#{enctype}> + ^{widget} + <button>_{MsgSubmit} + |] + +trackerConfigForm + :: Maybe OwnTracks.Configuration + -> Html + -> MForm Handler (FormResult OwnTracks.Configuration, Widget) +trackerConfigForm maybeLastConfig = renderDivs do + -- TODO: default text should be last config, if known? + text <- areq textField + (fieldSettingsLabel MsgSendCommand) + (fmap (decodeUtf8 . toStrict . encode) maybeLastConfig) + let Just c = (decode (fromStrict (encodeUtf8 text))) + pure c + +trackerConfigWidget :: Maybe OwnTracks.Configuration -> Text -> Handler Html +trackerConfigWidget maybeLastConfig name = do + (widget, enctype) <- generateFormPost (trackerConfigForm maybeLastConfig) + -- TODO: show which config version we're writing here, and which one was last? + defaultLayout [whamlet| + <h2> _{MsgSendCommand} + <form method=post action="@{TrackerConfigR name}" enctype=#{enctype}> + ^{widget} + <button>_{MsgSubmit} + |] + +postTrackerConfigR :: Text -> Handler Html +postTrackerConfigR name = do + ((result, widget), enctype) <- runFormPost (trackerConfigForm Nothing) + case result of + FormSuccess config -> do + now <- liftIO $ getCurrentTime + res <- runDB $ + (selectOne do + tracker <- from (table @Tracker) + where_ (tracker ^. TrackerName ==. val name) + pure tracker) + >>= mapM \tracker@(Entity _ Tracker{..}) -> do + insert $ TrackerCommand + { trackerCommandTracker = entityKey tracker + , trackerCommandTimestamp = now + , trackerCommandStatus = Queued + , trackerCommandCommand = SetConfiguration (config + { configHost = configHost config + & fmap \host -> case trackerConfigVersion of + Nothing -> host <> "&v=1" + Just v -> ""+|host|+ "&v="+|show (v + 1)|+"" + -- FIXME: something less unsafe here? + }) + } + insert $ TrackerConfig + { trackerConfigTracker = entityKey tracker + , trackerConfigTimestamp = now + , trackerConfigSeen = False + , trackerConfigConfiguration = config + } + case res of + Just _ -> redirect $ TrackerViewR name + Nothing -> notFound + _ -> defaultLayout + [whamlet| + <p>_{MsgInvalidInput}. + <form method=post action=@{TrackerConfigR name} enctype=#{enctype}> + ^{widget} + <button>_{MsgSubmit} + |] + +getTrackerViewR :: Text -> Handler Html +getTrackerViewR name = + runDB (selectOne do + tracker <- from (table @Tracker) + where_ (tracker ^. TrackerName ==. val name) + pure tracker) + >>= \case + Nothing -> notFound + Just (Entity trackerId Tracker{..}) -> do + + (maybeStatus, maybePing, config) <- runDB $ do + status <- selectOne do + status <- from (table @TrackerStatus) + where_ (status ^. TrackerStatusTracker ==. val trackerId) + orderBy [desc $ status ^. TrackerStatusTimestamp] + pure status + ping <- selectOne do + ping <- from (table @Ping) + where_ (ping ^. PingTrackerId ==. val trackerId) + orderBy [desc $ ping ^. PingTimestamp] + pure ping + config <- selectOne do + config <- from (table @TrackerConfig) + where_ (config ^. TrackerConfigTracker ==. val trackerId) + orderBy [desc $ config ^. TrackerConfigTimestamp] + pure config + pure (status, ping, config) + + commandWidget <- trackerCommandWidget name + configWidget <- trackerConfigWidget (fmap (trackerConfigConfiguration . entityVal) config) name + + -- TODO: leaflet map; auto updates? + defaultLayout [whamlet| + <h1> _{MsgTracker name} + <section> + <h1> _{MsgTracker name} + <p> + Agent: #{trackerAgent} <br> + UUID: #{trackerId} + <p> + <form action=@{TrackerDeleteR trackerName} method="post"> + <button> _{Msgdelete} + <section> + <h2> _{MsgLastTrackerStatus} + $maybe Entity _ TrackerStatus{..} <- maybeStatus + LocationPermission: #{show $ statusLocationPermission trackerStatusStatus} <br> + BatteryOptimisations: #{show $ statusBatteryOptimizations trackerStatusStatus} <br> + Phone in power save mode: #{show $ statusPhonePowerSaveMode trackerStatusStatus} + $nothing + <em>Status unknown + <section> + <h2> _{MsgLastTrackerPosition} + $maybe Entity _ Ping{..} <- maybePing + Position: #{show pingGeopos} <br> + Timestamp: #{show pingTimestamp} <br> + $maybe ticketId <- pingTicket + Ticket: <a href="@{TicketViewR (coerce ticketId)}">#{UUID.toText (coerce ticketId)}</a> + $nothing + Ticket: (no assigned ticket) + $nothing + (none) + <section> + ^{configWidget} + <section> + ^{commandWidget} + |] + + +postTrackerDeleteR :: Text -> Handler Html +postTrackerDeleteR name = do + runDB $ delete do + tracker <- from (table @Tracker) + where_ (tracker ^. TrackerName ==. val name) + redirect TrackersR diff --git a/lib/Server/GTFS_RT.hs b/lib/Server/GTFS_RT.hs index cfb02ce..4b16a5b 100644 --- a/lib/Server/GTFS_RT.hs +++ b/lib/Server/GTFS_RT.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE RecordWildCards #-} @@ -8,21 +8,23 @@ module Server.GTFS_RT (gtfsRealtimeServer) where import API (GtfsRealtimeAPI) +import Config (ServerConfig (..)) import Control.Lens ((&), (.~)) import Control.Monad (forM) import Control.Monad.Extra (mapMaybeM) import Control.Monad.IO.Class (MonadIO (..)) +import Data.Coerce (coerce) import Data.Functor ((<&>)) import Data.List.NonEmpty (NonEmpty, nonEmpty) import qualified Data.Map as M -import Data.Maybe (catMaybes, mapMaybe) +import Data.Maybe (catMaybes, fromMaybe, mapMaybe) import Data.Pool (Pool) import Data.ProtoLens (defMessage) import Data.Text (Text) import qualified Data.Text as T import Data.Time.Calendar (Day, toGregorian) import Data.Time.Clock (UTCTime (utctDay), addUTCTime, - getCurrentTime) + diffUTCTime, getCurrentTime) import Data.Time.Clock.System (SystemTime (systemSeconds), getSystemTime, utcToSystemTime) import Data.Time.Format.ISO8601 (iso8601Show) @@ -31,21 +33,24 @@ import qualified Data.UUID as UUID import qualified Data.Vector as V import Database.Persist (Entity (..), PersistQueryRead (selectFirst), - selectList, (==.)) + SelectOpt (Asc, Desc), get, + getJust, selectKeysList, + selectList, (<-.), (==.)) import Database.Persist.Postgresql (SqlBackend) import Extrapolation (Extrapolator (extrapolateAtPosition, extrapolateAtSeconds), LinearExtrapolator (..)) import GHC.Float (double2Float, int2Double) import GTFS (Depth (..), GTFS (..), - Seconds (..), Stop (..), - Trip (..), TripID, + Seconds (..), Trip (..), TripId, showTimeWithSeconds, stationId, toSeconds, toUTC, tripsOnDay) import Persist (Announcement (..), EntityField (..), Key (..), - Running (..), Token (..), - TrainAnchor (..), TrainPing (..), - runSql) + Ping (..), Station (..), + Stop (..), Ticket (..), + Tracker (..), TrackerId (..), + TrainAnchor (..), latitude, + longitude, runSql) import qualified Proto.GtfsRealtime as RT import qualified Proto.GtfsRealtime_Fields as RT import Servant.API ((:<|>) (..)) @@ -65,101 +70,127 @@ toStupidDate date = toStupidTime :: Num i => UTCTime -> i toStupidTime = fromIntegral . systemSeconds . utcToSystemTime -gtfsRealtimeServer :: GTFS -> Pool SqlBackend -> Service GtfsRealtimeAPI -gtfsRealtimeServer gtfs@GTFS{..} dbpool = +gtfsRealtimeServer :: ServerConfig -> GTFS -> Pool SqlBackend -> Service GtfsRealtimeAPI +gtfsRealtimeServer settings@ServerConfig{..} gtfs@GTFS{..} dbpool = handleServiceAlerts :<|> handleTripUpdates :<|> handleVehiclePositions + where - handleServiceAlerts = runSql dbpool $ do - announcements <- selectList [] [] - defFeedMessage (fmap mkAlert announcements) + -- return an empty message if we're in silent mode & not force=yes + doNothingIfSilent m force = + if serverConfigBeSilent && not force then defFeedMessage mempty + else m >>= defFeedMessage + + handleServiceAlerts = doNothingIfSilent $ runSql dbpool $ do + announcements <- selectList [] [] + forM announcements $ \(Entity (AnnouncementKey uuid) announcement@Announcement{..}) -> do + ticket <- getJust announcementTicket + pure $ mkAlert uuid announcement ticket where - mkAlert :: Entity Announcement -> RT.FeedEntity - mkAlert (Entity (AnnouncementKey uuid) Announcement{..}) = + mkAlert :: UUID.UUID -> Announcement -> Ticket -> RT.FeedEntity + mkAlert uuid Announcement{..} Ticket{..} = defMessage & RT.id .~ UUID.toText uuid & RT.alert .~ (defMessage & RT.activePeriod .~ [ defMessage :: RT.TimeRange ] & RT.informedEntity .~ [ defMessage - & RT.trip .~ defTripDescriptor announcementTrip (Just announcementDay) Nothing + & RT.trip .~ defTripDescriptor ticketTripName (Just ticketDay) Nothing ] & RT.maybe'url .~ fmap (monolingual "de") announcementUrl & RT.headerText .~ monolingual "de" announcementHeader & RT.descriptionText .~ monolingual "de" announcementMessage ) - handleTripUpdates = runSql dbpool $ do - today <- liftIO $ getCurrentTime <&> utctDay + handleTripUpdates = doNothingIfSilent $ runSql dbpool $ do + now <- liftIO getCurrentTime + let today = utctDay now nowSeconds <- secondsNow today - let running = M.toList (tripsOnDay gtfs today) - anchors <- flip mapMaybeM running $ \(tripId, trip@Trip{..}) -> do - entities <- selectList [TrainAnchorTrip ==. tripId, TrainAnchorDay ==. today] [] - case nonEmpty (fmap entityVal entities) of + -- let running = M.toList (tripsOnDay gtfs today) + tickets <- selectList [TicketCompleted ==. False, TicketDay ==. today] [Asc TicketTripName] + + tripUpdates <- forM tickets $ \(Entity key Ticket{..}) -> do + selectList [TrainAnchorTicket ==. key] [] >>= \a -> case nonEmpty a of Nothing -> pure Nothing - Just anchors -> pure $ Just (tripId, trip, anchors) + Just anchors -> do + stops <- selectList [StopTicket ==. key] [Asc StopArrival] >>= mapM (\(Entity _ stop) -> do + station <- getJust (stopStation stop) + pure (stop, station)) - defFeedMessage (mapMaybe (mkTripUpdate today nowSeconds) anchors) - where - mkTripUpdate :: Day -> Seconds -> (Text, Trip 'Deep 'Deep, NonEmpty TrainAnchor) -> Maybe RT.FeedEntity - mkTripUpdate today nowSeconds (tripId :: Text, Trip{..} :: Trip Deep Deep, anchors) = - let lastCall = extrapolateAtSeconds LinearExtrapolator anchors nowSeconds - stations = tripStops - <&> (\stop@Stop{..} -> (, stop) - <$> extrapolateAtPosition LinearExtrapolator anchors (int2Double stopSequence)) - (lastAnchor, lastStop) = V.last (V.catMaybes stations) - stillRunning = trainAnchorDelay lastAnchor + toSeconds (stopArrival lastStop) tzseries today - < nowSeconds + 5 * 60 - in if not stillRunning then Nothing else Just $ defMessage - & RT.id .~ (tripId <> "-" <> T.pack (iso8601Show today)) - & RT.tripUpdate .~ (defMessage - & RT.trip .~ defTripDescriptor tripId (Just today) (Just $ T.pack (showTimeWithSeconds $ stopDeparture $ V.head tripStops)) - & RT.stopTimeUpdate .~ fmap mkStopTimeUpdate (catMaybes $ V.toList stations) - & RT.maybe'delay .~ Nothing -- lastCall <&> (fromIntegral . unSeconds . trainAnchorDelay) - & RT.maybe'timestamp .~ fmap (toStupidTime . trainAnchorCreated) lastCall - ) - where - mkStopTimeUpdate :: (TrainAnchor, Stop Deep) -> RT.TripUpdate'StopTimeUpdate - mkStopTimeUpdate (TrainAnchor{..}, Stop{..}) = defMessage - & RT.stopSequence .~ fromIntegral stopSequence - & RT.stopId .~ stationId stopStation - & RT.arrival .~ (defMessage + let anchorEntities = fmap entityVal anchors + let lastCall = extrapolateAtSeconds LinearExtrapolator anchorEntities nowSeconds + let atStations = flip fmap stops $ \(stop, station) -> + (, stop, station) <$> extrapolateAtPosition LinearExtrapolator anchorEntities (int2Double (stopSequence stop)) + let (lastAnchor, lastStop, lastStation) = last (catMaybes atStations) + + -- google's TripUpdateTooOld does not like information on trips which have ended + let stillRunning = trainAnchorDelay lastAnchor + toSeconds (stopArrival lastStop) tzseries today + > nowSeconds + 5 * 60 + -- google's TripUpdateTooOld check fails if the given timestamp is older than ~ half an hour + let isOutdated = maybe False + (\a -> trainAnchorCreated a `diffUTCTime` now < 20 * 60) lastCall + + pure $ if not stillRunning && not isOutdated then Nothing else Just $ defMessage + & RT.id .~ UUID.toText (coerce key) + & RT.tripUpdate .~ (defMessage + & RT.trip .~ + defTripDescriptor + ticketTripName (Just today) + (Just $ T.pack (showTimeWithSeconds $ stopDeparture $ fst $ head stops)) + & RT.stopTimeUpdate .~ fmap mkStopTimeUpdate (catMaybes atStations) + & RT.maybe'delay .~ Nothing -- lastCall <&> (fromIntegral . unSeconds . trainAnchorDelay) + & RT.maybe'timestamp .~ fmap (toStupidTime . trainAnchorCreated) lastCall + ) + where + mkStopTimeUpdate :: (TrainAnchor, Stop, Station) -> RT.TripUpdate'StopTimeUpdate + mkStopTimeUpdate (TrainAnchor{..}, Stop{..}, Station{..}) = defMessage + & RT.stopSequence .~ fromIntegral stopSequence + & RT.stopId .~ stationShortName + & RT.arrival .~ (defMessage & RT.delay .~ fromIntegral (unSeconds trainAnchorDelay) & RT.time .~ toStupidTime (addUTCTime (fromIntegral $ unSeconds trainAnchorDelay) (toUTC stopArrival tzseries today)) & RT.uncertainty .~ 60 - ) - & RT.departure .~ (defMessage - & RT.delay .~ fromIntegral (unSeconds trainAnchorDelay) - & RT.time .~ toStupidTime (addUTCTime + ) + & RT.departure .~ (defMessage + & RT.delay .~ fromIntegral (unSeconds trainAnchorDelay) + & RT.time .~ toStupidTime (addUTCTime (fromIntegral $ unSeconds trainAnchorDelay) (toUTC stopDeparture tzseries today)) - & RT.uncertainty .~ 60 - ) - & RT.scheduleRelationship .~ RT.TripUpdate'StopTimeUpdate'SCHEDULED + & RT.uncertainty .~ 60 + ) + & RT.scheduleRelationship .~ RT.TripUpdate'StopTimeUpdate'SCHEDULED + pure (catMaybes tripUpdates) + + handleVehiclePositions = doNothingIfSilent $ runSql dbpool $ do + + ticket <- selectList [TicketCompleted ==. False] [] + + -- TODO: reimplement this (since trainpings no longer reference tickets it's gone for now) + -- positions <- forM ticket $ \(Entity key ticket) -> do + -- selectFirst [PingTicket ==. key] [Desc PingTimestamp] >>= \case + -- Nothing -> pure Nothing + -- Just lastPing -> + -- pure (Just $ mkPosition (lastPing, ticket)) - handleVehiclePositions = runSql dbpool $ do - (running :: [Entity Running]) <- selectList [] [] - pings <- forM running $ \(Entity key entity) -> do - selectFirst [TrainPingToken ==. key] [] <&> fmap (, entity) - defFeedMessage (mkPosition <$> catMaybes pings) + pure [] -- (catMaybes positions) where - mkPosition :: (Entity TrainPing, Running) -> RT.FeedEntity - mkPosition (Entity (TrainPingKey key) TrainPing{..}, Running{..}) = defMessage + mkPosition :: (Entity Ping, Ticket) -> RT.FeedEntity + mkPosition (Entity key Ping{..}, Ticket{..}) = defMessage & RT.id .~ T.pack (show key) & RT.vehicle .~ (defMessage - & RT.trip .~ defTripDescriptor runningTrip Nothing Nothing - & RT.maybe'vehicle .~ case runningVehicle of + & RT.trip .~ defTripDescriptor ticketTripName Nothing Nothing + & RT.maybe'vehicle .~ case ticketVehicle of Nothing -> Nothing Just trainset -> Just $ defMessage & RT.label .~ trainset & RT.position .~ (defMessage - & RT.latitude .~ double2Float trainPingLat - & RT.longitude .~ double2Float trainPingLong + & RT.latitude .~ double2Float (latitude pingGeopos) + & RT.longitude .~ double2Float (longitude pingGeopos) ) -- TODO: should probably give currentStopSequence/stopId here as well - & RT.timestamp .~ toStupidTime trainPingTimestamp + & RT.timestamp .~ toStupidTime pingTimestamp ) @@ -181,7 +212,7 @@ defFeedMessage entities = do ) & RT.entity .~ entities -defTripDescriptor :: TripID -> Maybe Day -> Maybe Text -> RT.TripDescriptor +defTripDescriptor :: TripId -> Maybe Day -> Maybe Text -> RT.TripDescriptor defTripDescriptor tripId day starttime = defMessage & RT.tripId .~ tripId & RT.scheduleRelationship .~ RT.TripDescriptor'SCHEDULED diff --git a/lib/Server/Ingest.hs b/lib/Server/Ingest.hs new file mode 100644 index 0000000..ec99e60 --- /dev/null +++ b/lib/Server/Ingest.hs @@ -0,0 +1,372 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} + +module Server.Ingest (handleTrackerRegister, handlePing, handleWS, handleOwntracksMessage) where +import API (Metrics (..), + RegisterJson (..), + SentPing (..)) +import Control.Concurrent.STM (atomically, readTVar, + writeTQueue) +import Control.Monad (forM, forever, unless, + void, when) +import Control.Monad.Catch (handle) +import Control.Monad.Extra (ifM, mapMaybeM, whenJust, + whenJustM) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Logger (LoggingT, logDebugN, + logErrorN, logInfoN, + logWarnN) +import Control.Monad.Reader (ReaderT) +import qualified Data.Aeson as A +import qualified Data.ByteString.Char8 as C8 +import Data.Coerce (coerce) +import Data.Functor ((<&>)) +import qualified Data.Map as M +import Data.Pool (Pool) +import Data.Text (Text) +import Data.Text.Encoding (decodeASCII, decodeUtf8) +import Data.Time (NominalDiffTime, + UTCTime (..), addUTCTime, + diffUTCTime, + getCurrentTime, + nominalDay) +import qualified Data.Vector as V +import Database.Persist +import Database.Persist.Postgresql (SqlBackend) +import Fmt ((+|), (|+)) +import qualified GTFS +import qualified Network.WebSockets as WS +import Persist +import Servant (err400, err401, + throwError) +import Servant.Server (Handler) +import Server.Util (ServiceM, getTzseries, + utcToSeconds) + +import Config (LoggingConfig, + ServerConfig (..)) +import Control.Exception (throw) +import Data.ByteString (ByteString) +import Data.ByteString.Lazy (toStrict) +import Data.Foldable (find, minimumBy) +import Data.Function (on, (&)) +import Data.Maybe (fromJust) +import qualified Data.Text as T +import Data.Time.LocalTime.TimeZone.Series (TimeZoneSeries) +import qualified Data.UUID as UUID +import Database.Esqueleto.Experimental (from, select, selectOne, + set, table, val, where_, + (^.)) +import qualified Database.Esqueleto.Experimental as E +import Extrapolation (Extrapolator (..), + LinearExtrapolator (..), + euclid) +import GHC.Generics (Generic) +import GTFS (seconds2Double) +import OwnTracks hiding (Ping) +import Prometheus (decGauge, incGauge) +import Server.Base (ServerState) + +handleTrackerRegister + :: Pool SqlBackend + -> RegisterJson + -> ServiceM TrackerId +handleTrackerRegister dbpool RegisterJson{..} = do + today <- liftIO getCurrentTime <&> utctDay + expires <- liftIO $ getCurrentTime <&> addUTCTime validityPeriod + runSql dbpool $ do + TrackerKey tracker <- insert (Tracker "dummy" {-expires-} False registerAgent Nothing Nothing) + pure (coerce tracker) + where + validityPeriod :: NominalDiffTime + validityPeriod = nominalDay + +handlePing + :: Pool SqlBackend + -> ServerState + -> ServerConfig + -> LoggingT (ReaderT LoggingConfig Handler) a + -> SentPing + -> LoggingT (ReaderT LoggingConfig Handler) (Maybe TrainAnchor) +handlePing dbpool subscribers cfg onError ping@SentPing{..} = + isTrackerIdValid dbpool sentPingTrackerId >>= \case + Nothing -> onError >> pure Nothing + Just tracker@Tracker{..} -> do + + -- unless (serverConfigDebugMode cfg) $ do + -- now <- liftIO getCurrentTime + -- let timeDiff = sentPingTimestamp `diffUTCTime` now + -- when (utctDay sentPingTimestamp /= utctDay now) $ do + -- logErrorN "received ping for wrong day" + -- throw err400 + -- when (timeDiff < 10) $ do + -- logWarnN "received ping more than 10 seconds out of date" + -- throw err400 + -- when (timeDiff > 10) $ do + -- logWarnN "received ping from more than 10 seconds in the future" + -- throw err400 + + ticketId <- case trackerCurrentTicket of + Just ticketId -> pure ticketId + -- if the tracker is not associated with a ticket, it is probably new + -- & should be auto-associated with the most fitting current ticket + Nothing -> runSql dbpool (guessTicketFromPing cfg ping) >>= \case + Just ticketId -> pure ticketId + Nothing -> do + logWarnN $ "Tracker "+|UUID.toString (coerce sentPingTrackerId)|+ + " sent a ping, but no trips are running today." + throwError err400 + + runSql dbpool $ insertSentPing subscribers cfg ping tracker ticketId + + +handleOwntracksMessage + :: Pool SqlBackend + -> ServerState + -> ServerConfig + -> Maybe Text + -> Maybe Text + -> Maybe Int + -> Message + -> LoggingT (ReaderT LoggingConfig Handler) [Command] +handleOwntracksMessage dbpool subscribers cfg maybeUser device maybeVersion msg = do + user <- case maybeUser of + Just user -> pure user + Nothing -> throwError err401 + + -- TODO: maybe get the basic json here, and put it into a log-msg table? + + logDebugN $ "received msg: "+|show msg|+"." + + Entity trackerId tracker@Tracker{..} <- runSql dbpool $ (selectOne do + tracker <- from (table @Tracker) + where_ (tracker ^. TrackerName E.==. val user) + pure tracker) + >>= \case + Just tracker -> pure tracker + Nothing -> throw err401 + + whenJust maybeVersion \version -> do + whenJust trackerConfigVersion \tversion -> do + when (tversion > version) $ logWarnN $ "Tracker "+|trackerName|+" sent message tagged with older config "+|version|+" after we've seen it using config "+|tversion|+"." + runSql dbpool $ do + when (tversion < version) $ E.update \t -> do + set t [TrackerConfigVersion E.=. val (Just version)] + where_ (t ^. TrackerId E.==. val trackerId) + E.update \c -> do + set c [TrackerConfigSeen E.=. val True] + where_ (c ^. TrackerConfigTracker E.==. val trackerId) + + case msg of + MsgStatus status -> do + now <- liftIO getCurrentTime + logInfoN $ "received status msg: "+|show status|+"" + runSql dbpool $ insert_ $ TrackerStatus trackerId now status + MsgLocation Location{..} -> do + let ping = SentPing + { sentPingTrackerId = trackerId + , sentPingGeopos = Geopos (locationLatitude, locationLongitude) + , sentPingTimestamp = locationTimestamp + } + + maybeTicketId <- case trackerCurrentTicket of + -- if the tracker is not associated with a ticket, it is probably new + -- & should be auto-associated with the most fitting current ticket + Nothing -> runSql dbpool (guessTicketFromPing cfg ping) >>= \case + Just ticketId -> pure (Just ticketId) + Nothing -> do + -- unfortunately, cannot really communicate anything useful back? + logWarnN $ "Owntracks user "+|user|+ + " sent a ping, but no trips are running today." + pure Nothing + + case maybeTicketId of + Nothing -> do + runSql dbpool $ insert $ Ping + { pingTicket = Nothing + , pingTrackerId = trackerId + , pingGeopos = Geopos (locationLatitude, locationLongitude) + , pingTimestamp = locationTimestamp + , pingSequence = Nothing + } + pure () + Just ticketId -> + void $ runSql dbpool $ insertSentPing subscribers cfg undefined tracker ticketId + other -> logWarnN $ "received unhandled owntracks message: "+|show other|+"" + + commands <- runSql dbpool $ do + command <- select do + command <- from (table @TrackerCommand) + where_ (command ^. TrackerCommandTracker E.==. val trackerId + E.&&. command ^. TrackerCommandStatus E.==. val Queued) + pure command + -- this is silly; update does not support a RETURNING clause … + E.update \command -> do + set command [ TrackerCommandStatus E.=. val Sent ] + where_ (command ^. TrackerCommandTracker E.==. val trackerId + E.&&. command ^. TrackerCommandStatus E.==. val Queued) + pure command + + logInfoN $ "sending commands: "+|show (fmap (entityVal) commands)|+"" + pure (fmap (trackerCommandCommand . entityVal) commands) + +insertSentPing + :: ServerState + -> ServerConfig + -> SentPing + -> Tracker + -> TicketId + -> InSql (Maybe TrainAnchor) +insertSentPing subscribers cfg ping@SentPing{..} tracker@Tracker{..} ticketId = do + ticket@Ticket{..} <- getJust ticketId + + stations <- selectList [ StopTicket ==. ticketId ] [Asc StopArrival] + >>= mapM (\stop -> do + station <- getJust (stopStation (entityVal stop)) + tzseries <- liftIO $ getTzseries cfg (GTFS.tzname (stopArrival (entityVal stop))) + pure (entityVal stop, station, tzseries)) + <&> V.fromList + + shapePoints <- selectList [ShapePointShape ==. ticketShape] [Asc ShapePointIndex] + <&> (V.fromList . fmap entityVal) + + + let anchor = extrapolateAnchorFromPing LinearExtrapolator + ticketId ticket stations shapePoints ping + + + maybeReassign <- selectFirst + [ PingTicket ==. Just ticketId, PingSequence !=. Nothing ] + [ Desc PingTimestamp ] + <&> find (\ping -> fromJust (pingSequence (entityVal ping)) > trainAnchorSequence anchor) + >> guessTicketFromPing cfg ping + <&> find (/= ticketId) + + + -- mapM (\newTicketId -> if ticketId /= newTicketId then Just newTicketId else Nothing)) + -- >>= (\ping -> guessTicketFromPing cfg ping >>= \case + -- Just newTicketId | ticketId /= newTicketId -> pure (Just newTicketId) + -- _ -> pure Nothing) + + case maybeReassign of + Just newTicketId -> do + update sentPingTrackerId + [TrackerCurrentTicket =. Just newTicketId ] + logInfoN $ "tracker "+|UUID.toText (coerce sentPingTrackerId)|+ + "has switched direction, and was reassigned to ticket " + +|UUID.toText (coerce newTicketId)|+"." + insertSentPing subscribers cfg ping tracker newTicketId + Nothing -> do + let trackedPing = Ping + { pingTrackerId = sentPingTrackerId + , pingGeopos = sentPingGeopos + , pingTimestamp = sentPingTimestamp + , pingSequence = Just (trainAnchorSequence anchor) + , pingTicket = Just ticketId + } + + insert trackedPing + + last <- selectFirst [TrainAnchorTicket ==. ticketId] [Desc TrainAnchorWhen] + -- only insert new estimates if they've actually changed anything + when (fmap (trainAnchorDelay . entityVal) last /= Just (trainAnchorDelay anchor)) + $ void $ insert anchor + + -- are we at the final stop? if so, mark this ticket as done + -- & the tracker as free + let maxSequence = V.last stations + & (\(stop, _, _) -> stopSequence stop) + & fromIntegral + when (trainAnchorSequence anchor + 0.1 >= maxSequence) $ do + update sentPingTrackerId + [TrackerCurrentTicket =. Nothing] + update ticketId + [TicketCompleted =. True] + logInfoN $ "Tracker "+|UUID.toString (coerce sentPingTrackerId)|+ + " has completed ticket "+|UUID.toString (coerce ticketId)|+ + " (trip "+|ticketTripName|+")" + + queues <- liftIO $ atomically $ do + queues <- readTVar subscribers <&> M.lookup (coerce ticketId) + whenJust queues $ + mapM_ (\q -> writeTQueue q (Just trackedPing)) + pure queues + pure (Just anchor) + +handleWS + :: Pool SqlBackend + -> ServerState + -> ServerConfig + -> Metrics + -> WS.Connection -> ServiceM () +handleWS dbpool subscribers cfg Metrics{..} conn = do + liftIO $ WS.forkPingThread conn 30 + incGauge metricsWSGauge + handle (\(e :: WS.ConnectionException) -> decGauge metricsWSGauge) $ forever $ do + msg <- liftIO $ WS.receiveData conn + case A.eitherDecode msg of + Left err -> do + logWarnN ("stray websocket message: "+|decodeASCII (toStrict msg)|+" (could not decode: "+|err|+")") + liftIO $ WS.sendClose conn (C8.pack err) + -- TODO: send a close msg (Nothing) to the subscribed queues? decGauge metricsWSGauge + Right ping -> do + -- if invalid trackerId, send a "polite" close request. Note that the client may + -- ignore this and continue sending messages, which will continue to be handled. + handlePing dbpool subscribers cfg (liftIO $ WS.sendClose conn ("" :: ByteString)) ping >>= \case + Just anchor -> liftIO $ WS.sendTextData conn (A.encode anchor) + Nothing -> pure () + + +guessTicketFromPing :: ServerConfig -> SentPing -> InSql (Maybe (Key Ticket)) +guessTicketFromPing cfg SentPing{..} = do + tickets <- selectList [ TicketDay ==. utctDay sentPingTimestamp, TicketCompleted ==. False ] [] + + ticketsWithStation <- forM tickets (\ticket@(Entity ticketId _) -> do + stops <- selectList [StopTicket ==. ticketId] [Asc StopSequence] >>= mapM (\(Entity _ stop) -> do + station <- getJust (stopStation stop) + tzseries <- liftIO $ getTzseries cfg (GTFS.tzname (stopDeparture stop)) + pure (station, stop, tzseries)) + pure (ticket, stops)) + + if null ticketsWithStation then pure Nothing else do + let (closestTicket, _) = ticketsWithStation + & minimumBy (compare `on` (\(Entity _ ticket, stations) -> + let + runningDay = ticketDay ticket + smallestDistance = stations + <&> (\(station, stop, tzseries) -> spaceAndTimeDiff + (sentPingGeopos, utcToSeconds sentPingTimestamp runningDay) + (stationGeopos station, GTFS.toSeconds (stopDeparture stop) tzseries runningDay)) + & minimum + in smallestDistance)) + + logInfoN + $ "Tracker "+|UUID.toString (coerce sentPingTrackerId)|+ + " is now handling ticket "+|UUID.toString (coerce (entityKey closestTicket))|+ + " (trip "+|ticketTripName (entityVal closestTicket)|+")." + + update sentPingTrackerId + [TrackerCurrentTicket =. Just (entityKey closestTicket)] + + pure (Just (entityKey closestTicket)) + +spaceAndTimeDiff :: (Geopos, GTFS.Seconds) -> (Geopos, GTFS.Seconds) -> Double +spaceAndTimeDiff (pos1, time1) (pos2, time2) = + spaceDistance + abs (seconds2Double timeDiff / 3600) + where spaceDistance = euclid pos1 pos2 + timeDiff = time1 - time2 + +-- TODO: proper debug logging for expired trackerIds +isTrackerIdValid :: Pool SqlBackend -> TrackerId -> ServiceM (Maybe Tracker) +isTrackerIdValid dbpool trackerId = runSql dbpool $ get trackerId >>= \case + Just tracker | not (trackerBlocked tracker) -> do + pure (Just tracker) + -- ifM (hasExpired (trackerExpires tracker)) + -- (pure Nothing) + -- (pure (Just tracker)) + _ -> pure Nothing + +hasExpired :: MonadIO m => UTCTime -> m Bool +hasExpired limit = do + now <- liftIO getCurrentTime + pure (now > limit) diff --git a/lib/Server/Subscribe.hs b/lib/Server/Subscribe.hs new file mode 100644 index 0000000..86b67a6 --- /dev/null +++ b/lib/Server/Subscribe.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE BlockArguments #-} + +module Server.Subscribe where +import Conduit (MonadIO (..)) +import Control.Concurrent.STM (atomically, newTQueue, + readTQueue, readTVar, + writeTVar) +import Control.Exception (handle) +import Control.Monad.Extra (forever, whenJust) +import qualified Data.Aeson as A +import qualified Data.ByteString.Char8 as C8 +import Data.Coerce (coerce) +import Data.Functor ((<&>)) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Pool +import Data.UUID (UUID) +import Database.Esqueleto.Experimental hiding ((<&>)) +import Database.Persist.Sql (SqlBackend) +import qualified Network.WebSockets as WS +import Persist +import Server.Base (ServerState) +import Server.Util (ServiceM) + +handleSubscribe + :: Pool SqlBackend + -> ServerState + -> UUID + -> WS.Connection + -> ServiceM () +handleSubscribe dbpool subscribers (ticketId :: UUID) conn = liftIO $ WS.withPingThread conn 30 (pure ()) $ do + queue <- atomically $ do + queue <- newTQueue + qs <- readTVar subscribers + writeTVar subscribers + $ M.insertWith (<>) ticketId [queue] qs + pure queue + + -- send most recent ping, if any (so we won't have to wait for movement) + runSqlWithoutLog dbpool (selectOne do + ping <- from (table @Ping) + where_ (ping ^. PingTicket ==. val (Just (coerce ticketId))) + orderBy [desc (ping ^. PingTimestamp)] + pure ping) + <&> fmap entityVal + >>= flip whenJust (WS.sendTextData conn . A.encode) + + handle (\(e :: WS.ConnectionException) -> removeSubscriber queue) $ forever $ do + res <- atomically $ readTQueue queue + case res of + Just ping -> WS.sendTextData conn (A.encode ping) + Nothing -> do + removeSubscriber queue + WS.sendClose conn (C8.pack "train ended") + where removeSubscriber queue = atomically $ do + qs <- readTVar subscribers + writeTVar subscribers + $ M.adjust (filter (/= queue)) ticketId qs + +-- getTicketTrackers :: (MonadLogger (t (ResourceT IO)), MonadIO (t (ResourceT IO))) +-- => UUID -> ReaderT SqlBackend (t (ResourceT IO)) [Entity Tracker] +getTicketTrackers ticketId = select do + (tracker :& trackerticket) <- from $ + table @Tracker + `innerJoin` + table @TrackerTicket + `on` \(tr :& ti) -> tr ^. TrackerId ==. ti ^. TrackerTicketTracker + + where_ $ + tracker ^. TrackerCurrentTicket ==. val (Just (TicketKey ticketId)) + ||. trackerticket ^. TrackerTicketTicket ==. val (TicketKey ticketId) + + pure tracker + + -- joins <- selectList [TrackerTicketTicket ==. TicketKey ticketId] [] + -- <&> fmap (trackerTicketTracker . entityVal) + -- selectList ([TrackerId <-. joins] ||. [TrackerCurrentTicket ==. Just (TicketKey ticketId)]) [] diff --git a/lib/Server/Util.hs b/lib/Server/Util.hs index 41d26f7..b519a86 100644 --- a/lib/Server/Util.hs +++ b/lib/Server/Util.hs @@ -1,32 +1,79 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} - +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE RecordWildCards #-} -- | mostly the monad the service runs in -module Server.Util (Service, ServiceM, runService, sendErrorMsg, secondsNow, utcToSeconds) where +module Server.Util (Service, ServiceM, runService, sendErrorMsg, secondsNow, utcToSeconds, runLogging, getTzseries, serveDirectoryFileServer) where -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Logger (LoggingT, runStderrLoggingT) -import qualified Data.Aeson as A -import Data.ByteString (ByteString) -import Data.Text (Text) -import Data.Time (Day, UTCTime (..), diffUTCTime, - getCurrentTime, - nominalDiffTimeToSeconds) -import GTFS (Seconds (..)) -import Prometheus (MonadMonitor (doIO)) -import Servant (Handler, ServerError, ServerT, err404, - errBody, errHeaders, throwError) +import Config (LoggingConfig (..), + ServerConfig (..)) +import Control.Exception (handle, try) +import Control.Monad.Extra (void, whenJust) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Logger (Loc, LogLevel (..), + LogSource, LogStr, + LoggingT (..), + defaultOutput, fromLogStr, + runStderrLoggingT) +import Control.Monad.Reader (ReaderT (..)) +import qualified Data.Aeson as A +import Data.ByteString (ByteString) +import qualified Data.ByteString as C8 +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8Lenient) +import Data.Time (Day, UTCTime (..), + diffUTCTime, + getCurrentTime, + nominalDiffTimeToSeconds) +import Data.Time.LocalTime.TimeZone.Olson (getTimeZoneSeriesFromOlsonFile) +import Data.Time.LocalTime.TimeZone.Series (TimeZoneSeries) +import Fmt ((+|), (|+)) +import GHC.IO (unsafePerformIO) +import GHC.IO.Exception (IOException (IOError)) +import GTFS (Seconds (..)) +import Prometheus (MonadMonitor (doIO)) +import qualified Servant +import Servant (Handler, ServerError, + ServerT, err404, errBody, + errHeaders, throwError) +import System.IO (stderr) +import System.OsPath (OsPath, decodeFS, + decodeUtf, encodeUtf, + (</>)) +import System.Process.Extra (callProcess) -type ServiceM = LoggingT Handler +type ServiceM = LoggingT (ReaderT LoggingConfig Handler) type Service api = ServerT api ServiceM -runService :: ServiceM a -> Handler a -runService = runStderrLoggingT +runService :: LoggingConfig -> ServiceM a -> Handler a +runService conf m = runReaderT (runLogging conf m) conf instance MonadMonitor ServiceM where doIO = liftIO +runLogging :: MonadIO m => LoggingConfig -> LoggingT m a -> m a +runLogging LoggingConfig{..} logging = runLoggingT logging printLogMsg + where printLogMsg loc source level msg = do + -- this is what runStderrLoggingT does + defaultOutput stderr loc source level msg + + whenJust loggingConfigNtfyToken \token -> handle ntfyFailed do + callProcess "ntfy" + [ "send" + , "--token=" <> T.unpack token + , "--title="+|loggingConfigHostname|+"/"+|"tracktrain" + , "--priority="+|show (ntfyPriority level)|+"" + , T.unpack loggingConfigNtfyTopic + , T.unpack (decodeUtf8Lenient (fromLogStr msg)) ] + + ntfyFailed (e :: IOError) = + putStrLn ("calling ntfy failed:"+|show e|+".") + ntfyPriority level = case level of + LevelDebug -> 2 + LevelInfo -> 3 + LevelWarn -> 4 + LevelError -> 5 + LevelOther _ -> 0 + sendErrorMsg :: Text -> ServiceM a sendErrorMsg msg = throwError err404 @@ -42,3 +89,15 @@ secondsNow runningDay = do utcToSeconds :: UTCTime -> Day -> Seconds utcToSeconds time day = Seconds $ round $ nominalDiffTimeToSeconds $ diffUTCTime time (UTCTime day 0) + +getTzseries :: ServerConfig -> Text -> IO TimeZoneSeries +getTzseries settings tzname = do + suffix <- encodeUtf (T.unpack tzname) + -- TODO: submit a patch to timezone-olson making it accept OsPath + legacyPath <- decodeFS (serverConfigZoneinfoPath settings </> suffix) + getTimeZoneSeriesFromOlsonFile legacyPath + +-- TODO: patch servant / wai to use OsPath? +serveDirectoryFileServer :: OsPath -> ServerT Servant.Raw m +serveDirectoryFileServer = + Servant.serveDirectoryFileServer . unsafePerformIO . decodeUtf diff --git a/lib/Yesod/Orphans.hs b/lib/Yesod/Orphans.hs index f66f8af..dc5c77a 100644 --- a/lib/Yesod/Orphans.hs +++ b/lib/Yesod/Orphans.hs @@ -27,14 +27,17 @@ instance ToMarkup Day where instance ToMessage UTCTime where toMessage = formatW3 -instance ToMessage Token where - toMessage (Token uuid) = UUID.toText uuid +instance ToMessage TrackerId where + toMessage (TrackerKey uuid) = UUID.toText uuid instance ToMarkup UTCTime where toMarkup = toMarkup . formatW3 -instance ToMarkup Token where - toMarkup (Token uuid) = toMarkup (UUID.toText uuid) +instance ToMarkup TrackerId where + toMarkup (TrackerKey uuid) = toMarkup (UUID.toText uuid) + +instance ToMarkup UUID where + toMarkup uuid = toMarkup (UUID.toText uuid) instance ToMessage Double where toMessage = T.pack . show diff --git a/messages/de.msg b/messages/de.msg index 016ebbb..aab2766 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -19,28 +19,33 @@ Info: Info SwitchLanguage: Sprache wechseln Switch: wechseln Stops: Stationen -Tokens: Token -BlockToken: blockieren -UnblockToken: zulassen -Token: Token +TrackerIds: TrackerId +BlockTrackerId: blockieren +UnblockTrackerId: zulassen +TrackerId: TrackerId Status: Status Expires: läuft ab Agent: Gerät Live: Echtzeit LastPing: Letzte Meldung -TrainPing lat long time: #{lat},#{long}, um #{time} -NoTrainPing: keine empfangen +Ping lat long time: #{lat},#{long}, um #{time} +NoPing: keine empfangen raw: roh EstimatedDelay: Geschätzte Verspätung OnStationSequence idx: an Stationsindex #{idx} Map: Karte InvalidInput: Ungültige Eingabe, bitte noch einmal Submit: Ok +ImportTrips: Fahrten importieren +Tickets: Tickets delete: löschen +AccordingToGtfs: Weitere Fahrten im GTFS +SpaceTimeDiagram: Weg-Zeit +incident: Aktuelle Störungsmeldung OBU: Onboard-Unit ChooseTrain: Fahrt auswählen -TokenFailed: konnte kein Token erhalten +TrackerIdFailed: konnte kein TrackerId erhalten PermissionFailed: Berechtigungsfehler WebsocketError: Websocketfehler Error: Fehler diff --git a/messages/en.msg b/messages/en.msg index ecaad0a..a3ab7d7 100644 --- a/messages/en.msg +++ b/messages/en.msg @@ -19,28 +19,41 @@ Info: Info SwitchLanguage: Switch language to: Switch: Switch Stops: Stops -Tokens: Tokens -BlockToken: block -UnblockToken: unblock -Token: Token +TrackerIds: TrackerIds +BlockTrackerId: block +UnblockTrackerId: unblock +TrackerId: TrackerId +Tracker name@Text: Tracker #{name} +TrackerName: Name +TrackerAgent: Agent +CreateTracker: Create new tracker +LastTrackerStatus: Last Status +LastTrackerPosition: Last Position +SendCommand: Send Command Status: Status Expires: Expires Agent: Agent Live: Live LastPing: Last Ping -TrainPing lat@Double long@Double time@UTCTime: #{lat},#{long}, at #{time} -NoTrainPing: none received +Ping lat@Double long@Double time@UTCTime: #{lat},#{long}, at #{time} +NoPing: none received raw: raw EstimatedDelay: Estimated Delay OnStationSequence idx@String: on station index #{idx} Map: Map InvalidInput: Invalid input, let's try again Submit: Submit +Tickets: Tickets +ImportTrips: import selected trips delete: delete +AccordingToGtfs: Additional Trips contained in the Gtfs +StartTracking: Start Tracking +SpaceTimeDiagram: Space-Time Diagram +incident: Current Incident text OBU: Onboard-Unit ChooseTrain: Choose a Train -TokenFailed: Failed to acquire token +TrackerIdFailed: Failed to acquire token PermissionFailed: permission failed WebsocketError: Websocket Error Error: Error diff --git a/shell.nix b/shell.nix new file mode 100644 index 0000000..8c58e9d --- /dev/null +++ b/shell.nix @@ -0,0 +1,5 @@ +with import <nixpkgs> {}; + +mkShell { + buildInputs = [ pkg-config openssl zlib postgresql ]; +} diff --git a/site/obu.hamlet b/site/obu.hamlet deleted file mode 100644 index 7068014..0000000 --- a/site/obu.hamlet +++ /dev/null @@ -1,132 +0,0 @@ -<h1>_{MsgOBU} - -<section> - <h2>#{tripId} _{Msgon} #{day} - <strong>Token:</strong> <span id="token"> - -<section> - <h2>_{MsgLive} - <p><strong>Position: </strong><span id="lat"></span>, <span id="long"></span> - <p><strong>Accuracy: </strong><span id="acc"> - -<section> - <h2>_{MsgEstimated} - <p><strong>_{MsgDelay}</strong>: <span id="delay"> - <p><strong>_{MsgSequence}</strong>: <span id="sequence"> - -<section> - <h2>Status - <p id="status">_{MsgNone} - <p id>_{MsgError}: <span id="error"> - - -<script> - var token = null; - - let euclid = (a,b) => { - let x = a[0]-b[0]; - let y = a[1]-b[1]; - return x*x+y*y; - } - - let minimalDist = (point, list, proj, norm) => { - return list.reduce ( - (min, x) => { - let dist = norm(point, proj(x)); - return dist < min[0] ? [dist,x] : min - }, - [norm(point, proj(list[0])), list[0]] - )[1] - } - - let counter = 0; - let ws; - let id; - - async function geoError(error) { - document.getElementById("status").innerText = "error"; - alert(`_{MsgPermissionFailed}: \n${error.message}`); - console.log(error); - } - - async function wsError(error) { - // alert(`_{MsgWebsocketError}: \n${error.message === undefined ? error.reason : error.message}`); - console.log(error); - navigator.geolocation.clearWatch(id); - } - - async function wsClose(error) { - console.log(error); - document.getElementById("error").innerText = `websocket closed (reason: ${error.reason}). reconnecting …`; - navigator.geolocation.clearWatch(id); - setTimeout(openWebsocket, 1000); - } - - function wsMsg(msg) { - let json = JSON.parse(msg.data); - console.log(json); - document.getElementById("delay").innerText = - `${json.delay}s (${Math.floor(json.delay / 60)}min)`; - document.getElementById("sequence").innerText = json.sequence; - } - - - function initGeopos() { - document.getElementById("error").innerText = ""; - id = navigator.geolocation.watchPosition( - geoPing, - geoError, - {enableHighAccuracy: true} - ); - } - - - function openWebsocket () { - ws = new WebSocket((location.protocol == "http:" ? "ws" : "wss") + "://" + location.host + "/api/train/ping/ws"); - ws.onerror = wsError; - ws.onclose = wsClose; - ws.onmessage = wsMsg - ws.onopen = (event) => initGeopos(); - } - - async function geoPing(geoloc) { - console.log("got position update " + counter); - document.getElementById("lat").innerText = geoloc.coords.latitude; - document.getElementById("long").innerText = geoloc.coords.longitude; - document.getElementById("acc").innerText = geoloc.coords.accuracy; - - ws.send(JSON.stringify({ - token: token, - lat: geoloc.coords.latitude, - long: geoloc.coords.longitude, - timestamp: (new Date()).toISOString() - })); - counter += 1; - document.getElementById("status").innerText = `sent ${counter} pings`; - } - - - async function main() { - let trip = await (await fetch("/api/trip/#{tripId}")).json(); - console.log("got trip info"); - - token = await (await fetch("/api/train/register/#{tripId}", { - method: "POST", - body: JSON.stringify({agent: "onboard-unit"}), - headers: {"Content-Type": "application/json"} - })).json(); - - - if (token.error) { - alert("could not obtain token: \n" + token.msg); - document.getElementById("status").innerText = "_{MsgTokenFailed}"; - } else { - console.log("got token"); - - document.getElementById("token").innerText = token; - - openWebsocket(); - } - } - - main() @@ -1,42 +1,97 @@ #+TITLE: Traintrack Todos +* Bugs found 2024-05-01 +** PROGRESS train anchors are sorted wrong +probably based on sequence number, not based on time. results in "stuck" +nonsensical delay information if we had a mistaken geolocation in the middle +of the route too early -* DONE Handle service announcements -(per trip & day, nothing else needs to be supported) -* DONE allow trip ping ingest via websockets +changed to creation date, check in production +** TODO auto-reconnect of /tracker websocket fails after android has gone to sleep +** TODO stations with longer stopovers than ~2 minutes break delay extrapolation +** TODO head-turn at Passau (Gr) breaks delay extrapolation +here the train has to stop & change direction, but is not in a station. +Stefan says this usually takes ~5 minutes. Breaks delay predictions during +that time, since we assume linear movement. +** DONE /tracker should remember its token, not constantly open a new one +either via a cookie or url parameter & redirect +** DONE do not give tripupdates after tickets are completed or outdated +another update: this is also triggered for tickets which are still running, +but their last ping was a while ago. +** TODO tickets are not reliably marked completed +** TODO any kind of check against unrealistically fast travel? +** DONE matching of tokens to trip ought not to assume trips are at their start position +this produces horrible results if the tracker is started towards a trip's end * TODO implement GTFS realtime -(this actually doesn't look too bad?) -** DONE do the protobuf stuff -** DONE implement vehicle positions -** DONE implement service alerts -** DONE implement trip updates -** TODO test against actual real-world applications & stuff -* TODO frontend stuff ("leitstelle"/controlroom) -** DONE do stuff with yesod -** TODO auth (openID? How to test?) -** TODO dynamic content via logging/monitoring etc. +** TODO get google to accept trip updates +** DONE get google to accept service alerts +** TODO re-implement vehicle updates +* TODO web frontend ("Leitsystem") ** TODO nicer rendering for timestamps (e.g. "in three minutes", "5 seconds ago", etc.) ** TODO more cross-references (e.g. list of dates on which a trip runs) ** TODO links to osm / embed leaflet -* TODO decent-ish config files (probably yaml … sigh …) -** DONE basic config -** TODO more options, esp. regarding extrapolation -* DONE estimate delays -basically: list of known delays in a db table, either generated from -trip pings & estimates or user-defined in the control room -** DONE properly handle timezones during gtfs parsing so no one else has to deal with that -turns out that's impossible, but it looks to be fine the way it is now -* TODO "turn off" a specific trip (as workaround in case it's cancelled or something) +** TODO better import workflow +be careful to deduplicate things wherever possible (e.g. shapes), and make +it easy to import single trips & <range of time>. +** TODO prevent double imports +should either error or (optionally) update the existing trip (perhaps change +the completed-field of tickets int a status: scheduled (can still be changed +by imports), in-progress (currently underway), done, archived) +* TODO build a better onboard unit +Friedrich still likes the idea of dedicated hardware (so people won't have to +remember turning it on). I kinda like the idea of an android app for the +onboard tablet. If it always displays current information, people might even +remember to turn it on (at least people were interested today – 2024-05-01) +** IDEA display a warning on it if there's another tracker for the same trip +** IDEA display a warning on it if it's > 100m away from tracks +(possibly also make the server discard data in such cases) +* TODO replace the gtfs-based sequence with my own index during import +this should enforce that the difference between stations is always exactly 1 +(& possibly also that the first station is 0) +* TODO somehow handle extra data without polluting the GTFS +** TODO gtfs blocks for handling trips done by the same vehicle +** TODO everything else goes into the database & can be inserted via the web frontend +* TODO "cronjobs" that check for odd things +things like: trip is scheduled to run, but has no tracker, trip has unreasonable +delay values (< -5, > 40 or so) +* IDLE look at hasql-th for database things +https://hackage.haskell.org/package/hasql-th -* TODO do lots and lots of testing -* DONE tracker stuff (as website) -* IDLE monitoring stuff (at least a grafana with trains would be nice) -probably requires a fork of that grafana package -* IDLE somehow handle extra data (e.g. track kilometres) without polluting the GTFS -** TODO same for "how do we know how much we can reduce delay between stops?" -** DONE can use block_id for turnaround times -* IDLE Handle extraordinary trips +this would be another major rework, but persistent really is a little annoying +to use … +* IDLE UI for entering custom / ad-hoc trips (i.e. those outside the gtfs schedule) * IDLE handle partially cancelled trips * IDLE find out if we need to support VDV standards focus on gtfs rt first +* IDLE better sql library +persistent is sometimes weird to use, and without any support for joins some +queries are just unreasonably wordy (& inefficient), requiring lots of mapM. +It also has horrible mapping for datatypes (almost all i use are natively +supported by postgres, but persistent stores most things as var char) + +* DONE re-do configuration, replace conferer, possibly write own config library +conferer is okay-ish, but it cannot (?) give warnings for config items that +were e.g. misspelled in a yaml file. There's also no easy way to figure out +where a config value came from afterwards. +* done before 0.0.2 +** DONE estimate delays +basically: list of known delays in a db table, either generated from +trip pings & estimates or user-defined in the control room +*** DONE properly handle timezones during gtfs parsing so no one else has to deal with that +turns out that's impossible, but it looks to be fine the way it is now +** DONE "turn off" a specific trip (as workaround in case it's cancelled or something) +** DONE do lots and lots of testing +** DONE tracker stuff (as website) +** DONE do stuff with yesod +** DONE auth (openID? How to test?) +** DONE Handle service announcements +(per trip & day, nothing else needs to be supported) +** DONE allow trip ping ingest via websockets +** DONE implement gtfs realtime +*** DONE do the protobuf stuff +*** DONE implement vehicle positions +*** DONE implement service alerts +*** DONE implement trip updates +*** DONE switch to proto-lens library +protocol-buffers is sadly undermaintained, and a bit unwieldy to use diff --git a/tools/obu-guess-trip b/tools/obu-guess-trip index b9264f6..32aa6d4 100755 --- a/tools/obu-guess-trip +++ b/tools/obu-guess-trip @@ -44,8 +44,9 @@ Arguments: (define pos (with-input-from-process `(obu-ping -s ,statefile -n 1 -d) read)) (define guessed - (closest-stop-to stops pos)) + (closest-stop-to stops pos)) (define trip (assoc-ref guessed 'trip)) + (display stops) (do-process `(obu-config -s ,statefile sequencelength ,(assoc-ref guessed 'sequencelength))) (display trip)) @@ -68,7 +69,7 @@ Arguments: (define day (date->string (current-date) "~1")) (define tls (equal? (uri-ref url 'scheme) "https")) - (parameterize + (define thing (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)))) <>)]) @@ -76,3 +77,5 @@ Arguments: (values-ref (http-get (uri-ref url 'host+port) (format "/api/timetable/stops/~a" day) :secure tls) 2)))) + (display thing) + thing) diff --git a/tools/obu-state.edn b/tools/obu-state.edn index db989c8..b0c4b0e 100644 --- a/tools/obu-state.edn +++ b/tools/obu-state.edn @@ -1 +1 @@ -{token "5ab95c26-367e-40fc-8d3e-2956af6f61e4"}
\ No newline at end of file +{sequencelength "#f"}
\ No newline at end of file diff --git a/tracktrain-conftrack-deps.patch b/tracktrain-conftrack-deps.patch new file mode 100644 index 0000000..416f860 --- /dev/null +++ b/tracktrain-conftrack-deps.patch @@ -0,0 +1,12 @@ +diff --git a/conftrack.cabal b/conftrack.cabal +index efc198f..ac17b62 100644 +--- a/conftrack.cabal ++++ b/conftrack.cabal +@@ -56,6 +56,7 @@ library + , file-io >= 0.1.1 && < 0.2 + , template-haskell >= 2.20.0 && < 2.21 + , directory >= 1.3.8 && < 1.4 ++ , os-string + hs-source-dirs: src + default-language: GHC2021 + diff --git a/tracktrain.cabal b/tracktrain.cabal index e763f6d..fb9cc70 100644 --- a/tracktrain.cabal +++ b/tracktrain.cabal @@ -1,31 +1,22 @@ cabal-version: 2.4 name: tracktrain -version: 0.1.0.0 - --- A short (one-line) description of the package. -synopsis: tracktrain tracks trains on their traintracks - --- A longer description of the package. --- description: - --- A URL where users can report bugs. --- bug-reports: - --- The license under which the package is released. --- license: +version: 0.0.2.0 +synopsis: tracktrain tracks trains on their traintracks +description: A passenger information system backend for the Ilztalbahn +license: EUPL-1.2 author: stuebinm maintainer: stuebinm@disroot.org -- A copyright notice. -- copyright: --- category: + extra-source-files: CHANGELOG.md executable tracktrain main-is: Main.hs ghc-options: -threaded -rtsopts - build-depends: base ^>=4.17 - , bytestring ^>= 0.11 + build-depends: base + , bytestring ^>= 0.12 , fmt >= 0.6.3.0 , time , aeson @@ -36,24 +27,25 @@ executable tracktrain , persistent-postgresql , monad-logger , gtfs-realtime - , conferer - , conferer-aeson - , conferer-yaml + , conftrack , directory , extra , proto-lens + , filepath >= 1.4.100 hs-source-dirs: app - default-language: Haskell2010 + default-language: GHC2021 default-extensions: OverloadedStrings , ScopedTypeVariables + , BlockArguments + , LambdaCase library - build-depends: base ^>=4.17 + build-depends: base , gtfs-realtime , zip-archive , cassava >= 0.5.2.0 - , bytestring ^>= 0.11 + , bytestring ^>= 0.12 , uri-bytestring , vector >= 0.12.3.1 , regex-tdfa @@ -91,25 +83,29 @@ library , yesod , yesod-form , yesod-auth - , yesod-auth-oauth2 + , yesod-auth-oauth2 ^>= 0.7.4.0 , yesod-core , hoauth2 , blaze-html , blaze-markup , timezone-olson , timezone-series - , conferer - , conferer-warp + , conftrack , prometheus-client , prometheus-metrics-ghc , exceptions , proto-lens , http-media + , filepath >= 1.4.100 + , monad-control + , esqueleto + , base64 + , network-uri hs-source-dirs: lib exposed-modules: GTFS , Server , Server.GTFS_RT - , Server.ControlRoom + , Server.Frontend , PersistOrphans , Persist , Extrapolation @@ -118,14 +114,34 @@ library other-modules: Server.Util , Yesod.Auth.Uffd , Yesod.Orphans - default-language: Haskell2010 + , MultiLangText + , Server.Base + , Server.Ingest + , Server.Subscribe + , Server.Frontend.Routes + , Server.Frontend.Tickets + , Server.Frontend.OnboardUnit + , Server.Frontend.Gtfs + , Server.Frontend.SpaceTime + , Server.Frontend.Ticker + , Server.Frontend.Tracker + , OwnTracks + , OwnTracks.Location + , OwnTracks.Status + , OwnTracks.Configuration + , OwnTracks.Command + , OwnTracks.Waypoint + default-language: GHC2021 default-extensions: OverloadedStrings , ScopedTypeVariables , ViewPatterns + , BlockArguments + , LambdaCase + , RecordWildCards library gtfs-realtime - build-depends: base ^>=4.17 - , proto-lens-runtime + build-depends: base + , proto-lens-runtime default-language: Haskell2010 hs-source-dirs: gtfs-realtime exposed-modules: Proto.GtfsRealtime |