this does way too much tbh (also functioning delays)

most of it deals with timezones, and all the weird implications that has

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}