diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/API.hs | 85 | ||||
| -rw-r--r-- | lib/Config.hs | 131 | ||||
| -rw-r--r-- | lib/Extrapolation.hs | 170 | ||||
| -rw-r--r-- | lib/GTFS.hs | 86 | ||||
| -rw-r--r-- | lib/MultiLangText.hs | 12 | ||||
| -rw-r--r-- | lib/Persist.hs | 182 | ||||
| -rw-r--r-- | lib/Server.hs | 291 | ||||
| -rw-r--r-- | lib/Server/Base.hs | 9 | ||||
| -rw-r--r-- | lib/Server/ControlRoom.hs | 446 | ||||
| -rw-r--r-- | lib/Server/Frontend.hs | 22 | ||||
| -rw-r--r-- | lib/Server/Frontend/Gtfs.hs | 57 | ||||
| -rw-r--r-- | lib/Server/Frontend/OnboardUnit.hs | 174 | ||||
| -rw-r--r-- | lib/Server/Frontend/Routes.hs | 151 | ||||
| -rw-r--r-- | lib/Server/Frontend/SpaceTime.hs | 195 | ||||
| -rw-r--r-- | lib/Server/Frontend/Ticker.hs | 63 | ||||
| -rw-r--r-- | lib/Server/Frontend/Tickets.hs | 404 | ||||
| -rw-r--r-- | lib/Server/GTFS_RT.hs | 150 | ||||
| -rw-r--r-- | lib/Server/Ingest.hs | 275 | ||||
| -rw-r--r-- | lib/Server/Subscribe.hs | 63 | ||||
| -rw-r--r-- | lib/Server/Util.hs | 103 |
20 files changed, 2085 insertions, 984 deletions
@@ -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 |