diff options
Diffstat (limited to 'lib/Server/ControlRoom.hs')
| -rw-r--r-- | lib/Server/ControlRoom.hs | 30 |
1 files changed, 20 insertions, 10 deletions
diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs index 721d7df..9b61828 100644 --- a/lib/Server/ControlRoom.hs +++ b/lib/Server/ControlRoom.hs @@ -17,18 +17,20 @@ module Server.ControlRoom (ControlRoom(..)) where -import Control.Monad (forM_) +import Control.Monad (forM_, join) import Control.Monad.Extra (maybeM) import Control.Monad.IO.Class (MonadIO (liftIO)) import qualified Data.ByteString.Char8 as C8 import Data.Functor ((<&>)) import Data.List (lookup) +import Data.List.NonEmpty (nonEmpty) import Data.Map (Map) import qualified Data.Map as M import Data.Pool (Pool) import Data.Text (Text) import qualified Data.Text as T -import Data.Time (UTCTime(..), getCurrentTime, utctDay) +import Data.Time (UTCTime (..), getCurrentTime, + utctDay) import Data.Time.Calendar (Day) import Data.Time.Format.ISO8601 (iso8601Show) import Data.UUID (UUID) @@ -39,6 +41,7 @@ import Database.Persist (Entity (..), delete, entityVal, get, import Database.Persist.Sql (PersistFieldSql, SqlBackend, runSqlPool) import Fmt ((+|), (|+)) +import GHC.Float (int2Double) import GHC.Generics (Generic) import Server.Util (Service) import Text.Blaze.Html (ToMarkup (..)) @@ -48,12 +51,12 @@ import Text.Read (readMaybe) import Text.Shakespeare.Text import Yesod import Yesod.Form -import Data.List.NonEmpty (nonEmpty) +import Extrapolation (Extrapolator (..), + LinearExtrapolator, secondsNow) import GTFS +import Numeric (showFFloat) import Persist -import Extrapolation (Extrapolator(..), LinearExtrapolator) -import Control.Monad (join) data ControlRoom = ControlRoom @@ -170,10 +173,11 @@ getTrainViewR trip day = do Nothing -> notFound Just res@Trip{..} -> do anns <- runDB $ selectList [ AnnouncementTrip ==. trip, AnnouncementDay ==. day ] [] - tokens <- runDB $ selectList [ RunningTrip ==. trip, RunningDay ==. 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)) @@ -187,14 +191,19 @@ getTrainViewR trip day = do (<a href="/api/debug/pings/#{trip}/#{day}">_{Msgraw}</a>) $nothing <em>(_{MsgNoTrainPing}) - <p><strong>Estimated Delay</strong>: Todo! + <p><strong>_{MsgEstimatedDelay}</strong>: + $maybe history <- anchors + $maybe TrainAnchor{..} <- guessAtSeconds history nowSeconds + \ #{trainAnchorDelay} (_{MsgOnStationSequence (showFFloat (Just 3) trainAnchorSequence "")}) + $nothing + <em> (_{MsgNone}) <section> <h2>_{MsgStops} <ol> $forall Stop{..} <- tripStops - <li> #{stopArrival} #{stationName stopStation} + <li value="#{stopSequence}"> #{stopArrival} #{stationName stopStation} $maybe history <- anchors - $maybe delay <- guessDelay history (toSeconds stopArrival tzseries day) + $maybe delay <- guessDelay history (int2Double stopSequence) \ (#{delay}) <section> <h2>_{MsgAnnouncements} @@ -223,7 +232,8 @@ getTrainViewR trip day = do $else <td title="_{MsgBlockToken}"><a href="@{TokenBlock key}">_{MsgBlockToken}</a> |] - where guessDelay history = join . fmap trainAnchorDelay . extrapolateAtSeconds @LinearExtrapolator history + where guessDelay history = fmap trainAnchorDelay . extrapolateAtPosition @LinearExtrapolator history + guessAtSeconds = extrapolateAtSeconds @LinearExtrapolator getTripsViewR :: Handler Html |