diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/Server.hs | 22 | ||||
| -rw-r--r-- | lib/Server/ControlRoom.hs | 2 |
2 files changed, 19 insertions, 5 deletions
diff --git a/lib/Server.hs b/lib/Server.hs index 75617bd..055925f 100644 --- a/lib/Server.hs +++ b/lib/Server.hs @@ -51,6 +51,8 @@ import Server.Util (Service, ServiceM, runService, sendErrorMsg) import Yesod (toWaiAppPlain) +import Extrapolation (Extrapolator (guessAnchor), + LinearExtrapolator) import System.IO.Unsafe application :: GTFS -> Pool SqlBackend -> IO Application @@ -68,7 +70,7 @@ doMigration pool = runSql pool $ server :: GTFS -> Pool SqlBackend -> Service CompleteAPI server gtfs@GTFS{..} dbpool = handleDebugAPI :<|> (handleStations :<|> handleTimetable :<|> handleTrip - :<|> handleRegister :<|> handleTripPing :<|> handleWS + :<|> handleRegister :<|> handleTrainPing :<|> handleWS :<|> handleDebugState :<|> handleDebugTrain :<|> handleDebugRegister :<|> gtfsRealtimeServer gtfs dbpool) :<|> pure (unsafePerformIO (toWaiAppPlain (ControlRoom gtfs dbpool))) @@ -94,10 +96,19 @@ server gtfs@GTFS{..} dbpool = handleDebugAPI expires <- liftIO $ getCurrentTime <&> addUTCTime validityPeriod RunningKey token <- runSql dbpool $ insert (Running expires False tripID day Nothing "debug key") pure token - handleTripPing ping = do - lift $ checkTokenValid dbpool (coerce $ trainPingToken ping) + handleTrainPing ping = do + running@Running{..} <- lift $ checkTokenValid dbpool (coerce $ trainPingToken ping) + let anchor = guessAnchor @LinearExtrapolator gtfs running ping -- TODO: are these always inserted in order? - runSql dbpool $ insert ping + runSql dbpool $ do + insert ping + last <- selectFirst + [TrainAnchorTrip ==. runningTrip, TrainAnchorDay ==. runningDay] + [Desc TrainAnchorWhen] + -- only insert new estimates if they've actually changed anything + when (fmap (trainAnchorDelay . entityVal) last /= Just (trainAnchorDelay anchor)) + $ void $ insert anchor + pure NoContent handleWS conn = do -- TODO test this!! @@ -131,13 +142,14 @@ server gtfs@GTFS{..} dbpool = handleDebugAPI -- TODO: proper debug logging for expired tokens -checkTokenValid :: Pool SqlBackend -> Token -> Handler () +checkTokenValid :: Pool SqlBackend -> Token -> Handler Running checkTokenValid dbpool token = do trip <- try $ runSql dbpool $ get (coerce token) when (runningBlocked trip) $ throwError err401 whenM (hasExpired (runningExpires trip)) $ throwError err401 + pure trip where try m = m >>= \case Just a -> pure a Nothing -> throwError err404 diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs index 4ef3784..3c928f1 100644 --- a/lib/Server/ControlRoom.hs +++ b/lib/Server/ControlRoom.hs @@ -203,6 +203,8 @@ getTrainViewR trip day = do <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 + <tr><td></td><td style="text-align:center"><em>(_{MsgNone}) $forall Entity (RunningKey key) Running{..} <- tokens <tr :runningBlocked:.blocked> <td title="#{runningAgent}">#{runningAgent} |