Server.Frontend.Tracker: creation & deletion dialogs

1 files changed, 62 insertions, 7 deletions

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