diff options
| -rw-r--r-- | lib/API.hs | 2 | ||||
| -rw-r--r-- | lib/OwnTracks.hs | 3 | ||||
| -rw-r--r-- | lib/OwnTracks/Command.hs | 16 | ||||
| -rw-r--r-- | lib/OwnTracks/Configuration.hs | 70 | ||||
| -rw-r--r-- | lib/Persist.hs | 14 | ||||
| -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 | ||||
| -rw-r--r-- | messages/en.msg | 1 |
9 files changed, 152 insertions, 45 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] () + "pub" :> QueryParam "u" Text :> QueryParam "d" Text :> ReqBody '[JSON] OT.Message :> Post '[JSON] [OT.Command] type CompleteAPI = diff --git a/lib/OwnTracks.hs b/lib/OwnTracks.hs index c39a3bc..e9bb011 100644 --- a/lib/OwnTracks.hs +++ b/lib/OwnTracks.hs @@ -20,6 +20,7 @@ import Data.Aeson.Types (Parser) import Data.ByteString (ByteString) import Data.ByteString.Base64 import Data.Functor ((<&>)) +import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) @@ -48,5 +49,5 @@ instance FromJSON Message where "location" -> MsgLocation <$> parseJSON v "status" -> MsgStatus <$> parseJSON v "configuration" -> MsgConfig <$> parseJSON v - "waypoints" -> MsgWaypoints <$> o .: "waypoints" + "waypoints" -> MsgWaypoints <$> (fmap (fromMaybe []) (o .:? "waypoints")) _ -> fail "unknown _type of owntracks message." diff --git a/lib/OwnTracks/Command.hs b/lib/OwnTracks/Command.hs index 257d3e3..532a593 100644 --- a/lib/OwnTracks/Command.hs +++ b/lib/OwnTracks/Command.hs @@ -42,6 +42,7 @@ data Command = -- ^ Imports and activates new configuration values (iOS,Android) | GetWaypoints -- ^ Triggers publish of a waypoints message (iOS,Android) + deriving (Eq, Show, Generic) instance ToJSON Command where toJSON c = object ( "_type" .= String "cmd" @@ -61,3 +62,18 @@ instance ToJSON Command where SetWaypoints ws -> [ "waypoints" .= ws ] SetConfiguration c -> [ "configuration" .= c ] _ -> [] + +instance FromJSON Command where + parseJSON (Object v) = do + action :: Text <- v .: "action" + case action of + "dump" -> pure Dump + "status" -> pure GetStatus + "reportSteps" -> ReportSteps <$> v .: "from" <*> v .: "to" + "reportLocation" -> pure ReportLocation + "clearWaypoints" -> pure ClearWaypoints + "setWaypoints" -> SetWaypoints <$> v .: "waypoints" + "setConfiguration" -> SetConfiguration <$> v .: "configuration" + "waypoints" -> pure GetWaypoints + _ -> fail "unknown action in _type=command" + parseJSON _ = fail "Command should be an object" diff --git a/lib/OwnTracks/Configuration.hs b/lib/OwnTracks/Configuration.hs index 5880c69..0cb361d 100644 --- a/lib/OwnTracks/Configuration.hs +++ b/lib/OwnTracks/Configuration.hs @@ -59,21 +59,21 @@ instance ToJSON ProtocolMode where data Configuration = Configuration { configAdapt :: Maybe Int -- ^ time in minutes of non-movement before switching from move to significant mode. 0 (zero) means disabled. Defaults to 0 (zero) (iOS/integer/minutes/optional) - , configAllowRemoteLocation :: Bool + , configAllowRemoteLocation :: Maybe Bool -- ^ Respond to reportLocation cmd message (iOS/boolean) - , configAllowInvalidCerts :: Bool + , configAllowInvalidCerts :: Maybe Bool -- ^ disable TLS certificate checks insecure (iOS/boolean) - , configAuth :: Bool + , configAuth :: Maybe Bool -- ^ Use username and password for endpoint authentication (iOS,Android/boolean) - , configAutostartOnBoot :: Bool + , configAutostartOnBoot :: Maybe Bool -- ^ Autostart the app on device boot (Android/boolean) - , configCleanSession :: Bool + , configCleanSession :: Maybe Bool -- ^ MQTT endpoint clean session (iOS,Android/boolean) , configClientId :: Maybe Text -- ^ client id to use for MQTT connect. Defaults to "user deviceId" (iOS,Android/string) , configClientpkcs :: Maybe Text -- ^ Name of the client pkcs12 file (iOS/string) - , configCmd :: Bool + , configCmd :: Maybe Bool -- ^ Respond to cmd messages (iOS,Android/boolean) , configConnectionTimeoutSeconds :: Maybe Int -- ^ (default 30) TCP timeout for establishing a connection to the MQTT / HTTP broker, (Android/int) @@ -81,41 +81,41 @@ data Configuration = Configuration -- ^ Number of days to keep locations stored locally. 0 means no local keeping of locations. A negative number indicates to use the positions value. Defaults to -1 for backward compatibility. (iOS/integer/days) , configDebugLog :: Maybe Bool -- ^ (default false) whether or not debug logs should be shown in the log viewer / exporter activity (Android/bool) - , configDeviceId :: Text + , configDeviceId :: Maybe Text -- ^ id of the device used for pubTopicBase and clientId construction. Defaults to the os name of the device (iOS,Android/string) , configDowngrade :: Maybe Int -- ^ battery level below which to downgrade monitoring from move mode (iOS/integer/percent/optional) , configEcryptionKey :: Maybe Text -- ^ the secret key used for payload encryption (iOS,Android/string) - , configExtendedData :: Bool + , configExtendedData :: Maybe Bool -- ^ Add extended data attributes to location messages (iOS,Android/boolean) - , configHost :: Text + , configHost :: Maybe Text -- ^ MQTT endpoint host (iOS,Android/string) , 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 :: Int + , configIgnoreInaccurateLocations :: Maybe Int -- ^ Location accuracy below which reports are supressed. 0 means no locations are suppressed. (iOS,Android/integer/meters) - , configIgnoreStaleLocations :: Bool + , configIgnoreStaleLocations :: Maybe Bool -- ^ Number of days after which location updates are assumed stale. Locations sent by friends older than the number of days specified here will not be shown on map or in friends list. Defaults to 0, which means stale locations are not filtered. (iOS,Android/integer/days) - , configKeepalive :: Int + , configKeepalive :: Maybe Int -- ^ MQTT endpoint keepalive (iOS,Android/integer/seconds) - , configLocatorDisplacement :: Int + , configLocatorDisplacement :: Maybe Int -- ^ maximum distance between location source updates (iOS,Android/integer/meters) - , configLocatorInterval :: Int + , configLocatorInterval :: Maybe Int -- ^ maximum interval between location source updates (iOS,Android/integer/seconds) - , configLocatorPriority :: LocatorPriority + , configLocatorPriority :: Maybe LocatorPriority -- ^ source/power setting for location updates (Android/integer) , configLocked :: Maybe Bool -- ^ Locks settings screen on device for editing (iOS/boolean) , configMaxHistory :: Maybe Int -- ^ Number of notifications to store historically. Zero (0) means no notifications are stored and history tab is hidden. Defaults to zero. (iOS/integer) - , configMode :: ProtocolMode + , configMode :: Maybe ProtocolMode -- ^ Endpoint protocol mode (iOS,Android/integer) - , configMonitoring :: MonitoringMode + , configMonitoring :: Maybe MonitoringMode -- ^ Location reporting mode (iOS,Android/integer) - , configProtocolLevel :: Int + , configProtocolLevel :: Maybe Int -- ^ MQTT broker protocol level (iOS,Android/integer) - , configNotificationLocation :: Bool + , configNotificationLocation :: Maybe Bool -- ^ Show last reported location in ongoing notification (Android/boolean) , configOpencageApiKey :: Maybe Text -- ^ API key for alternate Geocoding provider. See OpenCage for details. (Android/string) @@ -127,49 +127,49 @@ data Configuration = Configuration -- ^ Passphrase of the client pkcs12 file (iOS/string) , configPassword :: Maybe Text -- ^ Endpoint password (iOS,Android/string) - , configPegLocatorFastestIntervalToInterval :: Bool + , configPegLocatorFastestIntervalToInterval :: Maybe Bool -- ^ (default false) - if true, requests that that the device provide locations no faster than the specified interval. Location providers often use the requested interval as a "at least every" setting, and may return locations more frequencly. Some people wanted the behaviour where it also meant "no more frequently than", so this setting lets them specify this (Android/bool) , configPing :: Maybe Int -- ^ Interval in which location messages of with t:p are reported (Android/integer) - , configPort :: Int + , configPort :: Maybe Int -- ^ MQTT endpoint port (iOS,Android/integer) , configPositions :: Maybe Int -- ^ Number of locations to keep for friends and own device and display (iOS/integer) , configPubTopicBase :: Maybe Text -- ^ MQTT topic base to which the app publishes; %u is replaced by the user name, %d by device (iOS,Android/string) - , configPubRetain :: Bool + , configPubRetain :: Maybe Bool -- ^ MQTT retain flag for reported messages (iOS,Android/boolean) - , configPubQos :: Int + , configPubQos :: Maybe Int -- ^ MQTT QoS level for reported messages (iOS,Android/integer) , configRanging :: Maybe Bool -- ^ Beacon ranging (iOS/boolean) , configRemoteConfiguration :: Maybe Bool -- ^ Allow remote configuration by sending a setConfiguration cmd message (Android/boolean) - , configSub :: Bool + , configSub :: Maybe Bool -- ^ subscribe to subTopic via MQTT (iOS,Android/boolean) - , configSubTopic :: Text + , configSubTopic :: Maybe Text -- ^ A whitespace separated list of MQTT topics to which the app subscribes if sub is true (defaults see topics) (iOS,Android/string) - , configSubQos :: Bool + , configSubQos :: Maybe Bool -- ^ (iOS,Android/boolean) - , configTid :: Text + , configTid :: Maybe Text -- ^ Two digit Tracker ID used to display short name and default face of a user (iOS,Android/string) - , configTls :: Bool + , configTls :: Maybe Bool -- ^ MQTT endpoint TLS connection (iOS,Android/boolean) , configTlsClientCrtPassword :: Maybe Text -- ^ Passphrase of the client pkcs12 file (Android/string) - , configUrl :: Text + , configUrl :: Maybe Text -- ^ HTTP endpoint URL to which messages are POSTed (iOS,Android/string) - , configUsername :: Text + , configUsername :: Maybe Text -- ^ Endpoint username (iOS,Android/string) - , configWs :: Bool + , configWs :: Maybe Bool -- ^ use MQTT over Websocket, default false (iOS,Android/boolean) - , configWaypoints :: [Waypoint] + , configWaypoints :: Maybe [Waypoint] -- ^ Array of waypoint messages (iOS,Android/array) } deriving (Show, Eq, Generic) -TH.deriveJSON (TH.defaultOptions +TH.deriveJSON (TH.defaultOptions -- TODO: _type=configuration missing! { TH.omitNothingFields = True - , TH.rejectUnknownFields = False - , TH.fieldLabelModifier = drop 5 . \(x:xs) -> toLower x : xs + , TH.rejectUnknownFields = True + , TH.fieldLabelModifier = (\(x:xs) -> toLower x : xs) . drop 6 }) 'Configuration diff --git a/lib/Persist.hs b/lib/Persist.hs index 7ff3f1d..dbab9bd 100644 --- a/lib/Persist.hs +++ b/lib/Persist.hs @@ -93,8 +93,14 @@ derivePersistFieldJSON "Value" -- We derive these here so that OwnTracks.* can become its own package eventually derivePersistFieldJSON "OwnTracks.Status" +derivePersistFieldJSON "OwnTracks.Command" +data CommandStatus = Queued | Sent + deriving (Eq, Show, Read, Generic) + +derivePersistField "CommandStatus" + share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| Ticket sql=tt_ticket Id UUID default=uuid_generate_v4() @@ -150,6 +156,14 @@ TrackerTicket tracker TrackerId OnDeleteCascade OnUpdateCascade UniqueTrackerTicket ticket tracker +-- owntracks commands enqueued, to be sent to a tracker on next contact +TrackerCommand sql=tt_tracker_command + tracker TrackerId + timestamp UTCTime + status CommandStatus + command OwnTracks.Command + 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 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 diff --git a/messages/en.msg b/messages/en.msg index 50c00d9..a3ab7d7 100644 --- a/messages/en.msg +++ b/messages/en.msg @@ -29,6 +29,7 @@ TrackerAgent: Agent CreateTracker: Create new tracker LastTrackerStatus: Last Status LastTrackerPosition: Last Position +SendCommand: Send Command Status: Status Expires: Expires Agent: Agent |