diff options
Diffstat (limited to 'lib/Server.hs')
| -rw-r--r-- | lib/Server.hs | 22 |
1 files changed, 17 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 |