aboutsummaryrefslogtreecommitdiff
path: root/lib/Server
diff options
context:
space:
mode:
authorstuebinm2022-09-02 00:18:18 +0200
committerstuebinm2022-09-02 00:18:18 +0200
commit8fcabd505e39b718336e57d104a84407bf6bf274 (patch)
tree78ad2baa11e51aad3fd804b6ac0544cb4ad35217 /lib/Server
parentbaa7430e3bb19d25f2264571c990f850e67bd969 (diff)
reasonable delay forecasts
Diffstat (limited to 'lib/Server')
-rw-r--r--lib/Server/ControlRoom.hs30
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