path: root/lib/Server/Frontend/Tracker.hs

{-# 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