1 files changed, 275 insertions, 0 deletions
diff --git a/lib/Server/Frontend/Tracker.hs b/lib/Server/Frontend/Tracker.hs
new file mode 100644
index 0000000..e78e567
--- /dev/null
+++ b/lib/Server/Frontend/Tracker.hs
@@ -0,0 +1,275 @@
+{-# LANGUAGE BlockArguments  #-}
+{-# LANGUAGE QuasiQuotes     #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Server.Frontend.Tracker
+  (getTrackerViewR, getTrackersR, postTrackersR, postTrackerDeleteR,
+  postTrackerCommandR, postTrackerConfigR)
+where
+
+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              (decodeUtf8, encodeUtf8)
+import           Data.Time                       (getCurrentTime)
+import qualified Data.UUID                       as UUID
+import           Database.Esqueleto.Experimental hiding ((<&>))
+import           Persist
+import           Server.Frontend.Routes          (FrontendMessage (..), Handler,
+                                                  Route (..), Widget)
+import           Yesod                           hiding (delete, update, (=.),
+                                                  (==.))
+
+import           Fmt
+import qualified OwnTracks
+import           OwnTracks.Command
+import           OwnTracks.Configuration         (configHost)
+import           OwnTracks.Status
+
+
+getTrackersR :: Handler Html
+getTrackersR = do
+  trackers <- runDB $ select do
+      (t :& p) <- from $
+        (table @Tracker) `LeftOuterJoin` (table @Ping)
+        `on` \(t :& p) -> just (t ^. TrackerId) ==. p ?. PingTrackerId
+      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>
+      ^{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
+  <*> 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}
+        |]
+
+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}
+        |]
+
+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
+    tracker <- from (table @Tracker)
+    where_ (tracker ^. TrackerName ==. val name)
+    pure tracker)
+  >>= \case
+    Nothing -> notFound
+    Just (Entity trackerId Tracker{..}) -> do
+
+      (maybeStatus, maybePing, config) <- runDB $ do
+        status <- selectOne do
+          status <- from (table @TrackerStatus)
+          where_ (status ^. TrackerStatusTracker ==. val trackerId)
+          orderBy [desc $ status ^. TrackerStatusTimestamp]
+          pure status
+        ping <- selectOne do
+          ping <- from (table @Ping)
+          where_ (ping ^. PingTrackerId ==. val trackerId)
+          orderBy [desc $ ping ^. PingTimestamp]
+          pure 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|
+        <h1> _{MsgTracker name}
+        <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
+            LocationPermission: #{show $ statusLocationPermission trackerStatusStatus} <br>
+            BatteryOptimisations: #{show $ statusBatteryOptimizations trackerStatusStatus} <br>
+            Phone in power save mode: #{show $ statusPhonePowerSaveMode trackerStatusStatus}
+          $nothing
+            <em>Status unknown
+        <section>
+          <h2> _{MsgLastTrackerPosition}
+          $maybe Entity _ Ping{..} <- maybePing
+            Position: #{show pingGeopos} <br>
+            Timestamp: #{show pingTimestamp} <br>
+            $maybe ticketId <- pingTicket
+              Ticket: <a href="@{TicketViewR (coerce ticketId)}">#{UUID.toText (coerce ticketId)}</a>
+            $nothing
+              Ticket: (no assigned ticket)
+          $nothing
+            (none)
+        <section>
+          ^{configWidget}
+        <section>
+          ^{commandWidget}
+        |]
+
+
+postTrackerDeleteR :: Text -> Handler Html
+postTrackerDeleteR name = do
+  runDB $ delete do
+    tracker <- from (table @Tracker)
+    where_ (tracker ^. TrackerName ==. val name)
+  redirect TrackersR