Server.Frontend.Tracker: dedicated configuration menuHEADmain

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.

7 files changed, 112 insertions, 11 deletions

diff --git a/lib/API.hs b/lib/API.hs
index e3e7107..b890ab7 100644
--- a/lib/API.hs
+++ b/lib/API.hs
@@ -83,7 +83,7 @@ type GtfsRealtimeAPI = "servicealerts" :> QueryFlag "force" :> Get '[Proto] Feed
   :<|> "vehiclepositions" :> QueryFlag "force" :> Get '[Proto] FeedMessage
 
 type OwnTracksAPI =
-      "pub" :> QueryParam "u" Text :> QueryParam "d" Text :> ReqBody '[JSON] OT.Message :> Post '[JSON] [OT.Command]
+      "pub" :> QueryParam "u" Text :> QueryParam "d" Text :> QueryParam "version" Int :> ReqBody '[JSON] OT.Message :> Post '[JSON] [OT.Command]
 
 
 type CompleteAPI =
diff --git a/lib/OwnTracks/Configuration.hs b/lib/OwnTracks/Configuration.hs
index 0cb361d..a10a46e 100644
--- a/lib/OwnTracks/Configuration.hs
+++ b/lib/OwnTracks/Configuration.hs
@@ -91,6 +91,7 @@ data Configuration = Configuration
   -- ^ Add extended data attributes to location messages (iOS,Android/boolean)
   , configHost                                :: Maybe Text
   -- ^ MQTT endpoint host (iOS,Android/string)
+  -- FIXME: structured type here?
   , configHttpHeaders                         :: Maybe Text
   -- ^ extra HTTP headers:field names and field content are separated by a colon (:), multiple fields by a backslash-n (\n) \<field-name>:\<field-content>\n\<field-name>:\<field-content>... (iOS only/string)
   , configIgnoreInaccurateLocations           :: Maybe Int
diff --git a/lib/Persist.hs b/lib/Persist.hs
index dbab9bd..6f459fc 100644
--- a/lib/Persist.hs
+++ b/lib/Persist.hs
@@ -94,6 +94,7 @@ derivePersistFieldJSON "Value"
 -- We derive these here so that OwnTracks.* can become its own package eventually
 derivePersistFieldJSON "OwnTracks.Status"
 derivePersistFieldJSON "OwnTracks.Command"
+derivePersistFieldJSON "OwnTracks.Configuration"
 
 
 data CommandStatus = Queued | Sent
@@ -144,6 +145,7 @@ Tracker sql=tt_tracker
   blocked Bool
   agent Text
   currentTicket TicketId Maybe
+  configVersion Int Maybe
   deriving Eq Show Generic
 
 TrackerStatus sql=tt_tracker_status
@@ -164,6 +166,13 @@ TrackerCommand sql=tt_tracker_command
   command OwnTracks.Command
   deriving Show Eq
 
+TrackerConfig sql=tt_tracker_config
+  tracker TrackerId
+  timestamp UTCTime
+  seen Bool
+  configuration OwnTracks.Configuration
+  deriving Show Eq
+
 -- raw frames as received from OBUs
 Ping json sql=tt_trip_ping
   ticket TicketId Maybe OnDeleteCascade OnUpdateCascade
