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/Routes.hs  |  1 +
 lib/Server/Frontend/Tracker.hs | 60 +++++++++++++++++++++++++++++++++++++++++-
 lib/Server/Ingest.hs           | 30 ++++++++++++++++-----
 3 files changed, 83 insertions(+), 8 deletions(-)

(limited to 'lib/Server')

diff --git a/lib/Server/Frontend/Routes.hs b/lib/Server/Frontend/Routes.hs
index b84d49b..d6b82e2 100644
--- a/lib/Server/Frontend/Routes.hs
+++ b/lib/Server/Frontend/Routes.hs
@@ -48,6 +48,7 @@ mkYesodData "Frontend" [parseRoutes|
 /trackers TrackersR GET POST
 /tracker/#Text TrackerViewR GET
 /tracker/#Text/delete TrackerDeleteR POST
+/tracker/#Text/command TrackerCommandR POST
 
 /ticker/announce TickerAnnounceR POST
 /ticker/delete TickerDeleteR POST
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}
         |]
 
 
diff --git a/lib/Server/Ingest.hs b/lib/Server/Ingest.hs
index edbce08..c598ac2 100644
--- a/lib/Server/Ingest.hs
+++ b/lib/Server/Ingest.hs
@@ -54,8 +54,9 @@ import           Data.Maybe                          (fromJust)
 import qualified Data.Text                           as T
 import           Data.Time.LocalTime.TimeZone.Series (TimeZoneSeries)
 import qualified Data.UUID                           as UUID
-import           Database.Esqueleto.Experimental     (from, selectOne, table,
-                                                      val, where_, (^.))
+import           Database.Esqueleto.Experimental     (from, select, selectOne,
+                                                      set, table, val, where_,
+                                                      (^.))
 import qualified Database.Esqueleto.Experimental     as E
 import           Extrapolation                       (Extrapolator (..),
                                                       LinearExtrapolator (..),
@@ -126,7 +127,7 @@ handleOwntracksMessage
   -> Maybe Text
   -> Maybe Text
   -> Message
-  -> LoggingT (ReaderT LoggingConfig Handler) ()
+  -> LoggingT (ReaderT LoggingConfig Handler) [Command]
 handleOwntracksMessage dbpool subscribers cfg maybeUser device msg = do
   user <- case maybeUser of
     Just user -> pure user
@@ -177,10 +178,25 @@ handleOwntracksMessage dbpool subscribers cfg maybeUser device msg = do
             , pingSequence = Nothing
             }
           pure ()
-        Just ticketId -> do
-          runSql dbpool $ insertSentPing subscribers cfg undefined tracker ticketId
-          pure ()
-
+        Just ticketId ->
+          void $ runSql dbpool $ insertSentPing subscribers cfg undefined tracker ticketId
+    other -> logWarnN $ "received unhandled owntracks message: "+|show other|+""
+
+  commands <- runSql dbpool $ do
+    command <- select do
+      command <- from (table @TrackerCommand)
+      where_ (command ^. TrackerCommandTracker E.==. val trackerId
+            E.&&. command ^. TrackerCommandStatus E.==. val Queued)
+      pure command
+    -- this is silly; update does not support a RETURNING clause …
+    E.update \command -> do
+      set command [ TrackerCommandStatus E.=. val Sent ]
+      where_ (command ^. TrackerCommandTracker E.==. val trackerId
+            E.&&. command ^. TrackerCommandStatus E.==. val Queued)
+    pure command
+
+  logInfoN $ "sending commands: "+|show (fmap (entityVal) commands)|+""
+  pure (fmap (trackerCommandCommand . entityVal) commands)
 
 insertSentPing
   :: ServerState
-- 
cgit v1.2.3