diff options
39 files changed, 2391 insertions, 1303 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/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..37248e7 100644 --- a/default.nix +++ b/default.nix @@ -4,10 +4,32 @@ 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"; + revision = "1"; + editedCabalFile = "0wx03gla2x51llwng995snp9lyg1msnyf0337hd1ph9874zcadxr"; + libraryHaskellDepends = [ + aeson base bytestring containers directory file-io filepath mtl + scientific template-haskell text transformers yaml + ]; + 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, 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 +49,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 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 +61,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 +85,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 (..)) @@ -34,7 +31,6 @@ import Servant.API (Accept, Capture, Get, JSON, Post, QueryParam, Raw, ReqBody, type (:<|>) (..)) import Servant.API.WebSocket (WebSocket) --- import Servant.GTFS.Realtime (Proto) import Servant.Swagger (HasSwagger (..)) import Web.Internal.FormUrlEncoded (Form) @@ -44,55 +40,47 @@ 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 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 + { sentPingToken :: 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 + "tracker" :> "register" :> ReqBody '[JSON] RegisterJson :> Post '[JSON] Token + :<|> "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 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 + :<|> "debug" :> "pings" :> Capture "Ticket Id" UUID :> Get '[JSON] [TrainPing] :<|> "gtfs.zip" :> Get '[OctetStream] GTFSFile :<|> "gtfs" :> GtfsRealtimeAPI --- | The API used for publishing gtfs realtime updates type GtfsRealtimeAPI = "servicealerts" :> Get '[Proto] FeedMessage :<|> "tripupdates" :> Get '[Proto] FeedMessage :<|> "vehiclepositions" :> Get '[Proto] FeedMessage --- | 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 @@ -107,6 +95,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 "trainPing") + -- TODO write something useful here! (and if it's just "hey this is some websocket thingie") @@ -132,7 +134,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..88206f1 100644 --- a/lib/Config.hs +++ b/lib/Config.hs @@ -1,15 +1,22 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE RecordWildCards #-} --- | - -module Config where -import Conferer (DefaultConfig (configDef)) -import Conferer.FromConfig -import Conferer.FromConfig.Warp () +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} + +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,85 @@ 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 + } deriving (Generic) + +data LoggingConfig = LoggingConfig + { loggingConfigNtfyToken :: Maybe Text + , loggingConfigNtfyTopic :: Text + , loggingConfigHostname :: Text } deriving (Generic) -instance FromConfig ServerConfig - -instance DefaultConfig ServerConfig where - configDef = ServerConfig - { serverConfigWarp = configDef - , serverConfigDbString = "" - , serverConfigGtfs = "./gtfs.zip" - , serverConfigAssets = "./assets" - , serverConfigZoneinfoPath = "/etc/zoneinfo/" - , serverConfigLogin = configDef - } - -instance DefaultConfig UffdConfig where - configDef = UffdConfig uri "secret" "uffdclient" False - where Right uri = parseURI strictURIParserOptions "http://www.example.org" - -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 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) + + prettyValue uri = decodeUtf8 (serializeURIRef' uri) + +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|ntfyToken|] + <*> 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|] + diff --git a/lib/Extrapolation.hs b/lib/Extrapolation.hs index 5adc074..759b31e 100644 --- a/lib/Extrapolation.hs +++ b/lib/Extrapolation.hs @@ -1,48 +1,56 @@ -{-# 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 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 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 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, + Token (..), Tracker (..), + 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 +59,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 - - 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 + 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 + + -- 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 +133,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..4f3a311 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 @@ -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/Persist.hs b/lib/Persist.hs index a8ed15e..637155a 100644 --- a/lib/Persist.hs +++ b/lib/Persist.hs @@ -1,18 +1,10 @@ -{-# 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. @@ -24,19 +16,26 @@ import Data.Swagger (ToParamSchema (..), ToSchema (..), 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,10 +43,13 @@ 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 Server.Util (runLogging) import Web.PathPieces (PathPiece) +import Yesod (Lang) newtype Token = Token UUID @@ -60,75 +62,143 @@ instance ToSchema Token where instance ToParamSchema Token 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 share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| +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 + -- | tokens which have been issued -Running sql=tt_tracker_token +Tracker sql=tt_tracker_token Id Token default=uuid_generate_v4() expires UTCTime blocked Bool - trip Text - day Day - vehicle Text Maybe agent Text + currentTicket TicketId Maybe deriving Eq Show Generic +TrackerTicket + ticket TicketId OnDeleteCascade OnUpdateCascade + tracker TrackerId OnDeleteCascade OnUpdateCascade + UniqueTrackerTicket ticket tracker + -- raw frames as received from OBUs TrainPing json sql=tt_trip_ping - token RunningId - lat Double - long Double + ticket TicketId OnDeleteCascade OnUpdateCascade + token TrackerId OnDeleteSetNull OnUpdateCascade + geopos Geopos timestamp UTCTime + sequence Double 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? 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") + declareNamedSchema = genericDeclareNamedSchema (GTFS.swaggerOptions "trainPing") 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..3fc2c5a 100644 --- a/lib/Server.hs +++ b/lib/Server.hs @@ -1,231 +1,122 @@ -{-# 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 (handleTrackerRegister, + handleTrainPing, 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 + :<|> handleTrainPing dbpool subscribers settings (throwError err401) + :<|> handleWS dbpool subscribers settings metrics + :<|> handleCurrentTicker + :<|> handleSubscribe dbpool subscribers + :<|> handleDebugState :<|> handleDebugTrain + :<|> pure (GTFS.gtfsFile gtfs) :<|> gtfsRealtimeServer gtfs dbpool) + :<|> 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 token@(TrackerKey uuid) _) -> do + entities <- selectList [TrainPingToken ==. token] [] + 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 token _) -> do + selectList [TrainPingToken ==. token] [] <&> fmap entityVal + pure (concat pings) + handleDebugAPI = pure $ toSwagger (Proxy @API) + handleMetrics = exportMetricsAsText <&> (decodeUtf8 . toStrict) -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..14b77ca --- /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 (TrainPing) + +type ServerState = TVar (M.Map UUID [TQueue (Maybe TrainPing)]) 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..a9c2f69 --- /dev/null +++ b/lib/Server/Frontend.hs @@ -0,0 +1,22 @@ +{-# 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 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..6a8fe6e --- /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>Token:</strong> <span id="token"> + <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 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; + + 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({ + token: token, + 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); + + token = urlparams.get("token"); + + if (token === null) { + token = await (await fetch("/api/tracker/register/", { + method: "POST", + body: JSON.stringify({agent: "tracktrain-website"}), + headers: {"Content-Type": "application/json"} + })).json(); + + if (token.error) { + alert("could not obtain token: \n" + token.msg); + setStatus("_{MsgTokenFailed}"); + } else { + console.log("got token"); + window.location.search = `?token=${token}`; + } + } + + console.log(token) + + if (token !== null) { + document.getElementById("token").innerText = token; + openWebsocket(); + } + } + + main() + |] diff --git a/lib/Server/Frontend/Routes.hs b/lib/Server/Frontend/Routes.hs new file mode 100644 index 0000000..9245e6a --- /dev/null +++ b/lib/Server/Frontend/Routes.hs @@ -0,0 +1,151 @@ +{-# 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 (Token) +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 + +/ticker/announce TickerAnnounceR POST +/ticker/delete TickerDeleteR POST + +/spacetime SpaceTimeDiagramR GET + +/token/block/#Token TokenBlock 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..861197a --- /dev/null +++ b/lib/Server/Frontend/Ticker.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Server.Frontend.Ticker (tickerWidget, postTickerAnnounceR, postTickerDeleteR) where +import Data.Functor ((<&>)) +import Data.Time (getCurrentTime) +import Persist (EntityField (TickerAnnouncementArchived), + TickerAnnouncement (..)) +import Server.Frontend.Routes (FrontendMessage (..), Handler, + Route (..), Widget) +import Yesod + + +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 $ selectFirst [ TickerAnnouncementArchived ==. False ] [] + + (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 $ selectFirst [ TickerAnnouncementArchived ==. False ] [] + ((result, widget), enctype) <- + runFormPost (tickerAnnounceForm (current <&> entityVal)) + case result of + FormSuccess ann -> do + runDB $ do + updateWhere [] [ TickerAnnouncementArchived =. 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 $ updateWhere [] [ TickerAnnouncementArchived =. True ] + redirect RootR diff --git a/lib/Server/Frontend/Tickets.hs b/lib/Server/Frontend/Tickets.hs new file mode 100644 index 0000000..9b88a48 --- /dev/null +++ b/lib/Server/Frontend/Tickets.hs @@ -0,0 +1,404 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} + +module Server.Frontend.Tickets + ( getTicketsR + , postGtfsTicketImportR + , getTicketViewR + , getTicketMapViewR + , getDelAnnounceR + , postAnnounceR + , getTokenBlock + ) 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 Yesod +import Yesod.Auth +import Yesod.Auth.Uffd (UffdUser (..), uffdClient) + + +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 ==. 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 $ selectList [ TicketDay ==. day ] [ Asc TicketTripName ] >>= mapM (\ticket -> do + stops <- selectList [ StopTicket ==. entityKey ticket ] [] + startStation <- getJust (stopStation $ entityVal $ head stops) + pure (ticket, startStation, fmap entityVal stops)) + + 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 (Entity (TicketKey ticketId) Ticket{..}, startStation, stops) <- tickets + <li><a href="@{TicketViewR ticketId}">_{MsgTrip} #{ticketTripName}</a> + : _{Msgdep} #{stopDeparture (head stops)} #{stationName startStation} → #{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 $ do + maybeExists <- selectFirst [ StationShortName ==. stationId ] [] + case maybeExists of + Nothing -> do + key <- insert Station + { stationGeopos = Geopos (stationLat, stationLon) + , stationShortName = stationId , stationName } + pure (stationId, key) + Just (Entity key _) -> pure (stationId, key)) + <&> 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 $ selectList [StopTicket ==. ticketKey] [] >>= mapM (\stop -> do + station <- getJust (stopStation (entityVal stop)) + pure (entityVal stop, station)) + + anns <- runDB $ selectList [ AnnouncementTicket ==. ticketKey ] [] + joins <- runDB $ selectList [ TrackerTicketTicket ==. ticketKey ] [] + <&> fmap (trackerTicketTracker . entityVal) + trackers <- runDB $ selectList + ([ TrackerId <-. joins ] ||. [ TrackerCurrentTicket ==. Just ticketKey ]) + [Asc TrackerExpires] + lastPing <- runDB $ selectFirst [ TrainPingTicket ==. coerce ticketId ] [Desc TrainPingTimestamp] + anchors <- runDB $ selectList [ TrainAnchorTicket ==. ticketKey ] [] + <&> nonEmpty . fmap entityVal + + spaceTimeMaybe <- mkSpaceTimeDiagramHandler 2 ticketDay [ TicketId ==. 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 _ TrainPing{..} <- lastPing + _{MsgTrainPing (latitude trainPingGeopos) (longitude trainPingGeopos) trainPingTimestamp} + (<a href="/api/debug/pings/#{UUID.toString ticketId}/#{ticketDay}">_{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="@{TicketMapViewR ticketId}">_{MsgMap}</a> +<section> + <h2>_{MsgStops} + <ol> + $forall (Stop{..}, 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>_{MsgTokens} + <table> + <tr><th style="width: 20%">_{MsgAgent}</th><th style="width: 50%">_{MsgToken}</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} + <td title="#{trackerExpires}">#{trackerExpires} + $if trackerBlocked + <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 + + +getTicketMapViewR :: UUID -> Handler Html +getTicketMapViewR ticketId = do + Ticket{..} <- runDB $ get (TicketKey ticketId) + >>= \case { Nothing -> notFound ; Just ticket -> pure ticket } + + stops <- runDB $ selectList [StopTicket ==. TicketKey ticketId] [] >>= mapM (\stop -> do + station <- getJust (stopStation (entityVal stop)) + pure (entityVal 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 (AnnouncementKey uuid) + pure a + case ann of + Nothing -> notFound + Just Announcement{..} -> + let (TicketKey ticketId) = announcementTicket + in redirect (TicketViewR ticketId) + +getTokenBlock :: Token -> Handler Html +getTokenBlock token = do + YesodRequest{..} <- getRequest + let blocked = lookup "unblock" reqGetParams /= Just "true" + maybe <- runDB $ do + update (TrackerKey token) [ TrackerBlocked =. blocked ] + get (TrackerKey token) + 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/GTFS_RT.hs b/lib/Server/GTFS_RT.hs index cfb02ce..5ad4b40 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 #-} @@ -12,17 +12,18 @@ 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 +32,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) + Station (..), Stop (..), + Ticket (..), Token (..), + Tracker (..), TrainAnchor (..), + TrainPing (..), latitude, + longitude, runSql) import qualified Proto.GtfsRealtime as RT import qualified Proto.GtfsRealtime_Fields as RT import Servant.API ((:<|>) (..)) @@ -71,17 +75,20 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool = where handleServiceAlerts = runSql dbpool $ do announcements <- selectList [] [] - defFeedMessage (fmap mkAlert announcements) + alerts <- forM announcements $ \(Entity (AnnouncementKey uuid) announcement@Announcement{..}) -> do + ticket <- getJust announcementTicket + pure $ mkAlert uuid announcement ticket + defFeedMessage alerts 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 @@ -89,74 +96,93 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool = ) handleTripUpdates = runSql dbpool $ do - today <- liftIO $ getCurrentTime <&> utctDay + 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 + + defFeedMessage (catMaybes tripUpdates) handleVehiclePositions = runSql dbpool $ do - (running :: [Entity Running]) <- selectList [] [] - pings <- forM running $ \(Entity key entity) -> do - selectFirst [TrainPingToken ==. key] [] <&> fmap (, entity) - defFeedMessage (mkPosition <$> catMaybes pings) + + 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 [TrainPingTicket ==. key] [Desc TrainPingTimestamp] >>= \case + -- Nothing -> pure Nothing + -- Just lastPing -> + -- pure (Just $ mkPosition (lastPing, ticket)) + + defFeedMessage [] -- (catMaybes positions) where - mkPosition :: (Entity TrainPing, Running) -> RT.FeedEntity - mkPosition (Entity (TrainPingKey key) TrainPing{..}, Running{..}) = defMessage + mkPosition :: (Entity TrainPing, Ticket) -> RT.FeedEntity + mkPosition (Entity key TrainPing{..}, 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 trainPingGeopos) + & RT.longitude .~ double2Float (longitude trainPingGeopos) ) -- TODO: should probably give currentStopSequence/stopId here as well & RT.timestamp .~ toStupidTime trainPingTimestamp @@ -181,7 +207,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..959a4c6 --- /dev/null +++ b/lib/Server/Ingest.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} + +module Server.Ingest (handleTrackerRegister, handleTrainPing, handleWS) 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, 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, throwError) +import Servant.Server (Handler) +import Server.Util (ServiceM, getTzseries, + utcToSeconds) + +import Config (LoggingConfig, + ServerConfig (..)) +import Control.Exception (throw) +import Control.Monad.Logger.CallStack (logErrorN) +import Data.ByteString (ByteString) +import Data.ByteString.Lazy (toStrict) +import Data.Foldable (find, minimumBy) +import Data.Function (on, (&)) +import qualified Data.Text as T +import Data.Time.LocalTime.TimeZone.Series (TimeZoneSeries) +import qualified Data.UUID as UUID +import Extrapolation (Extrapolator (..), + LinearExtrapolator (..), + euclid) +import GHC.Generics (Generic) +import GTFS (seconds2Double) +import Prometheus (decGauge, incGauge) +import Server.Base (ServerState) + + +handleTrackerRegister + :: Pool SqlBackend + -> RegisterJson + -> ServiceM Token +handleTrackerRegister dbpool RegisterJson{..} = do + today <- liftIO getCurrentTime <&> utctDay + expires <- liftIO $ getCurrentTime <&> addUTCTime validityPeriod + runSql dbpool $ do + TrackerKey tracker <- insert (Tracker expires False registerAgent Nothing) + pure tracker + where + validityPeriod :: NominalDiffTime + validityPeriod = nominalDay + +handleTrainPing + :: Pool SqlBackend + -> ServerState + -> ServerConfig + -> LoggingT (ReaderT LoggingConfig Handler) a + -> SentPing + -> LoggingT (ReaderT LoggingConfig Handler) (Maybe TrainAnchor) +handleTrainPing dbpool subscribers cfg onError ping@SentPing{..} = + isTokenValid dbpool sentPingToken >>= \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 sentPingToken)|+ + " sent a ping, but no trips are running today." + throwError err400 + + + runSql dbpool $ insertSentPing subscribers cfg ping tracker ticketId + +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 + [ TrainPingTicket ==. ticketId ] + [ Desc TrainPingTimestamp ] + <&> find (\ping -> trainPingSequence (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 sentPingToken + [TrackerCurrentTicket =. Just newTicketId ] + logInfoN $ "tracker "+|UUID.toText (coerce sentPingToken)|+ + "has switched direction, and was reassigned to ticket " + +|UUID.toText (coerce newTicketId)|+"." + insertSentPing subscribers cfg ping tracker newTicketId + Nothing -> do + let trackedPing = TrainPing + { trainPingToken = sentPingToken + , trainPingGeopos = sentPingGeopos + , trainPingTimestamp = sentPingTimestamp + , trainPingSequence = trainAnchorSequence anchor + , trainPingTicket = 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 sentPingToken + [TrackerCurrentTicket =. Nothing] + update ticketId + [TicketCompleted =. True] + logInfoN $ "Tracker "+|UUID.toString (coerce sentPingToken)|+ + " 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 token, send a "polite" close request. Note that the client may + -- ignore this and continue sending messages, which will continue to be handled. + handleTrainPing 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 sentPingToken)|+ + " is now handling ticket "+|UUID.toString (coerce (entityKey closestTicket))|+ + " (trip "+|ticketTripName (entityVal closestTicket)|+")." + + update sentPingToken + [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 tokens +isTokenValid :: Pool SqlBackend -> TrackerId -> ServiceM (Maybe Tracker) +isTokenValid dbpool token = runSql dbpool $ get token >>= \case + Just tracker | not (trackerBlocked tracker) -> do + 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..831f4c9 --- /dev/null +++ b/lib/Server/Subscribe.hs @@ -0,0 +1,63 @@ + +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.Persist (Entity (entityKey), SelectOpt (Desc), + entityVal, selectFirst, selectList, + (<-.), (==.), (||.)) +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 + (selectFirst [TrainPingTicket ==. coerce ticketId] [Desc TrainPingTimestamp]) + <&> 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 = do + 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 - -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) - -type ServiceM = LoggingT Handler +module Server.Util (Service, ServiceM, runService, sendErrorMsg, secondsNow, utcToSeconds, runLogging, getTzseries, serveDirectoryFileServer) where + +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 (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/messages/de.msg b/messages/de.msg index 016ebbb..f3748df 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -36,7 +36,12 @@ 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 diff --git a/messages/en.msg b/messages/en.msg index ecaad0a..c20149a 100644 --- a/messages/en.msg +++ b/messages/en.msg @@ -36,7 +36,13 @@ 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 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.cabal b/tracktrain.cabal index e763f6d..8f81229 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,23 @@ 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 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 @@ -98,18 +88,19 @@ library , 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 hs-source-dirs: lib exposed-modules: GTFS , Server , Server.GTFS_RT - , Server.ControlRoom + , Server.Frontend , PersistOrphans , Persist , Extrapolation @@ -118,14 +109,24 @@ 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 + default-language: GHC2021 default-extensions: OverloadedStrings , ScopedTypeVariables , ViewPatterns 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 |