diff options
Diffstat (limited to 'lib/Server/Frontend')
| -rw-r--r-- | lib/Server/Frontend/Routes.hs | 1 | ||||
| -rw-r--r-- | lib/Server/Frontend/Tracker.hs | 60 |
2 files changed, 60 insertions, 1 deletions
diff --git a/lib/Server/Frontend/Routes.hs b/lib/Server/Frontend/Routes.hs index b84d49b..d6b82e2 100644 --- a/lib/Server/Frontend/Routes.hs +++ b/lib/Server/Frontend/Routes.hs @@ -48,6 +48,7 @@ mkYesodData "Frontend" [parseRoutes| /trackers TrackersR GET POST /tracker/#Text TrackerViewR GET /tracker/#Text/delete TrackerDeleteR POST +/tracker/#Text/command TrackerCommandR POST /ticker/announce TickerAnnounceR POST /ticker/delete TickerDeleteR POST diff --git a/lib/Server/Frontend/Tracker.hs b/lib/Server/Frontend/Tracker.hs index a6c3c46..ddbf5e9 100644 --- a/lib/Server/Frontend/Tracker.hs +++ b/lib/Server/Frontend/Tracker.hs @@ -1,13 +1,20 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE QuasiQuotes #-} -module Server.Frontend.Tracker (getTrackerViewR, getTrackersR, postTrackersR, postTrackerDeleteR) where +module Server.Frontend.Tracker + (getTrackerViewR, getTrackersR, postTrackersR, postTrackerDeleteR, + postTrackerCommandR) +where + +import Data.Aeson (decode, Value) +import Data.ByteString (fromStrict) 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.Time (getCurrentTime) import qualified Data.UUID as UUID import Database.Esqueleto.Experimental hiding ((<&>)) @@ -17,6 +24,7 @@ import Server.Frontend.Routes (FrontendMessage (..), Handler, import Yesod hiding (delete, update, (=.), (==.)) +import OwnTracks.Command import OwnTracks.Status @@ -76,6 +84,52 @@ postTrackersR = do <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} + |] + getTrackerViewR :: Text -> Handler Html getTrackerViewR name = runDB (selectOne do @@ -99,6 +153,8 @@ getTrackerViewR name = pure ping pure (status, ping) + commandWidget <- trackerCommandWidget name + -- TODO: leaflet map; auto updates? defaultLayout [whamlet| <h1> _{MsgTracker name} @@ -129,6 +185,8 @@ getTrackerViewR name = Ticket: (no assigned ticket) $nothing (none) + <section> + ^{commandWidget} |] |