From b893f41188eb6fe5bc1de54da7225fc150be7c7d Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Thu, 16 Apr 2026 12:35:31 +0200
Subject: Server.Frontend.Tracker: creation & deletion dialogs

---
 lib/Server/Frontend/Routes.hs  |  3 +-
 lib/Server/Frontend/Tickets.hs |  2 +-
 lib/Server/Frontend/Tracker.hs | 69 +++++++++++++++++++++++++++++++++++++-----
 3 files changed, 65 insertions(+), 9 deletions(-)

(limited to 'lib/Server/Frontend')

diff --git a/lib/Server/Frontend/Routes.hs b/lib/Server/Frontend/Routes.hs
index cf6e342..b84d49b 100644
--- a/lib/Server/Frontend/Routes.hs
+++ b/lib/Server/Frontend/Routes.hs
@@ -45,8 +45,9 @@ mkYesodData "Frontend" [parseRoutes|
 /ticket/announce/#UUID AnnounceR POST
 /ticket/del-announce/#UUID DelAnnounceR GET
 
-/trackers TrackersR GET
+/trackers TrackersR GET POST
 /tracker/#Text TrackerViewR GET
+/tracker/#Text/delete TrackerDeleteR POST
 
 /ticker/announce TickerAnnounceR POST
 /ticker/delete TickerDeleteR POST
diff --git a/lib/Server/Frontend/Tickets.hs b/lib/Server/Frontend/Tickets.hs
index 76146df..915521d 100644
--- a/lib/Server/Frontend/Tickets.hs
+++ b/lib/Server/Frontend/Tickets.hs
@@ -311,7 +311,7 @@ $maybe spaceTime <- spaceTimeMaybe
       <tr :trackerBlocked:.blocked>
         <td title="#{trackerAgent}">#{trackerAgent}
         <td title="#{key}">#{key}
-        <td title="#{trackerExpires}">#{trackerExpires}
+
         $if trackerBlocked
           <td title="_{MsgUnblockTrackerId}"><a href="@?{(TrackerIdBlock (TrackerKey key), [("unblock", "true")])}">_{MsgUnblockTrackerId}</a>
         $else
diff --git a/lib/Server/Frontend/Tracker.hs b/lib/Server/Frontend/Tracker.hs
index e3d88ba..a6c3c46 100644
--- a/lib/Server/Frontend/Tracker.hs
+++ b/lib/Server/Frontend/Tracker.hs
@@ -1,7 +1,7 @@
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE QuasiQuotes    #-}
 
-module Server.Frontend.Tracker (getTrackerViewR, getTrackersR) where
+module Server.Frontend.Tracker (getTrackerViewR, getTrackersR, postTrackersR, postTrackerDeleteR) where
 import           Data.Coerce                     (coerce)
 import           Data.Function                   ((&))
 import           Data.Functor                    ((<&>))
@@ -14,7 +14,8 @@ import           Database.Esqueleto.Experimental hiding ((<&>))
 import           Persist
 import           Server.Frontend.Routes          (FrontendMessage (..), Handler,
                                                   Route (..), Widget)
-import           Yesod                           hiding (update, (=.), (==.))
+import           Yesod                           hiding (delete, update, (=.),
+                                                  (==.))
 
 import           OwnTracks.Status
 
@@ -28,14 +29,53 @@ getTrackersR = do
       pure (t, p)
     & fmap associateJoin
 
+  createWidget <- trackerCreateWidget
+
   defaultLayout [whamlet|
     <h1> Trackers
-      <section>
-        <ul>
-          $forall (trackerId, (Tracker{..}, status)) <- M.toList trackers
-            <li><a href="@{TrackerViewR trackerName}">#{trackerName}</a>
+    <section>
+      <ul>
+        $forall (trackerId, (Tracker{..}, status)) <- M.toList trackers
+          <li><a href="@{TrackerViewR trackerName}">#{trackerName}</a>
+    <section>
+      ^{createWidget}
+  |]
+
+trackerCreateForm
+  :: Html
+  -> MForm Handler (FormResult Tracker, Widget)
+trackerCreateForm = renderDivs $ Tracker
+  <$> areq textField (fieldSettingsLabel MsgTrackerName) Nothing
+  <*> pure False
+  <*> areq textField (fieldSettingsLabel MsgTrackerAgent) Nothing
+  <*> pure Nothing
+
+trackerCreateWidget :: Handler Html
+trackerCreateWidget = do
+  (widget, enctype) <- generateFormPost trackerCreateForm
+  defaultLayout [whamlet|
+  <h2> _{MsgCreateTracker}
+  <form method=post action="@{TrackersR}" enctype=#{enctype}>
+    ^{widget}
+    <button>_{MsgSubmit}
   |]
 
+postTrackersR :: Handler Html
+postTrackersR = do
+  ((result, widget), enctype) <- runFormPost trackerCreateForm
+  case result of
+    FormSuccess ann -> do
+      runDB do
+        insert ann
+      redirect TrackersR
+    _ -> defaultLayout
+        [whamlet|
+            <p>_{MsgInvalidInput}.
+            <form method=post action=@{TrackersR} enctype=#{enctype}>
+                ^{widget}
+                <button>_{MsgSubmit}
+        |]
+
 getTrackerViewR :: Text -> Handler Html
 getTrackerViewR name =
   runDB (selectOne do
@@ -62,7 +102,14 @@ getTrackerViewR name =
       -- TODO: leaflet map; auto updates?
       defaultLayout [whamlet|
         <h1> _{MsgTracker name}
-        <em> (#{trackerId})
+        <section>
+          <h1> _{MsgTracker name}
+          <p>
+            Agent: #{trackerAgent} <br>
+            UUID: #{trackerId}
+          <p>
+            <form action=@{TrackerDeleteR trackerName} method="post">
+              <button> _{Msgdelete}
         <section>
           <h2> _{MsgLastTrackerStatus}
           $maybe Entity _ TrackerStatus{..} <- maybeStatus
@@ -83,3 +130,11 @@ getTrackerViewR name =
           $nothing
             (none)
         |]
+
+
+postTrackerDeleteR :: Text -> Handler Html
+postTrackerDeleteR name = do
+  runDB $ delete do
+    tracker <- from (table @Tracker)
+    where_ (tracker ^. TrackerName ==. val name)
+  redirect TrackersR
-- 
cgit v1.2.3