1 files changed, 85 insertions, 8 deletions

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}
         |]