diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/Server/Frontend/Tracker.hs | 93 |
1 files changed, 85 insertions, 8 deletions
diff --git a/lib/Server/Frontend/Tracker.hs b/lib/Server/Frontend/Tracker.hs index ddbf5e9..e78e567 100644 --- a/lib/Server/Frontend/Tracker.hs +++ b/lib/Server/Frontend/Tracker.hs @@ -1,20 +1,21 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} module Server.Frontend.Tracker (getTrackerViewR, getTrackersR, postTrackersR, postTrackerDeleteR, - postTrackerCommandR) + postTrackerCommandR, postTrackerConfigR) where -import Data.Aeson (decode, Value) -import Data.ByteString (fromStrict) +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 (encodeUtf8) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Time (getCurrentTime) import qualified Data.UUID as UUID import Database.Esqueleto.Experimental hiding ((<&>)) @@ -24,7 +25,10 @@ import Server.Frontend.Routes (FrontendMessage (..), Handler, import Yesod hiding (delete, update, (=.), (==.)) +import Fmt +import qualified OwnTracks import OwnTracks.Command +import OwnTracks.Configuration (configHost) import OwnTracks.Status @@ -57,6 +61,7 @@ trackerCreateForm = renderDivs $ Tracker <*> pure False <*> areq textField (fieldSettingsLabel MsgTrackerAgent) Nothing <*> pure Nothing + <*> pure Nothing trackerCreateWidget :: Handler Html trackerCreateWidget = do @@ -130,6 +135,70 @@ postTrackerCommandR name = do <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 @@ -140,7 +209,7 @@ getTrackerViewR name = Nothing -> notFound Just (Entity trackerId Tracker{..}) -> do - (maybeStatus, maybePing) <- runDB $ do + (maybeStatus, maybePing, config) <- runDB $ do status <- selectOne do status <- from (table @TrackerStatus) where_ (status ^. TrackerStatusTracker ==. val trackerId) @@ -151,9 +220,15 @@ getTrackerViewR name = where_ (ping ^. PingTrackerId ==. val trackerId) orderBy [desc $ ping ^. PingTimestamp] pure ping - pure (status, 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| @@ -186,6 +261,8 @@ getTrackerViewR name = $nothing (none) <section> + ^{configWidget} + <section> ^{commandWidget} |] |