aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--.envrc1
-rw-r--r--.gitignore1
-rw-r--r--CHANGELOG.md9
-rw-r--r--GLOSSARY.md78
-rw-r--r--GLOSSARY.org66
-rw-r--r--app/GenJS.hs14
-rw-r--r--config.yaml.sample (renamed from config.yaml)8
-rw-r--r--hie.yaml10
-rw-r--r--lib/API.hs72
-rw-r--r--lib/Config.hs22
-rw-r--r--lib/Extrapolation.hs166
-rw-r--r--lib/GTFS.hs72
-rw-r--r--lib/MultiLangText.hs12
-rw-r--r--lib/Persist.hs175
-rw-r--r--lib/Server.hs354
-rw-r--r--lib/Server/ControlRoom.hs413
-rw-r--r--lib/Server/GTFS_RT.hs136
-rw-r--r--lib/Server/Util.hs53
-rw-r--r--messages/de.msg3
-rw-r--r--messages/en.msg4
-rw-r--r--shell.nix5
-rw-r--r--site/obu.hamlet6
-rw-r--r--site/tracker.hamlet137
-rw-r--r--todo.org1
-rwxr-xr-xtools/obu-guess-trip7
-rw-r--r--tools/obu-state.edn2
-rw-r--r--tracktrain.cabal26
27 files changed, 1196 insertions, 657 deletions
diff --git a/.envrc b/.envrc
new file mode 100644
index 0000000..1d953f4
--- /dev/null
+++ b/.envrc
@@ -0,0 +1 @@
+use nix
diff --git a/.gitignore b/.gitignore
index aff2958..8591317 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,3 +1,4 @@
dist-newstyle/*
result
gtfs.zip
+config.yaml
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 1df15d0..9ad039c 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,5 +1,10 @@
-# Revision history for haskell-gtfs
+# Revision history for tracktrain
-## 0.1.0.0 -- YYYY-mm-dd
+
+## 0.0.2.0 -- 2024-05-??
+* Hopefully first version usable in production?
+
+## 0.0.1.0 -- ~ 2022-11-01
* First version. Released on an unsuspecting world.
+* First version which could successfully send data to Google
diff --git a/GLOSSARY.md b/GLOSSARY.md
new file mode 100644
index 0000000..062f897
--- /dev/null
+++ b/GLOSSARY.md
@@ -0,0 +1,78 @@
+# Glossary
+
+This is meant to give a rough overview of (train-related) terms used in
+this code; both for others as a reference and for me so I can remember
+to use them in a (somewhat) consistent way, since they are somewhat
+arbitrary. I've tried to remain at least broadly close to the
+terminology used by GTFS.
+
+## Terms
+
+Ticket
+: A single tracked trip. These are imported from the GTFS (or couple be created
+ manually via the web interface), and are independent from it, i.e. they are
+ saved in tracktrain's data base and won't change with subsequent GTFS updates,
+ but would have to be deleted and reimported instead.
+
+ This prevents tracktrain from ending up with invalid data if a trip's id
+ or stops change retroactively.
+
+Trip (don't confuse with Train)
+: Used as in GTFS: a trip is a defined sequence of *stops*, referred to by
+ a number (called its trip ID, e.g. IC 94). Usually runs on multiple
+ days. Always has an associated *shape*.
+
+ (might match your intuition for "train line")
+
+(Calendar-)Date / Day
+: A single, unique day (e.g. 1970-01-01). Usually used to indicate if a
+ *trip* is running on that day or not.
+
+Seconds (on a given Day)
+: Time on a given day, given in seconds (though often displayed as
+ minutes) since midnight. If a trip crosses midnight it is treated as if
+ it took place entirely on the previous day, and times simply count up
+ beyond the total number of seconds in a day (note that that's a
+ timezone-series dependent number).
+
+Stop
+: A *station* with associated arrival/departure *time*.
+
+Station
+: A train station. Tracktrain refers to each by an ID, and hopefully knows
+ its geolocation.
+
+Shape
+: A sequence of geolocations describing a line between stations,
+ describing the physical railway along which trains travel.
+
+Vehicle
+: An actual, physical vehicle, which might act as the *train* going along
+ a *trip* on a certain *date*.
+
+ For now tracktrain doesn't really care about them (but if it's curious
+ it might yet learn about them!)
+
+Announcement
+: The thing that GTFS calls "Service Alert" --- a text message giving
+ human-readable information about some *train*.
+
+(Train-)Ping
+: A single packet of data sent from a train's *OBU*. Might arrive in some
+ arbitrary order.
+
+(Train-)Anchor
+: An "anchored" point of position of a train along a trip; a snapshot of its
+ delay and state at a known position. These are generated from train pings,
+ and are the basis for extrapolating future delays for passanger information.
+
+Control Room
+: The "admin interface" of tracktrain, which is not meant to be used by
+ on-board staff.
+
+On-Board Unit (OBU)
+: A thing on a vehicle which does geolocation tracking and yells at
+ tracktrain about it.
+
+ If we ever run into potential confusion regarding this term we're
+ probably way too professional to actually use tracktrain for anything.
diff --git a/GLOSSARY.org b/GLOSSARY.org
deleted file mode 100644
index 38cda75..0000000
--- a/GLOSSARY.org
+++ /dev/null
@@ -1,66 +0,0 @@
-#+TITLE: Glossary of Terms
-
-This is meant to give a rough overview of (train-related) terms used in this
-code; both for others as a reference and for me so I can remember to use them
-in a (somewhat) consistent way, since they are somewhat arbitrary. I've tried
-to remain at least broadly close to the terminology used by GTFS.
-
-* Terms
-** (Calendar-)Date / Day
-A single, unique day (e.g. 1970-01-01). Usually used to indicate if a /trip/
-is running on that day or not.
-
-** Time (of Day)
-Time on a given day, given in seconds (though often displayed as minutes)
-since midnight. If a trip crosses midnight it is treated as if it took place
-entirely on the previous day, and times simply count up beyond the total
-number of seconds in a day (note that that's a timezone-series dependent
-number).
-
-** Trip (don't confuse with Train)
-Used as in GTFS: a trip is a defined sequence of /stops/, referred to by a
-number (called its trip ID, e.g. IC 94). Usually runs on multiple days.
-Always has an associated /shape/.
-
-(might match your intuition for "train line")
-
-** Stop
-A /station/ with associated arrival/departure /time/.
-
-** Station
-A train station. Tracktrain refers to each by an ID, and hopefully knows
-its geolocation.
-
-** Shape
-A sequence of geolocations describing a line between stations, describing
-the physical railway along which trains travel.
-
-** Train (don't confuse with Trip)
-A single instance of a /trip/ on a concrete /date/. Tracktrain mostly concerns
-itself with keeping track of those; the rest is just additional stuff.
-
-** Vehicle
-An actual, physical vehicle, which might act as the /train/ going along a
-/trip/ on a certain /date/.
-
-For now tracktrain doesn't really care about them (but if it's curious it
-might yet learn about them!)
-
-** Announcement
-The thing that GTFS calls "Service Alert" — a text message giving
-human-readable information about some /train/.
-
-** (Train-)Ping
-A single packet of data sent from a train's /OBU/. Might arrive in some
-arbitrary order.
-
-** Control Room
-The "admin interface" of tracktrain, which is not meant to be used by on-board
-staff.
-
-** On-Board Unit (OBU)
-A thing on a vehicle which does geolocation tracking and yells at tracktrain
-about it.
-
-If we ever run into potential confusion regarding this term we're probably
-way too professional to actually use tracktrain for anything.
diff --git a/app/GenJS.hs b/app/GenJS.hs
index a580d23..1e7ba3a 100644
--- a/app/GenJS.hs
+++ b/app/GenJS.hs
@@ -4,12 +4,12 @@
-- bother with it
module Main where
-import Universum
-import Servant.JS
-import Servant.JS.Vanilla
-import System.Environment (getArgs)
+import Servant.JS
+import Servant.JS.Vanilla
+import System.Environment (getArgs)
+import Universum
-import API
+import API
apiJS :: Text -> Text
apiJS url = jsForAPI (Proxy @API) (vanillaJSWith options)
@@ -19,6 +19,6 @@ main :: IO ()
main = do
args <- getArgs
case args of
- [] -> putText (apiJS "")
+ [] -> putText (apiJS "")
[prefix] -> putText (apiJS (toText prefix))
- _ -> error "don't understand these options"
+ _ -> error "don't understand these options"
diff --git a/config.yaml b/config.yaml.sample
index 123031d..fef8e5e 100644
--- a/config.yaml
+++ b/config.yaml.sample
@@ -1,16 +1,18 @@
dbstring: "dbname=tracktrain"
-gtfs: "./gtfs.zip"
+gtfs: "gtfs.zip"
zoneinfoPath: "/etc/zoneinfo/"
+assets: ./assets
+
# generic warp server options (see warp docs)
warp:
- port: 9000
+ port: 5000
# only oauth2 with uffd supported (for now)
login:
- enable: true
+ enable: false
clientname: tracktrain
clientsecret: secret
url: http://localhost:8080
diff --git a/hie.yaml b/hie.yaml
deleted file mode 100644
index 4bc07c5..0000000
--- a/hie.yaml
+++ /dev/null
@@ -1,10 +0,0 @@
-cradle:
- cabal:
- - path: "app/Main.hs"
- component: "tracktrain:exe:tracktrain"
-
- - path: "lib"
- component: "lib:tracktrain"
-
- - path: "gtfs"
- component: "tracktrain:lib:gtfs"
diff --git a/lib/API.hs b/lib/API.hs
index b0e12f6..b2635c1 100644
--- a/lib/API.hs
+++ b/lib/API.hs
@@ -1,10 +1,6 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE DataKinds #-}
+{-# 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.
@@ -34,7 +30,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 +39,36 @@ 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)
-
-instance FromJSON RegisterJson where
- parseJSON = genericParseJSON (aesonOptions "register")
-instance ToSchema RegisterJson where
- declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "register")
-instance ToSchema Value where
- declareNamedSchema _ = pure $ NamedSchema (Just "json") $ mempty
- & type_ ?~ SwaggerObject
-
--- | The server's API (as it is actually intended).
-type API = "stations" :> Get '[JSON] (Map StationID Station)
- :<|> "timetable" :> Capture "Station ID" StationID :> QueryParam "day" Day :> Get '[JSON] (Map TripID (Trip Deep Deep))
- :<|> "timetable" :> "stops" :> Capture "Date" Day :> Get '[JSON] Value
- :<|> "trip" :> Capture "Trip ID" TripID :> Get '[JSON] (Trip Deep Deep)
+-- | 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] TrainPing :> Post '[JSON] (Maybe TrainAnchor)
+ :<|> "tracker" :> "ping" :> "ws" :> WebSocket
+ :<|> "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 +83,18 @@ 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
+
-- TODO write something useful here! (and if it's just "hey this is some websocket thingie")
@@ -132,7 +120,7 @@ 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..94fdd28 100644
--- a/lib/Config.hs
+++ b/lib/Config.hs
@@ -1,12 +1,11 @@
-{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RecordWildCards #-}
--- |
-module Config where
+module Config (UffdConfig(..), ServerConfig(..), LoggingConfig(..)) where
import Conferer (DefaultConfig (configDef))
import Conferer.FromConfig
import Conferer.FromConfig.Warp ()
import Data.ByteString (ByteString)
+import Data.Functor ((<&>))
import Data.Text (Text)
import GHC.Generics (Generic)
import Network.Wai.Handler.Warp (Settings)
@@ -26,6 +25,13 @@ data ServerConfig = ServerConfig
, serverConfigAssets :: FilePath
, serverConfigZoneinfoPath :: FilePath
, serverConfigLogin :: UffdConfig
+ , serverConfigLogging :: LoggingConfig
+ } deriving (Generic)
+
+data LoggingConfig = LoggingConfig
+ { loggingConfigNtfyToken :: Maybe Text
+ , loggingConfigNtfyTopic :: Text
+ , loggingConfigHostname :: Text
} deriving (Generic)
instance FromConfig ServerConfig
@@ -38,6 +44,7 @@ instance DefaultConfig ServerConfig where
, serverConfigAssets = "./assets"
, serverConfigZoneinfoPath = "/etc/zoneinfo/"
, serverConfigLogin = configDef
+ , serverConfigLogging = configDef
}
instance DefaultConfig UffdConfig where
@@ -52,3 +59,12 @@ instance FromConfig UffdConfig where
uffdConfigClientSecret <- fetchFromConfig (key /. "clientSecret") config
uffdConfigEnable <- fetchFromConfig (key /. "enable") config
pure UffdConfig {..}
+
+instance FromConfig LoggingConfig where
+ fromConfig key config = LoggingConfig
+ <$> fetchFromConfig (key /. "ntfyToken") config
+ <*> fetchFromConfig (key /. "ntfyTopic") config
+ <*> fetchFromConfig (key /. "name") config
+
+instance DefaultConfig LoggingConfig where
+ configDef = LoggingConfig Nothing "tracktrain" ""
diff --git a/lib/Extrapolation.hs b/lib/Extrapolation.hs
index 5adc074..389d047 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 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 (..),
+ TrainPing (..))
+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
+ -> TrainPing
+ -> 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,7 +59,7 @@ 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)
@@ -59,56 +67,65 @@ instance Extrapolator LinearExtrapolator where
fmap (minimumBy (compare `on` difference))
$ NE.nonEmpty $ sortOn (Down . trainAnchorWhen)
$ 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
+ extrapolateAnchorFromPing _ ticketId Ticket{..} stops shape ping@TrainPing{..} = TrainAnchor
{ trainAnchorCreated = trainPingTimestamp
- , trainAnchorTrip = runningTrip
- , trainAnchorDay = runningDay
- , trainAnchorWhen = utcToSeconds trainPingTimestamp runningDay
+ , trainAnchorTicket = ticketId
+ , trainAnchorWhen = utcToSeconds trainPingTimestamp 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 -> TrainPing -> Day -> (Seconds, Double)
+linearDelay tripStops shape TrainPing{..} 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 trainPingTimestamp 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 trainPingTimestamp 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 trainPingGeopos) 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..cb9be2a 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.)
@@ -96,11 +88,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 +115,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 +130,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 +143,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 +154,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 +193,7 @@ type family Optional c a where
Optional Shallow _ = ()
type StationID = Text
-type TripID = Text
+type TripId = Text
type ServiceID = Text
@@ -226,7 +218,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 +274,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 +487,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
@@ -557,7 +549,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 +587,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 +636,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..46e5ef4 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,134 @@ 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
+ 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
+ tracker TrackerId
+ UniqueTrackerTicket ticket tracker
+
+
-- raw frames as received from OBUs
TrainPing json sql=tt_trip_ping
- token RunningId
- lat Double
- long Double
+ -- ticket TicketId
+ token TrackerId
+ geopos Geopos
timestamp UTCTime
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
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
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
|]
-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")
+
+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
+ -> ReaderT SqlBackend (LoggingT (ResourceT IO)) 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..73c55cb 100644
--- a/lib/Server.hs
+++ b/lib/Server.hs
@@ -1,156 +1,230 @@
{-# 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 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 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.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 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, mapMaybeM, maybeM,
+ unlessM, whenJust, whenM)
+import Control.Monad.IO.Class (MonadIO (liftIO))
+import Control.Monad.Logger (LoggingT, MonadLogger,
+ NoLoggingT, logInfoN,
+ logWarnN)
+import Control.Monad.Reader (MonadReader, ReaderT,
+ forM)
+import Control.Monad.Trans (lift)
+import Data.Aeson ((.=))
+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.Proxy (Proxy (Proxy))
+import Data.Swagger (toSchema)
+import Data.Text (Text)
+import Data.Text.Encoding (decodeASCII, 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 Fmt ((+|), (|+))
-import qualified Network.WebSockets as WS
-import Servant (Application,
- ServerError (errBody), err401,
- err404, serve,
- serveDirectoryFileServer,
- throwError)
-import Servant.API (NoContent (..), (:<|>) (..))
-import Servant.Server (Handler, hoistServer)
-import Servant.Swagger (toSwagger)
+import Database.Persist.Postgresql (SqlBackend,
+ migrateEnableExtension,
+ runMigration)
+import Fmt ((+|), (|+))
+import qualified Network.WebSockets as WS
+import Servant (Application,
+ ServerError (errBody),
+ err400, err401, err404,
+ serve,
+ serveDirectoryFileServer,
+ throwError)
+import Servant.API (NoContent (..),
+ (:<|>) (..))
+import Servant.Server (Handler, hoistServer)
+import Servant.Swagger (toSwagger)
import API
-import GTFS
+import qualified GTFS
import Persist
import Server.ControlRoom
-import Server.GTFS_RT (gtfsRealtimeServer)
-import Server.Util (Service, ServiceM, runService,
- sendErrorMsg)
-import Yesod (toWaiAppPlain)
+import Server.GTFS_RT (gtfsRealtimeServer)
+import Server.Util (Service, ServiceM,
+ runService, sendErrorMsg,
+ utcToSeconds)
+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 Conduit (ResourceT)
+import Config (LoggingConfig,
+ ServerConfig (..))
+import Control.Exception (throw)
+import Data.ByteString (ByteString)
+import Data.ByteString.Lazy (toStrict)
+import Data.Foldable (minimumBy)
+import Data.Function (on, (&))
+import Data.Maybe (fromMaybe)
+import qualified Data.Text as T
+import Data.Time.LocalTime.TimeZone.Olson (getTimeZoneSeriesFromOlsonFile)
+import Data.Time.LocalTime.TimeZone.Series (TimeZoneSeries)
+import Data.UUID (UUID)
+import qualified Data.UUID as UUID
+import Extrapolation (Extrapolator (..),
+ LinearExtrapolator (..),
+ euclid)
+import GTFS (Seconds (unSeconds),
+ seconds2Double)
import Prometheus
import Prometheus.Metric.GHC
+import System.FilePath ((</>))
+import System.IO.Unsafe
-application :: GTFS -> Pool SqlBackend -> ServerConfig -> IO Application
+application :: GTFS.GTFS -> Pool SqlBackend -> ServerConfig -> IO Application
application gtfs dbpool settings = do
doMigration dbpool
metrics <- Metrics
<$> register (gauge (Info "ws_connections" "Number of WS Connections"))
register ghcMetrics
+
+ -- TODO: maybe cache these in a TVar, we're not likely to ever need
+ -- more than one of these
+ let getTzseries tzname = getTimeZoneSeriesFromOlsonFile
+ (serverConfigZoneinfoPath settings </> T.unpack tzname)
+
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 getTzseries 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
-
-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
+doMigration pool = runSqlWithoutLog pool $ runMigration $ do
+ migrateEnableExtension "uuid-ossp"
+ migrateAll
+
+server :: GTFS.GTFS -> (Text -> IO TimeZoneSeries) -> Metrics -> TVar (M.Map UUID [TQueue (Maybe TrainPing)]) -> Pool SqlBackend -> ServerConfig -> Service CompleteAPI
+server gtfs getTzseries Metrics{..} subscribers dbpool settings = handleDebugAPI
+ :<|> (handleTrackerRegister :<|> handleTrainPing (throwError err401) :<|> handleWS
:<|> handleSubscribe :<|> handleDebugState :<|> handleDebugTrain
- :<|> handleDebugRegister :<|> pure gtfsFile :<|> gtfsRealtimeServer gtfs dbpool)
+ :<|> pure (GTFS.gtfsFile gtfs) :<|> gtfsRealtimeServer gtfs dbpool)
:<|> metrics
:<|> 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
+ where handleTrackerRegister 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
+ TrackerKey tracker <- insert (Tracker expires False registerAgent Nothing)
+ pure tracker
+ handleTrainPing onError ping@TrainPing{..} =
+ isTokenValid dbpool trainPingToken >>= \case
+ Nothing -> onError >> pure Nothing
+ Just tracker@Tracker{..} -> do
+
+ -- if the tracker is not associated with a ticket, it is probably
+ -- just starting out on a new trip, or has finished an old one.
+ maybeTicketId <- case trackerCurrentTicket of
+ Just ticketId -> pure (Just ticketId)
+ Nothing -> runSql dbpool $ do
+ now <- liftIO getCurrentTime
+ tickets <- selectList [ TicketDay ==. utctDay now, TicketCompleted ==. False ] []
+ ticketsWithFirstStation <- flip mapMaybeM tickets
+ (\ticket@(Entity ticketId _) -> do
+ selectFirst [StopTicket ==. ticketId] [Asc StopSequence] >>= \case
+ Nothing -> pure Nothing
+ Just (Entity _ stop) -> do
+ station <- getJust (stopStation stop)
+ tzseries <- liftIO $ getTzseries (GTFS.tzname (stopDeparture stop))
+ pure (Just (ticket, station, stop, tzseries)))
+
+ if null ticketsWithFirstStation then pure Nothing else do
+ let (closestTicket, _, _, _) = minimumBy
+ -- (compare `on` euclid trainPingGeopos . stationGeopos . snd)
+ (compare `on`
+ (\(Entity _ ticket, station, stop, tzseries) ->
+ let
+ runningDay = ticketDay ticket
+ spaceDistance = euclid trainPingGeopos (stationGeopos station)
+ timeDiff =
+ GTFS.toSeconds (stopDeparture stop) tzseries runningDay
+ - utcToSeconds now runningDay
+ in
+ euclid trainPingGeopos (stationGeopos station)
+ + abs (seconds2Double timeDiff / 3600)))
+ ticketsWithFirstStation
+ logInfoN
+ $ "Tracker "+|UUID.toString (coerce trainPingToken)|+
+ " is now handling ticket "+|UUID.toString (coerce (entityKey closestTicket))|+
+ " (trip "+|ticketTripName (entityVal closestTicket)|+")."
+
+ update (coerce trainPingToken)
+ [TrackerCurrentTicket =. Just (entityKey closestTicket)]
+
+ pure (Just (entityKey closestTicket))
+
+ ticketId <- case maybeTicketId of
+ Just ticketId -> pure ticketId
+ Nothing -> do
+ logWarnN $ "Tracker "+|UUID.toString (coerce trainPingToken)|+
+ " sent a ping, but no trips are running today."
+ throwError err400
+
runSql dbpool $ do
+ ticket@Ticket{..} <- getJust ticketId
+
+ stations <- selectList [ StopTicket ==. ticketId ] [Asc StopArrival]
+ >>= mapM (\stop -> do
+ station <- getJust (stopStation (entityVal stop))
+ tzseries <- liftIO $ getTzseries (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
+
insert ping
- last <- selectFirst
- [TrainAnchorTrip ==. runningTrip, TrainAnchorDay ==. runningDay]
- [Desc TrainAnchorWhen]
+
+ 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
- queues <- liftIO $ atomically $ do
- queues <- readTVar subscribers <&> M.lookup runningTrip
- whenJust queues $
- mapM_ (\q -> writeTQueue q (Just ping))
- pure queues
- pure (Just 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 (coerce trainPingToken)
+ [TrackerCurrentTicket =. Nothing]
+ update ticketId
+ [TicketCompleted =. True]
+ logInfoN $ "Tracker "+|UUID.toString (coerce trainPingToken)|+
+ " 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 ping))
+ pure queues
+ pure (Just anchor)
handleWS conn = do
liftIO $ WS.forkPingThread conn 30
incGauge metricsWSGauge
@@ -158,27 +232,27 @@ server gtfs@GTFS{..} Metrics{..} subscribers dbpool settings = handleDebugAPI
msg <- liftIO $ WS.receiveData conn
case A.eitherDecode msg of
Left err -> do
- logWarnN ("stray websocket message: "+|show msg|+" (could not decode: "+|err|+")")
+ 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 ->
+ 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.
- liftIO $ handleTrainPing (WS.sendClose conn ("" :: ByteString)) ping >>= \case
- Just anchor -> WS.sendTextData conn (A.encode anchor)
+ handleTrainPing (liftIO $ WS.sendClose conn ("" :: ByteString)) ping >>= \case
+ Just anchor -> liftIO $ WS.sendTextData conn (A.encode anchor)
Nothing -> pure ()
- handleSubscribe tripId day conn = liftIO $ WS.withPingThread conn 30 (pure ()) $ do
+ handleSubscribe (ticketId :: UUID) conn = liftIO $ WS.withPingThread conn 30 (pure ()) $ do
queue <- atomically $ do
queue <- newTQueue
qs <- readTVar subscribers
writeTVar subscribers
- $ M.insertWith (<>) tripId [queue] qs
+ $ M.insertWith (<>) ticketId [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] []
+ lastPing <- runSqlWithoutLog dbpool $ do
+ trackers <- getTicketTrackers ticketId
<&> fmap entityKey
- selectFirst [TrainPingToken <-. tokens] [Desc TrainPingTimestamp]
+ selectFirst [TrainPingToken <-. trackers] [Desc TrainPingTimestamp]
<&> fmap entityVal
whenJust lastPing $ \ping ->
WS.sendTextData conn (A.encode lastPing)
@@ -192,34 +266,39 @@ server gtfs@GTFS{..} Metrics{..} subscribers dbpool settings = handleDebugAPI
where removeSubscriber queue = atomically $ do
qs <- readTVar subscribers
writeTVar subscribers
- $ M.adjust (filter (/= queue)) tripId qs
+ $ M.adjust (filter (/= queue)) ticketId qs
handleDebugState = do
now <- liftIO getCurrentTime
runSql dbpool $ do
- running <- selectList [RunningBlocked ==. False, RunningExpires >=. now] []
- pairs <- forM running $ \(Entity token@(RunningKey uuid) _) -> 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)
- handleDebugTrain tripId day = do
- unless (runsOnDay gtfs tripId day)
- $ sendErrorMsg ("this trip does not run on "+|day|+".")
+ handleDebugTrain ticketId = do
runSql dbpool $ do
- tokens <- selectList [RunningTrip ==. tripId, RunningDay ==. day] []
- pings <- forM tokens $ \(Entity token _) -> do
+ trackers <- getTicketTrackers ticketId
+ pings <- forM trackers $ \(Entity token _) -> do
selectList [TrainPingToken ==. token] [] <&> fmap entityVal
pure (concat pings)
handleDebugAPI = pure $ toSwagger (Proxy @API)
metrics = exportMetricsAsText <&> (decodeUtf8 . toStrict)
+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)]) []
+
-- 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))
+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 trip))
+ (pure (Just tracker))
_ -> pure Nothing
hasExpired :: MonadIO m => UTCTime -> m Bool
@@ -229,3 +308,4 @@ hasExpired limit = do
validityPeriod :: NominalDiffTime
validityPeriod = nominalDay
+
diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs
index 402f0b8..5292620 100644
--- a/lib/Server/ControlRoom.hs
+++ b/lib/Server/ControlRoom.hs
@@ -1,33 +1,30 @@
-{-# 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 #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
module Server.ControlRoom (ControlRoom(..)) where
-import Control.Monad (forM_, join)
+import Config (ServerConfig (..), UffdConfig (..))
+import Control.Monad (forM, 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.Coerce (coerce)
+import Data.Function (on, (&))
import Data.Functor ((<&>))
-import Data.List (lookup)
+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.Pool (Pool)
import Data.Text (Text)
import qualified Data.Text as T
@@ -42,9 +39,14 @@ import Database.Persist (Entity (..), delete, entityVal, get,
insert, selectList, (==.))
import Database.Persist.Sql (PersistFieldSql, SqlBackend,
runSqlPool)
+import Extrapolation (Extrapolator (..),
+ LinearExtrapolator (..))
import Fmt ((+|), (|+))
import GHC.Float (int2Double)
import GHC.Generics (Generic)
+import qualified GTFS
+import Numeric (showFFloat)
+import Persist
import Server.Util (Service, secondsNow)
import Text.Blaze.Html (ToMarkup (..))
import Text.Blaze.Internal (MarkupM (Empty))
@@ -53,21 +55,14 @@ 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.Form
import Yesod.Orphans ()
data ControlRoom = ControlRoom
- { getGtfs :: GTFS
+ { getGtfs :: GTFS.GTFS
, getPool :: Pool SqlBackend
, getSettings :: ServerConfig
}
@@ -77,16 +72,22 @@ 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
+
+/tickets TicketsR GET
+/ticket/#UUID TicketViewR GET
+/ticket/map/#UUID TicketMapViewR GET
+/ticket/announce/#UUID AnnounceR POST
+/ticket/del-announce/#UUID DelAnnounceR GET
+
/token/block/#Token TokenBlock GET
-/trips TripsViewR GET
-/trip/#TripID TripViewR GET
+
+/gtfs/trips GtfsTripsViewR GET
+/gtfs/trip/#GTFS.TripId GtfsTripViewR GET
+/gtfs/import/#Day GtfsTicketImportR POST
+
/obu OnboardUnitMenuR GET
-/obu/#TripID/#Day OnboardUnitR GET
+/obu/#UUID OnboardUnitR GET
+/tracker OnboardTrackerR GET
|]
emptyMarkup :: MarkupM a -> Bool
@@ -96,10 +97,11 @@ emptyMarkup _ = False
instance Yesod ControlRoom where
authRoute _ = Just $ AuthR LoginR
isAuthorized OnboardUnitMenuR _ = pure Authorized
- isAuthorized (OnboardUnitR _ _) _ = pure Authorized
+ isAuthorized (OnboardUnitR _) _ = pure Authorized
+ isAuthorized OnboardTrackerR _ = pure Authorized
isAuthorized (AuthR _) _ = pure Authorized
isAuthorized _ _ = do
- UffdConfig{..} <- getYesod <&> getSettings <&> serverConfigLogin
+ UffdConfig{..} <- getYesod <&> serverConfigLogin . getSettings
if uffdConfigEnable then maybeAuthId >>= \case
Just _ -> pure Authorized
Nothing -> pure AuthenticationRequired
@@ -124,6 +126,7 @@ instance Yesod ControlRoom where
<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} -->
@@ -182,10 +185,10 @@ instance YesodAuth ControlRoom where
getRootR :: Handler Html
-getRootR = redirect TrainsR
+getRootR = redirect TicketsR
-getTrainsR :: Handler Html
-getTrainsR = do
+getTicketsR :: Handler Html
+getTicketsR = do
req <- getRequest
let maybeDay = lookup "day" (reqGetParams req) >>= (readMaybe . T.unpack)
mdisplayname <- maybeAuthId <&> fmap uffdDisplayName
@@ -198,52 +201,151 @@ getTrainsR = do
let prevday = (T.pack . iso8601Show . addDays (-1)) day
let nextday = (T.pack . iso8601Show . addDays 1) day
gtfs <- getYesod <&> getGtfs
- let trips = tripsOnDay gtfs day
+
+ -- 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
+
+ (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="@?{(TrainsR, [("day", prevday)])}">← #{prevday}
+ <a class="nav-left" href="@?{(TicketsR, [("day", prevday)])}">← #{prevday}
$if isToday
_{Msgtoday}
$else
- <a href="@{TrainsR}">_{Msgtoday}
- <a class="nav-right" href="@?{(TrainsR, [("day", nextday)])}">#{nextday} →
+ <a href="@{TicketsR}">_{Msgtoday}
+ <a class="nav-right" href="@?{(TicketsR, [("day", nextday)])}">#{nextday} →
<section>
+ <h2>_{MsgTickets}
<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))}
+ $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>
+<section>
+ <h2>_{MsgAccordingToGtfs}
+ <form method=post action="@{GtfsTicketImportR day}" enctype=#{enctype}>
+ ^{widget}
+ <button>_{MsgImportTrips}
$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>
+
+-- 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 [ TrainPingToken <-. fmap entityKey trackers ] [Desc TrainPingTimestamp]
+ anchors <- runDB $ selectList [ TrainAnchorTicket ==. ticketKey ] []
+ <&> nonEmpty . fmap entityVal
+
+ (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 trainPingLat trainPingLong trainPingTimestamp}
- (<a href="/api/debug/pings/#{trip}/#{day}">_{Msgraw}</a>)
+ _{MsgTrainPing (latitude trainPingGeopos) (longitude trainPingGeopos) trainPingTimestamp}
+ (<a href="/api/debug/pings/#{UUID.toString ticketId}/#{ticketDay}">_{Msgraw}</a>)
$nothing
<em>(_{MsgNoTrainPing})
<p><strong>_{MsgEstimatedDelay}</strong>:
@@ -252,12 +354,12 @@ getTrainViewR trip day = do
\ #{trainAnchorDelay} (_{MsgOnStationSequence (showFFloat (Just 3) trainAnchorSequence "")})
$nothing
<em> (_{MsgNone})
- <p><a href="@{TrainMapViewR tripTripID day}">_{MsgMap}</a>
+ <p><a href="@{TicketMapViewR ticketId}">_{MsgMap}</a>
<section>
<h2>_{MsgStops}
<ol>
- $forall Stop{..} <- tripStops
- <li value="#{stopSequence}"> #{stopArrival} #{stationName stopStation}
+ $forall (Stop{..}, Station{..}) <- stops
+ <li value="#{stopSequence}"> #{stopArrival} #{stationName}
$maybe history <- anchors
$maybe delay <- guessDelay history (int2Double stopSequence)
\ (#{delay})
@@ -269,21 +371,21 @@ getTrainViewR trip day = do
$if null anns
<li><em>(_{MsgNone})</em>
<h3>_{MsgNewAnnouncement}
- <form method=post action=@{AnnounceR trip day} enctype=#{enctype}>
+ <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 tokens
+ $if null trackers
<tr><td></td><td style="text-align:center"><em>(_{MsgNone})
- $forall Entity (RunningKey key) Running{..} <- tokens
- <tr :runningBlocked:.blocked>
- <td title="#{runningAgent}">#{runningAgent}
+ $forall Entity (TrackerKey key) Tracker{..} <- trackers
+ <tr :trackerBlocked:.blocked>
+ <td title="#{trackerAgent}">#{trackerAgent}
<td title="#{key}">#{key}
- <td title="#{runningExpires}">#{runningExpires}
- $if runningBlocked
+ <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>
@@ -292,14 +394,19 @@ getTrainViewR trip day = do
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>
+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=""/>
@@ -315,7 +422,7 @@ getTrainMapViewR tripId day = do
attribution: '&copy; <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}");
+ ws = new WebSocket((location.protocol == "http:" ? "ws" : "wss") + "://" + location.host + "/api/train/subscribe/#{UUID.toText ticketId}");
var marker = null;
@@ -334,37 +441,37 @@ getTrainMapViewR tripId day = do
-getTripsViewR :: Handler Html
-getTripsViewR = do
- GTFS{..} <- getYesod <&> getGtfs
+getGtfsTripsViewR :: Handler Html
+getGtfsTripsViewR = do
+ GTFS.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))}
+ $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))}
|]
-getTripViewR :: TripID -> Handler Html
-getTripViewR tripId = do
- GTFS{..} <- getYesod <&> getGtfs
+getGtfsTripViewR :: GTFS.TripId -> Handler Html
+getGtfsTripViewR tripId = do
+ GTFS.GTFS{..} <- getYesod <&> getGtfs
case M.lookup tripId trips of
Nothing -> notFound
- Just trip@Trip{..} -> defaultLayout [whamlet|
-<h1>_{MsgTrip} #{tripName trip}
+ Just trip@GTFS.Trip{..} -> defaultLayout [whamlet|
+<h1>_{MsgTrip} #{GTFS.tripName trip}
<section>
<h2>_{MsgInfo}
- <p><strong>_{MsgtripId}:</strong> #{tripTripID}
+ <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}
+ $forall GTFS.Stop{..} <- tripStops
+ <div>(#{stopSequence}) #{stopArrival} #{GTFS.stationName stopStation}
<section>
<h2>Dates
<ul>
@@ -372,17 +479,17 @@ getTripViewR tripId = do
|]
-postAnnounceR :: TripID -> Day -> Handler Html
-postAnnounceR trip day = do
- ((result, widget), enctype) <- runFormPost (announceForm day trip)
+postAnnounceR :: UUID -> Handler Html
+postAnnounceR ticketId = do
+ ((result, widget), enctype) <- runFormPost (announceForm ticketId)
case result of
FormSuccess ann -> do
runDB $ insert ann
- redirect (TrainViewR trip day)
+ redirect RootR -- (TicketViewR trip day)
_ -> defaultLayout
[whamlet|
<p>_{MsgInvalidInput}.
- <form method=post action=@{AnnounceR trip day} enctype=#{enctype}>
+ <form method=post action=@{AnnounceR ticketId} enctype=#{enctype}>
^{widget}
<button>_{MsgSubmit}
|]
@@ -396,51 +503,103 @@ getDelAnnounceR uuid = do
case ann of
Nothing -> notFound
Just Announcement{..} ->
- redirect (TrainViewR announcementTrip announcementDay)
+ 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 (RunningKey token) [ RunningBlocked =. blocked ]
- get (RunningKey token)
+ update (TrackerKey token) [ TrackerBlocked =. blocked ]
+ get (TrackerKey token)
case maybe of
- Just r@Running{..} -> do
+ Just r@Tracker{..} -> do
liftIO $ print r
- redirect (TrainViewR runningTrip runningDay)
+ redirect $ case trackerCurrentTicket of
+ Just ticket -> TicketViewR (coerce ticket)
+ Nothing -> RootR
Nothing -> notFound
getOnboardUnitMenuR :: Handler Html
getOnboardUnitMenuR = do
day <- liftIO getCurrentTime <&> utctDay
- gtfs <- getYesod <&> getGtfs
- let trips = tripsOnDay gtfs day
+
+ tickets <-
+ runDB $ selectList [ TicketCompleted ==. False, TicketDay ==. day ] [] >>= mapM (\ticket -> do
+ firstStop <- selectFirst [StopTicket ==. entityKey ticket] [ Asc StopDeparture ]
+ pure (ticket, entityVal $ fromJust firstStop))
+
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 =
+ <h1>_{MsgOBU}
+ <section>
+ _{MsgChooseTrain}
+ $forall (Entity (TicketKey ticketId) Ticket{..}, firstStop) <- tickets
+ <hr>
+ <a href="@{OnboardUnitR ticketId}">
+ #{ticketTripName}: #{ticketHeadsign} #{stopDeparture firstStop}
+ <section>
+ <a href="@{OnboardTrackerR}">_{MsgStartTracking}
+ |]
+
+getOnboardUnitR :: UUID -> Handler Html
+getOnboardUnitR ticketId = do
+ Ticket{..} <- runDB $ get (TicketKey ticketId) >>= \case
+ Nothing -> notFound
+ Just ticket -> pure ticket
defaultLayout $(whamletFile "site/obu.hamlet")
-announceForm :: Day -> TripID -> Html -> MForm Handler (FormResult Announcement, Widget)
-announceForm day tripId = renderDivs $ Announcement
- <$> pure tripId
+getOnboardTrackerR :: Handler Html
+getOnboardTrackerR = do
+ defaultLayout
+ $( whamletFile "site/tracker.hamlet")
+
+
+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
- <*> pure day
<*> aopt urlField (fieldSettingsLabel MsgMaybeWeblink) Nothing
<*> lift (liftIO getCurrentTime <&> Just)
+
+
+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)
+
+
mightbe :: Maybe Text -> Text
mightbe (Just a) = a
mightbe Nothing = ""
+
+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))
diff --git a/lib/Server/GTFS_RT.hs b/lib/Server/GTFS_RT.hs
index cfb02ce..d2e53a1 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,6 +12,7 @@ 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
@@ -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
@@ -91,72 +98,85 @@ gtfsRealtimeServer gtfs@GTFS{..} dbpool =
handleTripUpdates = runSql dbpool $ do
today <- liftIO $ getCurrentTime <&> utctDay
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] [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
+ 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)
+ let 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
+
+ pure $ 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 +201,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/Util.hs b/lib/Server/Util.hs
index 41d26f7..0106428 100644
--- a/lib/Server/Util.hs
+++ b/lib/Server/Util.hs
@@ -1,32 +1,67 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeSynonymInstances #-}
-
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE RecordWildCards #-}
-- | mostly the monad the service runs in
-module Server.Util (Service, ServiceM, runService, sendErrorMsg, secondsNow, utcToSeconds) where
+module Server.Util (Service, ServiceM, runService, sendErrorMsg, secondsNow, utcToSeconds, runLogging) where
+import Config (LoggingConfig (..))
+import Control.Exception (handle, try)
+import Control.Monad.Extra (void, whenJust)
import Control.Monad.IO.Class (MonadIO (liftIO))
-import Control.Monad.Logger (LoggingT, runStderrLoggingT)
+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 Fmt ((+|), (|+))
+import GHC.IO.Exception (IOException (IOError))
import GTFS (Seconds (..))
import Prometheus (MonadMonitor (doIO))
import Servant (Handler, ServerError, ServerT, err404,
errBody, errHeaders, throwError)
+import System.IO (stderr)
+import System.Process.Extra (callProcess)
-type ServiceM = LoggingT Handler
+type ServiceM = LoggingT (ReaderT LoggingConfig Handler)
type Service api = ServerT api ServiceM
-runService :: ServiceM a -> Handler a
-runService = runStderrLoggingT
+runService :: LoggingConfig -> ServiceM a -> Handler a
+runService conf m = runReaderT (runLogging conf m) conf
instance MonadMonitor ServiceM where
doIO = liftIO
+runLogging :: MonadIO m => LoggingConfig -> LoggingT m a -> m a
+runLogging LoggingConfig{..} logging = runLoggingT logging printLogMsg
+ where printLogMsg loc source level msg = do
+ -- this is what runStderrLoggingT does
+ defaultOutput stderr loc source level msg
+
+ whenJust loggingConfigNtfyToken \token -> handle ntfyFailed do
+ callProcess "ntfy"
+ [ "send"
+ , "--token=" <> T.unpack token
+ , "--title="+|loggingConfigHostname|+"/"+|"tracktrain"
+ , "--priority="+|show (ntfyPriority level)|+""
+ , T.unpack loggingConfigNtfyTopic
+ , T.unpack (decodeUtf8Lenient (fromLogStr msg)) ]
+
+ ntfyFailed (e :: IOError) =
+ putStrLn ("calling ntfy failed:"+|show e|+".")
+ ntfyPriority level = case level of
+ LevelDebug -> 2
+ LevelInfo -> 3
+ LevelWarn -> 4
+ LevelError -> 5
+ LevelOther _ -> 0
+
sendErrorMsg :: Text -> ServiceM a
sendErrorMsg msg = throwError err404
diff --git a/messages/de.msg b/messages/de.msg
index 016ebbb..53e5ede 100644
--- a/messages/de.msg
+++ b/messages/de.msg
@@ -36,7 +36,10 @@ OnStationSequence idx: an Stationsindex #{idx}
Map: Karte
InvalidInput: Ungültige Eingabe, bitte noch einmal
Submit: Ok
+ImportTrips: Fahrten importieren
+Tickets: Tickets
delete: löschen
+AccordingToGtfs: Weitere Fahrten im GTFS
OBU: Onboard-Unit
ChooseTrain: Fahrt auswählen
diff --git a/messages/en.msg b/messages/en.msg
index ecaad0a..a2ef189 100644
--- a/messages/en.msg
+++ b/messages/en.msg
@@ -36,7 +36,11 @@ OnStationSequence idx@String: on station index #{idx}
Map: Map
InvalidInput: Invalid input, let's try again
Submit: Submit
+Tickets: Tickets
+ImportTrips: import selected trips
delete: delete
+AccordingToGtfs: Additional Trips contained in the Gtfs
+StartTracking: Start Tracking
OBU: Onboard-Unit
ChooseTrain: Choose a Train
diff --git a/shell.nix b/shell.nix
new file mode 100644
index 0000000..8c58e9d
--- /dev/null
+++ b/shell.nix
@@ -0,0 +1,5 @@
+with import <nixpkgs> {};
+
+mkShell {
+ buildInputs = [ pkg-config openssl zlib postgresql ];
+}
diff --git a/site/obu.hamlet b/site/obu.hamlet
index 7068014..ed8017a 100644
--- a/site/obu.hamlet
+++ b/site/obu.hamlet
@@ -1,7 +1,7 @@
<h1>_{MsgOBU}
<section>
- <h2>#{tripId} _{Msgon} #{day}
+ <h2>#{ticketTripName} _{Msgon} #{ticketDay}
<strong>Token:</strong> <span id="token">
<section>
@@ -107,10 +107,10 @@
async function main() {
- let trip = await (await fetch("/api/trip/#{tripId}")).json();
+ let trip = await (await fetch("/api/trip/#{ticketTripName}")).json();
console.log("got trip info");
- token = await (await fetch("/api/train/register/#{tripId}", {
+ token = await (await fetch("/api/train/register/#{UUID.toText ticketId}", {
method: "POST",
body: JSON.stringify({agent: "onboard-unit"}),
headers: {"Content-Type": "application/json"}
diff --git a/site/tracker.hamlet b/site/tracker.hamlet
new file mode 100644
index 0000000..5877c5d
--- /dev/null
+++ b/site/tracker.hamlet
@@ -0,0 +1,137 @@
+<h1>_{MsgOBU}
+
+<section>
+ <h2>Blub
+ <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();
+
+ 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");
+
+ document.getElementById("token").innerText = token;
+
+ openWebsocket();
+ }
+ }
+
+ main()
diff --git a/todo.org b/todo.org
index 7c5d891..b621e53 100644
--- a/todo.org
+++ b/todo.org
@@ -1,5 +1,6 @@
#+TITLE: Traintrack Todos
+* TODO be consistent & use lat/lon everywhere (not lat/long!)
* DONE Handle service announcements
(per trip & day, nothing else needs to be supported)
diff --git a/tools/obu-guess-trip b/tools/obu-guess-trip
index b9264f6..32aa6d4 100755
--- a/tools/obu-guess-trip
+++ b/tools/obu-guess-trip
@@ -44,8 +44,9 @@ Arguments:
(define pos
(with-input-from-process `(obu-ping -s ,statefile -n 1 -d) read))
(define guessed
- (closest-stop-to stops pos))
+ (closest-stop-to stops pos))
(define trip (assoc-ref guessed 'trip))
+ (display stops)
(do-process `(obu-config -s ,statefile sequencelength ,(assoc-ref guessed 'sequencelength)))
(display trip))
@@ -68,7 +69,7 @@ Arguments:
(define day (date->string (current-date) "~1"))
(define tls
(equal? (uri-ref url 'scheme) "https"))
- (parameterize
+ (define thing (parameterize
; replace all json keys with symbols; everything else is confusing
([json-object-handler
(cut map (lambda p `(,(string->symbol (car (car p))) . ,(cdr (car p)))) <>)])
@@ -76,3 +77,5 @@ Arguments:
(values-ref (http-get (uri-ref url 'host+port)
(format "/api/timetable/stops/~a" day)
:secure tls) 2))))
+ (display thing)
+ thing)
diff --git a/tools/obu-state.edn b/tools/obu-state.edn
index db989c8..b0c4b0e 100644
--- a/tools/obu-state.edn
+++ b/tools/obu-state.edn
@@ -1 +1 @@
-{token "5ab95c26-367e-40fc-8d3e-2956af6f61e4"} \ No newline at end of file
+{sequencelength "#f"} \ No newline at end of file
diff --git a/tracktrain.cabal b/tracktrain.cabal
index e763f6d..a8e42a4 100644
--- a/tracktrain.cabal
+++ b/tracktrain.cabal
@@ -1,24 +1,15 @@
cabal-version: 2.4
name: tracktrain
version: 0.1.0.0
-
--- A short (one-line) description of the package.
-synopsis: tracktrain tracks trains on their traintracks
-
--- A longer description of the package.
--- description:
-
--- A URL where users can report bugs.
--- bug-reports:
-
--- The license under which the package is released.
--- license:
+synopsis: tracktrain tracks trains on their traintracks
+description: A passenger information system backend for the Ilztalbahn
+license: EUPL-1.2
author: stuebinm
maintainer: stuebinm@disroot.org
-- A copyright notice.
-- copyright:
--- category:
+
extra-source-files: CHANGELOG.md
executable tracktrain
@@ -43,7 +34,7 @@ executable tracktrain
, extra
, proto-lens
hs-source-dirs: app
- default-language: Haskell2010
+ default-language: GHC2021
default-extensions: OverloadedStrings
, ScopedTypeVariables
@@ -105,6 +96,8 @@ library
, exceptions
, proto-lens
, http-media
+ , filepath
+ , monad-control
hs-source-dirs: lib
exposed-modules: GTFS
, Server
@@ -118,14 +111,15 @@ library
other-modules: Server.Util
, Yesod.Auth.Uffd
, Yesod.Orphans
- default-language: Haskell2010
+ , MultiLangText
+ default-language: GHC2021
default-extensions: OverloadedStrings
, ScopedTypeVariables
, ViewPatterns
library gtfs-realtime
build-depends: base ^>=4.17
- , proto-lens-runtime
+ , proto-lens-runtime
default-language: Haskell2010
hs-source-dirs: gtfs-realtime
exposed-modules: Proto.GtfsRealtime
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-01 19:08:25 +0000