diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/API.hs | 2 | ||||
| -rw-r--r-- | lib/OwnTracks/Configuration.hs | 1 | ||||
| -rw-r--r-- | lib/Persist.hs | 9 | ||||
| -rw-r--r-- | lib/Server/Frontend/Routes.hs | 1 | ||||
| -rw-r--r-- | lib/Server/Frontend/Tracker.hs | 93 | ||||
| -rw-r--r-- | lib/Server/Ingest.hs | 16 | ||||
| -rw-r--r-- | tracktrain.cabal | 1 |
7 files changed, 112 insertions, 11 deletions
@@ -83,7 +83,7 @@ type GtfsRealtimeAPI = "servicealerts" :> QueryFlag "force" :> Get '[Proto] Feed :<|> "vehiclepositions" :> QueryFlag "force" :> Get '[Proto] FeedMessage type OwnTracksAPI = - "pub" :> QueryParam "u" Text :> QueryParam "d" Text :> ReqBody '[JSON] OT.Message :> Post '[JSON] [OT.Command] + "pub" :> QueryParam "u" Text :> QueryParam "d" Text :> QueryParam "version" Int :> ReqBody '[JSON] OT.Message :> Post '[JSON] [OT.Command] type CompleteAPI = diff --git a/lib/OwnTracks/Configuration.hs b/lib/OwnTracks/Configuration.hs index 0cb361d..a10a46e 100644 --- a/lib/OwnTracks/Configuration.hs +++ b/lib/OwnTracks/Configuration.hs @@ -91,6 +91,7 @@ data Configuration = Configuration -- ^ Add extended data attributes to location messages (iOS,Android/boolean) , configHost :: Maybe Text -- ^ MQTT endpoint host (iOS,Android/string) + -- FIXME: structured type here? , configHttpHeaders :: Maybe Text -- ^ extra HTTP headers:field names and field content are separated by a colon (:), multiple fields by a backslash-n (\n) \<field-name>:\<field-content>\n\<field-name>:\<field-content>... (iOS only/string) , configIgnoreInaccurateLocations :: Maybe Int diff --git a/lib/Persist.hs b/lib/Persist.hs index dbab9bd..6f459fc 100644 --- a/lib/Persist.hs +++ b/lib/Persist.hs @@ -94,6 +94,7 @@ derivePersistFieldJSON "Value" -- We derive these here so that OwnTracks.* can become its own package eventually derivePersistFieldJSON "OwnTracks.Status" derivePersistFieldJSON "OwnTracks.Command" +derivePersistFieldJSON "OwnTracks.Configuration" data CommandStatus = Queued | Sent @@ -144,6 +145,7 @@ Tracker sql=tt_tracker blocked Bool agent Text currentTicket TicketId Maybe + configVersion Int Maybe deriving Eq Show Generic TrackerStatus sql=tt_tracker_status @@ -164,6 +166,13 @@ TrackerCommand sql=tt_tracker_command command OwnTracks.Command deriving Show Eq +TrackerConfig sql=tt_tracker_config + tracker TrackerId + timestamp UTCTime + seen Bool + configuration OwnTracks.Configuration + deriving Show Eq + -- raw frames as received from OBUs Ping json sql=tt_trip_ping ticket TicketId Maybe OnDeleteCascade OnUpdateCascade diff --git a/lib/Server/Frontend/Routes.hs b/lib/Server/Frontend/Routes.hs index d6b82e2..684d69d 100644 --- a/lib/Server/Frontend/Routes.hs +++ b/lib/Server/Frontend/Routes.hs @@ -49,6 +49,7 @@ mkYesodData "Frontend" [parseRoutes| /tracker/#Text TrackerViewR GET /tracker/#Text/delete TrackerDeleteR POST /tracker/#Text/command TrackerCommandR POST +/tracker/#Text/config TrackerConfigR POST /ticker/announce TickerAnnounceR POST /ticker/delete TickerDeleteR POST 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} |] diff --git a/lib/Server/Ingest.hs b/lib/Server/Ingest.hs index c598ac2..ec99e60 100644 --- a/lib/Server/Ingest.hs +++ b/lib/Server/Ingest.hs @@ -75,7 +75,7 @@ handleTrackerRegister dbpool RegisterJson{..} = do today <- liftIO getCurrentTime <&> utctDay expires <- liftIO $ getCurrentTime <&> addUTCTime validityPeriod runSql dbpool $ do - TrackerKey tracker <- insert (Tracker "dummy" {-expires-} False registerAgent Nothing) + TrackerKey tracker <- insert (Tracker "dummy" {-expires-} False registerAgent Nothing Nothing) pure (coerce tracker) where validityPeriod :: NominalDiffTime @@ -126,9 +126,10 @@ handleOwntracksMessage -> ServerConfig -> Maybe Text -> Maybe Text + -> Maybe Int -> Message -> LoggingT (ReaderT LoggingConfig Handler) [Command] -handleOwntracksMessage dbpool subscribers cfg maybeUser device msg = do +handleOwntracksMessage dbpool subscribers cfg maybeUser device maybeVersion msg = do user <- case maybeUser of Just user -> pure user Nothing -> throwError err401 @@ -145,6 +146,17 @@ handleOwntracksMessage dbpool subscribers cfg maybeUser device msg = do Just tracker -> pure tracker Nothing -> throw err401 + whenJust maybeVersion \version -> do + whenJust trackerConfigVersion \tversion -> do + when (tversion > version) $ logWarnN $ "Tracker "+|trackerName|+" sent message tagged with older config "+|version|+" after we've seen it using config "+|tversion|+"." + runSql dbpool $ do + when (tversion < version) $ E.update \t -> do + set t [TrackerConfigVersion E.=. val (Just version)] + where_ (t ^. TrackerId E.==. val trackerId) + E.update \c -> do + set c [TrackerConfigSeen E.=. val True] + where_ (c ^. TrackerConfigTracker E.==. val trackerId) + case msg of MsgStatus status -> do now <- liftIO getCurrentTime diff --git a/tracktrain.cabal b/tracktrain.cabal index 64b6edb..fb9cc70 100644 --- a/tracktrain.cabal +++ b/tracktrain.cabal @@ -100,6 +100,7 @@ library , monad-control , esqueleto , base64 + , network-uri hs-source-dirs: lib exposed-modules: GTFS , Server |