diff options
Diffstat (limited to 'lib/Server')
| -rw-r--r-- | lib/Server/Frontend/Routes.hs | 1 | ||||
| -rw-r--r-- | lib/Server/Frontend/Tracker.hs | 60 | ||||
| -rw-r--r-- | lib/Server/Ingest.hs | 30 |
3 files changed, 83 insertions, 8 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} |] diff --git a/lib/Server/Ingest.hs b/lib/Server/Ingest.hs index edbce08..c598ac2 100644 --- a/lib/Server/Ingest.hs +++ b/lib/Server/Ingest.hs @@ -54,8 +54,9 @@ import Data.Maybe (fromJust) import qualified Data.Text as T import Data.Time.LocalTime.TimeZone.Series (TimeZoneSeries) import qualified Data.UUID as UUID -import Database.Esqueleto.Experimental (from, selectOne, table, - val, where_, (^.)) +import Database.Esqueleto.Experimental (from, select, selectOne, + set, table, val, where_, + (^.)) import qualified Database.Esqueleto.Experimental as E import Extrapolation (Extrapolator (..), LinearExtrapolator (..), @@ -126,7 +127,7 @@ handleOwntracksMessage -> Maybe Text -> Maybe Text -> Message - -> LoggingT (ReaderT LoggingConfig Handler) () + -> LoggingT (ReaderT LoggingConfig Handler) [Command] handleOwntracksMessage dbpool subscribers cfg maybeUser device msg = do user <- case maybeUser of Just user -> pure user @@ -177,10 +178,25 @@ handleOwntracksMessage dbpool subscribers cfg maybeUser device msg = do , pingSequence = Nothing } pure () - Just ticketId -> do - runSql dbpool $ insertSentPing subscribers cfg undefined tracker ticketId - pure () - + Just ticketId -> + void $ runSql dbpool $ insertSentPing subscribers cfg undefined tracker ticketId + other -> logWarnN $ "received unhandled owntracks message: "+|show other|+"" + + commands <- runSql dbpool $ do + command <- select do + command <- from (table @TrackerCommand) + where_ (command ^. TrackerCommandTracker E.==. val trackerId + E.&&. command ^. TrackerCommandStatus E.==. val Queued) + pure command + -- this is silly; update does not support a RETURNING clause … + E.update \command -> do + set command [ TrackerCommandStatus E.=. val Sent ] + where_ (command ^. TrackerCommandTracker E.==. val trackerId + E.&&. command ^. TrackerCommandStatus E.==. val Queued) + pure command + + logInfoN $ "sending commands: "+|show (fmap (entityVal) commands)|+"" + pure (fmap (trackerCommandCommand . entityVal) commands) insertSentPing :: ServerState |