diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/Server.hs | 4 | ||||
| -rw-r--r-- | lib/Server/ControlRoom.hs | 16 |
2 files changed, 17 insertions, 3 deletions
diff --git a/lib/Server.hs b/lib/Server.hs index 1139ff8..759080c 100644 --- a/lib/Server.hs +++ b/lib/Server.hs @@ -52,7 +52,7 @@ import Server.Util (Service, ServiceM, runService, import Yesod (toWaiAppPlain) import Conferer (fetch, mkConfig) -import Extrapolation (Extrapolator (guessAnchor), +import Extrapolation (Extrapolator (..), LinearExtrapolator) import System.IO.Unsafe @@ -101,7 +101,7 @@ server gtfs@GTFS{..} dbpool = handleDebugAPI pure token handleTrainPing ping = do running@Running{..} <- lift $ checkTokenValid dbpool (coerce $ trainPingToken ping) - let anchor = guessAnchor @LinearExtrapolator gtfs running ping + let anchor = extrapolateAnchorFromPing @LinearExtrapolator gtfs running ping -- TODO: are these always inserted in order? runSql dbpool $ do insert ping diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs index 164d8ff..721d7df 100644 --- a/lib/Server/ControlRoom.hs +++ b/lib/Server/ControlRoom.hs @@ -28,7 +28,7 @@ import qualified Data.Map as M import Data.Pool (Pool) import Data.Text (Text) import qualified Data.Text as T -import Data.Time (UTCTime, getCurrentTime, utctDay) +import Data.Time (UTCTime(..), getCurrentTime, utctDay) import Data.Time.Calendar (Day) import Data.Time.Format.ISO8601 (iso8601Show) import Data.UUID (UUID) @@ -48,9 +48,12 @@ import Text.Read (readMaybe) import Text.Shakespeare.Text import Yesod import Yesod.Form +import Data.List.NonEmpty (nonEmpty) import GTFS import Persist +import Extrapolation (Extrapolator(..), LinearExtrapolator) +import Control.Monad (join) data ControlRoom = ControlRoom @@ -169,6 +172,8 @@ getTrainViewR trip day = do anns <- runDB $ selectList [ AnnouncementTrip ==. trip, AnnouncementDay ==. day ] [] tokens <- runDB $ selectList [ RunningTrip ==. trip, RunningDay ==. day ] [] lastPing <- runDB $ selectFirst [ TrainPingToken <-. fmap entityKey tokens ] [Desc TrainPingTimestamp] + anchors <- runDB $ selectList [ TrainAnchorTrip ==. trip, TrainAnchorDay ==. day ] [] + <&> nonEmpty . (fmap entityVal) defaultLayout $ do mr <- getMessageRender setTitle (toHtml (""+|mr MsgTrip|+" "+|tripTripID|+" "+|mr Msgon|+" "+|day|+"" :: Text)) @@ -188,6 +193,9 @@ getTrainViewR trip day = do <ol> $forall Stop{..} <- tripStops <li> #{stopArrival} #{stationName stopStation} + $maybe history <- anchors + $maybe delay <- guessDelay history (toSeconds stopArrival tzseries day) + \ (#{delay}) <section> <h2>_{MsgAnnouncements} <ul> @@ -215,6 +223,7 @@ getTrainViewR trip day = do $else <td title="_{MsgBlockToken}"><a href="@{TokenBlock key}">_{MsgBlockToken}</a> |] + where guessDelay history = join . fmap trainAnchorDelay . extrapolateAtSeconds @LinearExtrapolator history getTripsViewR :: Handler Html @@ -323,3 +332,8 @@ instance ToMarkup Token where instance ToMessage Double where toMessage = T.pack . show + +instance ToMarkup Seconds where + toMarkup (Seconds s) = + if s > 0 then toMarkup ("+"+|s `div` 60|+"" :: Text) + else toMarkup (s `div` 60) |