From 5fa550010cd0d9293d253d9528a4029db26ced54 Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Sat, 2 May 2026 14:31:33 +0200
Subject: owntracks: support returning commands

---
 lib/Server/Frontend/Tracker.hs | 60 +++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 59 insertions(+), 1 deletion(-)

(limited to 'lib/Server/Frontend/Tracker.hs')

diff --git a/lib/Server/Frontend/Tracker.hs b/lib/Server/Frontend/Tracker.hs
index a6c3c46..ddbf5e9 100644
--- a/lib/Server/Frontend/Tracker.hs
+++ b/lib/Server/Frontend/Tracker.hs
@@ -1,13 +1,20 @@
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE QuasiQuotes    #-}
 
-module Server.Frontend.Tracker (getTrackerViewR, getTrackersR, postTrackersR, postTrackerDeleteR) where
+module Server.Frontend.Tracker
+  (getTrackerViewR, getTrackersR, postTrackersR, postTrackerDeleteR,
+  postTrackerCommandR)
+where
+
+import           Data.Aeson                      (decode, Value)
+import           Data.ByteString                 (fromStrict)
 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.Time                       (getCurrentTime)
 import qualified Data.UUID                       as UUID
 import           Database.Esqueleto.Experimental hiding ((<&>))
@@ -17,6 +24,7 @@ import           Server.Frontend.Routes          (FrontendMessage (..), Handler,
 import           Yesod                           hiding (delete, update, (=.),
                                                   (==.))
 
+import           OwnTracks.Command
 import           OwnTracks.Status
 
 
@@ -76,6 +84,52 @@ postTrackersR = do
                 <button>_{MsgSubmit}
         |]
 
+trackerCommandForm
+  :: Html -> MForm Handler (FormResult Command, Widget)
+trackerCommandForm = renderDivs do
+  text <- areq textField (fieldSettingsLabel MsgSendCommand) (Just "{\"action\": \"dump\"}")
+  let Just c = (decode (fromStrict (encodeUtf8 text)))
+  pure c
+
+trackerCommandWidget :: Text -> Handler Html
+trackerCommandWidget name = do
+  (widget, enctype) <- generateFormPost trackerCommandForm
+  defaultLayout [whamlet|
+  <h2> _{MsgSendCommand}
+  <form method=post action="@{TrackerCommandR name}" enctype=#{enctype}>
+    ^{widget}
+    <button>_{MsgSubmit}
+  |]
+
+postTrackerCommandR :: Text -> Handler Html
+postTrackerCommandR name = do
+  ((result, widget), enctype) <- runFormPost trackerCommandForm
+  case result of
+    FormSuccess command -> do
+      now <- liftIO $ getCurrentTime
+      res <- runDB $
+        (selectOne do
+          tracker <- from (table @Tracker)
+          where_ (tracker ^. TrackerName ==. val name)
+          pure tracker)
+        >>= mapM \tracker ->
+          insert $ TrackerCommand
+            { trackerCommandTracker = entityKey tracker
+            , trackerCommandTimestamp = now
+            , trackerCommandStatus = Queued
+            , trackerCommandCommand = command
+            }
+      case res of
+        Just _  -> redirect $ TrackerViewR name
+        Nothing -> notFound
+    _ -> defaultLayout
+        [whamlet|
+            <p>_{MsgInvalidInput}.
+            <form method=post action=@{TrackerCommandR name} enctype=#{enctype}>
+                ^{widget}
+                <button>_{MsgSubmit}
+        |]
+
 getTrackerViewR :: Text -> Handler Html
 getTrackerViewR name =
   runDB (selectOne do
@@ -99,6 +153,8 @@ getTrackerViewR name =
           pure ping
         pure (status, ping)
 
+      commandWidget <- trackerCommandWidget name
+
       -- TODO: leaflet map; auto updates?
       defaultLayout [whamlet|
         <h1> _{MsgTracker name}
@@ -129,6 +185,8 @@ getTrackerViewR name =
               Ticket: (no assigned ticket)
           $nothing
             (none)
+        <section>
+          ^{commandWidget}
         |]
 
 
-- 
cgit v1.2.3