aboutsummaryrefslogtreecommitdiff
path: root/lib/Server
diff options
context:
space:
mode:
authorstuebinm2022-08-28 17:40:41 +0200
committerstuebinm2022-08-28 17:40:41 +0200
commit1b2e30c134c996e82c282b21099f21501dd966ac (patch)
tree42b9b1d56ed2a75af18689b29c2db5cc06ab0680 /lib/Server
parentce20814be8276501d7faa0ef19a8ceebb68283b2 (diff)
this does way too much tbh (also functioning delays)
most of it deals with timezones, and all the weird implications that has
Diffstat (limited to '')
-rw-r--r--lib/Server.hs22
-rw-r--r--lib/Server/ControlRoom.hs2
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}