From dbb5c4b6b882cd99981eb854386586854a23fdec Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Wed, 13 May 2026 00:05:37 +0200
Subject: Server.Frontend.Tracker: dedicated configuration menu

There is no back-channel with which we could retrieve the config that is
currently on an owntracks client. However, we can send out each config
with its own slightly tweaked host url, so that we can detect its
provisioning on the incoming requests anyways.

Credits for the idea go to Emily.
---
 lib/Server/Ingest.hs | 16 ++++++++++++++--
 1 file changed, 14 insertions(+), 2 deletions(-)

(limited to 'lib/Server/Ingest.hs')

diff --git a/lib/Server/Ingest.hs b/lib/Server/Ingest.hs
index c598ac2..ec99e60 100644
--- a/lib/Server/Ingest.hs
+++ b/lib/Server/Ingest.hs
@@ -75,7 +75,7 @@ handleTrackerRegister dbpool RegisterJson{..} = do
   today <- liftIO getCurrentTime <&> utctDay
   expires <- liftIO $ getCurrentTime <&> addUTCTime validityPeriod
   runSql dbpool $ do
-    TrackerKey tracker <- insert (Tracker "dummy" {-expires-} False registerAgent Nothing)
+    TrackerKey tracker <- insert (Tracker "dummy" {-expires-} False registerAgent Nothing Nothing)
     pure (coerce tracker)
   where
     validityPeriod :: NominalDiffTime
@@ -126,9 +126,10 @@ handleOwntracksMessage
   -> ServerConfig
   -> Maybe Text
   -> Maybe Text
+  -> Maybe Int
   -> Message
   -> LoggingT (ReaderT LoggingConfig Handler) [Command]
-handleOwntracksMessage dbpool subscribers cfg maybeUser device msg = do
+handleOwntracksMessage dbpool subscribers cfg maybeUser device maybeVersion msg = do
   user <- case maybeUser of
     Just user -> pure user
     Nothing   -> throwError err401
@@ -145,6 +146,17 @@ handleOwntracksMessage dbpool subscribers cfg maybeUser device msg = do
       Just tracker -> pure tracker
       Nothing -> throw err401
 
+  whenJust maybeVersion \version -> do
+    whenJust trackerConfigVersion \tversion -> do
+      when (tversion > version) $ logWarnN $ "Tracker "+|trackerName|+" sent message tagged with older config "+|version|+" after we've seen it using config "+|tversion|+"."
+      runSql dbpool $ do
+        when (tversion < version) $ E.update \t -> do
+            set t [TrackerConfigVersion E.=. val (Just version)]
+            where_ (t ^. TrackerId E.==. val trackerId)
+        E.update \c -> do
+          set c [TrackerConfigSeen E.=. val True]
+          where_ (c ^. TrackerConfigTracker E.==. val trackerId)
+
   case msg of
     MsgStatus status -> do
       now <- liftIO getCurrentTime
-- 
cgit v1.2.3