diff --git a/lib/Server/Frontend/Routes.hs b/lib/Server/Frontend/Routes.hs
index d6b82e2..684d69d 100644
--- a/lib/Server/Frontend/Routes.hs
+++ b/lib/Server/Frontend/Routes.hs
@@ -49,6 +49,7 @@ mkYesodData "Frontend" [parseRoutes|
 /tracker/#Text TrackerViewR GET
 /tracker/#Text/delete TrackerDeleteR POST
 /tracker/#Text/command TrackerCommandR POST
+/tracker/#Text/config TrackerConfigR POST
 
 /ticker/announce TickerAnnounceR POST
 /ticker/delete TickerDeleteR POST
diff --git a/lib/Server/Frontend/Tracker.hs b/lib/Server/Frontend/Tracker.hs
index ddbf5e9..e78e567 100644
--- a/lib/Server/Frontend/Tracker.hs
+++ b/lib/Server/Frontend/Tracker.hs
@@ -1,20 +1,21 @@
-{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE QuasiQuotes    #-}
+{-# LANGUAGE BlockArguments  #-}
+{-# LANGUAGE QuasiQuotes     #-}
+{-# LANGUAGE RecordWildCards #-}
 
 module Server.Frontend.Tracker
   (getTrackerViewR, getTrackersR, postTrackersR, postTrackerDeleteR,
-  postTrackerCommandR)
+  postTrackerCommandR, postTrackerConfigR)
 where
 
-import           Data.Aeson                      (decode, Value)
-import           Data.ByteString                 (fromStrict)
+import           Data.Aeson                      (Value, decode, encode)
+import           Data.ByteString                 (fromStrict, toStrict)
 import           Data.Coerce                     (coerce)
 import           Data.Function                   ((&))
 import           Data.Functor                    ((<&>))
 import qualified Data.Map                        as M
 import           Data.Text                       (Text)
 import qualified Data.Text                       as T
-import           Data.Text.Encoding              (encodeUtf8)
+import           Data.Text.Encoding              (decodeUtf8, encodeUtf8)
 import           Data.Time                       (getCurrentTime)
 import qualified Data.UUID                       as UUID
 import           Database.Esqueleto.Experimental hiding ((<&>))
@@ -24,7 +25,10 @@ import           Server.Frontend.Routes          (FrontendMessage (..), Handler,
 import           Yesod                           hiding (delete, update, (=.),
                                                   (==.))
 
+import           Fmt
+import qualified OwnTracks
 import           OwnTracks.Command
+import           OwnTracks.Configuration         (configHost)
 import           OwnTracks.Status
 
 
@@ -57,6 +61,7 @@ trackerCreateForm = renderDivs $ Tracker
   <*> pure False
   <*> areq textField (fieldSettingsLabel MsgTrackerAgent) Nothing
   <*> pure Nothing
+  <*> pure Nothing
 
 trackerCreateWidget :: Handler Html
 trackerCreateWidget = do
@@ -130,6 +135,70 @@ postTrackerCommandR name = do
                 <button>_{MsgSubmit}
         |]
 
+trackerConfigForm
+  :: Maybe OwnTracks.Configuration
+  -> Html
+  -> MForm Handler (FormResult OwnTracks.Configuration, Widget)
+trackerConfigForm maybeLastConfig = renderDivs do
+  -- TODO: default text should be last config, if known?
+  text <- areq textField
+    (fieldSettingsLabel MsgSendCommand)
+    (fmap (decodeUtf8 . toStrict . encode) maybeLastConfig)
+  let Just c = (decode (fromStrict (encodeUtf8 text)))
+  pure c
+
+trackerConfigWidget :: Maybe OwnTracks.Configuration -> Text -> Handler Html
+trackerConfigWidget maybeLastConfig name = do
+  (widget, enctype) <- generateFormPost (trackerConfigForm maybeLastConfig)
+  -- TODO: show which config version we're writing here, and which one was last?
+  defaultLayout [whamlet|
+  <h2> _{MsgSendCommand}
+  <form method=post action="@{TrackerConfigR name}" enctype=#{enctype}>
+    ^{widget}
+    <button>_{MsgSubmit}
+  |]
+
+postTrackerConfigR :: Text -> Handler Html
+postTrackerConfigR name = do
+  ((result, widget), enctype) <- runFormPost (trackerConfigForm Nothing)
+  case result of
+    FormSuccess config -> do
+      now <- liftIO $ getCurrentTime
+      res <- runDB $
+        (selectOne do
+          tracker <- from (table @Tracker)
+          where_ (tracker ^. TrackerName ==. val name)
+          pure tracker)
+        >>= mapM \tracker@(Entity _ Tracker{..}) -> do
+          insert $ TrackerCommand
+            { trackerCommandTracker = entityKey tracker
+            , trackerCommandTimestamp = now
+            , trackerCommandStatus = Queued
+            , trackerCommandCommand = SetConfiguration (config
+                  { configHost = configHost config
+                      & fmap \host -> case trackerConfigVersion of
+                                  Nothing -> host <> "&v=1"
+                                  Just v  -> ""+|host|+ "&v="+|show (v + 1)|+""
+                                  -- FIXME: something less unsafe here?
+                  })
+            }
+          insert $ TrackerConfig
+            { trackerConfigTracker = entityKey tracker
+            , trackerConfigTimestamp = now
+            , trackerConfigSeen = False
+            , trackerConfigConfiguration = config
+            }
+      case res of
+        Just _  -> redirect $ TrackerViewR name
+        Nothing -> notFound
+    _ -> defaultLayout
+        [whamlet|
+            <p>_{MsgInvalidInput}.
+            <form method=post action=@{TrackerConfigR name} enctype=#{enctype}>
+                ^{widget}
+                <button>_{MsgSubmit}
+        |]
+
 getTrackerViewR :: Text -> Handler Html
 getTrackerViewR name =
   runDB (selectOne do
@@ -140,7 +209,7 @@ getTrackerViewR name =
     Nothing -> notFound
     Just (Entity trackerId Tracker{..}) -> do
 
-      (maybeStatus, maybePing) <- runDB $ do
+      (maybeStatus, maybePing, config) <- runDB $ do
         status <- selectOne do
           status <- from (table @TrackerStatus)
           where_ (status ^. TrackerStatusTracker ==. val trackerId)
@@ -151,9 +220,15 @@ getTrackerViewR name =
           where_ (ping ^. PingTrackerId ==. val trackerId)
           orderBy [desc $ ping ^. PingTimestamp]
           pure ping
-        pure (status, ping)
+        config <- selectOne do
+          config <- from (table @TrackerConfig)
+          where_ (config ^. TrackerConfigTracker ==. val trackerId)
+          orderBy [desc $ config ^. TrackerConfigTimestamp]
+          pure config
+        pure (status, ping, config)
 
       commandWidget <- trackerCommandWidget name
+      configWidget <- trackerConfigWidget (fmap (trackerConfigConfiguration . entityVal) config) name
 
       -- TODO: leaflet map; auto updates?
       defaultLayout [whamlet|
@@ -186,6 +261,8 @@ getTrackerViewR name =
           $nothing
             (none)
         <section>
+          ^{configWidget}
+        <section>
           ^{commandWidget}
         |]
 
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
diff --git a/tracktrain.cabal b/tracktrain.cabal
index 64b6edb..fb9cc70 100644
--- a/tracktrain.cabal
+++ b/tracktrain.cabal
@@ -100,6 +100,7 @@ library
                     , monad-control
                     , esqueleto
                     , base64
+                    , network-uri
     hs-source-dirs:   lib
     exposed-modules: GTFS
                    , Server