diff options
Diffstat (limited to 'lib/Server/ControlRoom.hs')
| -rw-r--r-- | lib/Server/ControlRoom.hs | 16 |
1 files changed, 15 insertions, 1 deletions
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) |