Owntracks{,.Status}: init

4 files changed, 144 insertions, 29 deletions

diff --git a/lib/OwnTracks.hs b/lib/OwnTracks.hs
new file mode 100644
index 0000000..ae81d0b
--- /dev/null
+++ b/lib/OwnTracks.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE BlockArguments     #-}
+{-# LANGUAGE DeriveAnyClass     #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DerivingVia        #-}
+{-# LANGUAGE LambdaCase         #-}
+{-# LANGUAGE ApplicativeDo         #-}
+
+
+module OwnTracks
+  (Message(..),
+   module OwnTracks.Location,
+   module OwnTracks.Status
+  ) where
+
+import           Data.Aeson
+import           Data.Aeson.Types       (Parser)
+import           Data.ByteString        (ByteString)
+import           Data.ByteString.Base64
+import           Data.Functor           ((<&>))
+import           Data.Text              (Text)
+import qualified Data.Text              as T
+import           Data.Text.Encoding     (encodeUtf8)
+import           Data.Time              (
+                                         UTCTime,
+                                         defaultTimeLocale,
+                                         parseTimeM)
+import           Database.Persist
+import           GHC.Generics           (Generic)
+
+import           OwnTracks.Location
+import           OwnTracks.Status
+
+data Message =
+    MsgLocation Location
+  | MsgStatus Status -- TODO
+  deriving (Generic, Show, Eq)
+
+instance FromJSON Message where
+  parseJSON v@(Object o) = do
+    ty :: Text <- o .: "_type"
+    case ty of
+      "location" -> MsgLocation <$> parseJSON v
+      "status" -> MsgStatus <$> parseJSON v
+      _ -> fail "unknown _type of owntracks message."
diff --git a/lib/OwnTracks/Location.hs b/lib/OwnTracks/Location.hs
index de18596..b4bf807 100644
--- a/lib/OwnTracks/Location.hs
+++ b/lib/OwnTracks/Location.hs
@@ -57,10 +57,10 @@ instance FromJSON Trigger where
     "C" -> pure CircularRegionEnterLeavePlus
     "b" -> pure BeaconRegionEnterLeave
     "r" -> pure ReportLocationResponse
-    "m" -> pure ManualTrigger
+    "u" -> pure ManualTrigger
     "t" -> pure Timer
     "v" -> pure LocationsServices
-    _   -> fail "Unknown Trigger Type (not one of p, c, C, b, r, m, t, v)"
+    other   -> fail $ show other <> "Unknown Trigger Type (not one of p, c, C, b, r, m, t, v)"
   parseJSON _ = fail "Trigger Type must be a string"
 
 data MonitoringMode = Quiet | Manual | Significant | Move
@@ -93,7 +93,7 @@ data Location = Location
   -- ^ Altitude measured above sea level (iOS,Android/integer/meters/optional)
   , locationBattery             :: Maybe Int
   -- ^ Device battery level (iOS,Android/integer/percent/optional)
-  , locationBatteryStatus       :: BatteryStatus
+  , locationBatteryStatus       :: Maybe BatteryStatus
   -- ^ Battery Status 0=unknown, 1=unplugged, 2=charging, 3=full (iOS, Android)
   , locationCourse              :: Maybe Int
   -- ^ Course over ground (iOS/integer/degree/optional)
@@ -143,38 +143,38 @@ data Location = Location
 
 instance FromJSON Location where
   parseJSON (Object v) = Location
-    <$> v .: "acc"
-    <*> v .: "alt"
-    <*> v .: "batt"
-    <*> (v .: "bs" <&> toEnum)
-    <*> v .: "cog"
+    <$> v .:? "acc"
+    <*> v .:? "alt"
+    <*> v .:? "batt"
+    <*> (v .:? "bs" <&> fmap toEnum)
+    <*> v .:? "cog"
     <*> v .: "lat"
     <*> v .: "lon"
-    <*> v .: "rad"
-    <*> v .: "t"
-    <*> v .: "tid"
+    <*> v .:? "rad"
+    <*> v .:? "t"
+    <*> v .:? "tid"
     <*> (v .: "tst" >>= parseUnixTime)
-    <*> v .: "vac"
-    <*> v .: "vel"
-    <*> v .: "p"
-    <*> v .: "poi"
-    <*> (v .: "image" >>= mapM fromBase64)
-    <*> v .: "imagename"
-    <*> (v .: "conn" >>= mapM parseConnection)
-    <*> v .: "tag"
-    <*> v .: "topic"
-    <*> v .: "inregions"
-    <*> v .: "inrids"
-    <*> (v .: "created_at" >>= mapM parseUnixTime)
-    <*> v .: "m"
-    <*> v .: "_id"
-    <*> v .: "motionactivities"
-    where parseUnixTime :: String -> Parser UTCTime
-          parseUnixTime = parseTimeM False defaultTimeLocale "%s"
+    <*> v .:? "vac"
+    <*> v .:? "vel"
+    <*> v .:? "p"
+    <*> v .:? "poi"
+    <*> (v .:? "image" >>= mapM fromBase64)
+    <*> v .:? "imagename"
+    <*> (v .:? "conn" >>= mapM parseConnection)
+    <*> v .:? "tag"
+    <*> v .:? "topic"
+    <*> v .:? "inregions"
+    <*> v .:? "inrids"
+    <*> (v .:? "created_at" >>= mapM parseUnixTime)
+    <*> v .:? "m"
+    <*> v .:? "_id"
+    <*> v .:? "motionactivities"
+    where parseUnixTime :: Int -> Parser UTCTime
+          parseUnixTime = parseTimeM False defaultTimeLocale "%s" . show
           parseConnection = withText "Connection" \case
             "o" -> pure Offline
             "m" -> pure Mobile
-            "w" -> Wifi <$> v .: "SSID" <*> v .: "BSSID"
+            "w" -> Wifi <$> v .:? "SSID" <*> v .:? "BSSID"
           fromBase64 v = case decodeBase64Untyped (encodeUtf8 v) of
             Right bytes -> pure bytes
             Left err -> fail $ "image field could not be read: " <> T.unpack err
diff --git a/lib/OwnTracks/Status.hs b/lib/OwnTracks/Status.hs
new file mode 100644
index 0000000..83b5956
--- /dev/null
+++ b/lib/OwnTracks/Status.hs
@@ -0,0 +1,65 @@
+{-# LANGUAGE DeriveAnyClass     #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DerivingVia        #-}
+{-# LANGUAGE RecordWildCards    #-}
+
+
+module OwnTracks.Status
+-- | https://owntracks.org/booklet/tech/json/
+  (Status(..)) where
+
+import           Data.Aeson
+import           Data.Aeson.Types       (Parser)
+import           Data.ByteString        (ByteString)
+import           Data.ByteString.Base64
+import           Data.Data              (Proxy (..))
+import           Data.Functor           ((<&>))
+import           Data.Text              (Text)
+import qualified Data.Text              as T
+import           Data.Text.Encoding     (encodeUtf8)
+import           Data.Time              (UTCTime, defaultTimeLocale, parseTimeM)
+import           GHC.Generics           (Generic)
+
+
+-- | An owntracks message with _type=status.
+--
+-- Currently only implements android-specific fields.
+data Status = Status
+  { statusId                   :: Maybe Text
+  -- ^ random identifier to be used by consumers to correlate & distinguish send/return messages (Android/string)
+  , statusCanHibernate         :: Maybe Int
+  -- ^ app can hibernate if not used (Android/integer)
+  , statusBatteryOptimizations :: Maybe Int
+  -- ^ app is configured with battery optimizations (Android/integer)
+  , statusLocationPermission   :: Maybe Int
+  -- ^ app location permissions (Android/integer)
+  , statusPhonePowerSaveMode   :: Maybe Int
+  -- ^ phone power save mode (Android/integer)
+  , statusWifiOnOff            :: Maybe Int
+  -- ^ wifi is on/off (Android/integer)
+  } deriving (Generic, Eq, Show)
+
+instance FromJSON Status where
+  parseJSON (Object v) = do
+    a <- v .:? "android"
+    Status
+      <$> v .:? "_id"
+      <*> a .:?? "hib"
+      <*> a .:?? "bo"
+      <*> a .:?? "loc"
+      <*> a .:?? "ps"
+      <*> a .:?? "wifi"
+      where
+        (.:??) :: FromJSON a => Maybe Object -> Data.Aeson.Key -> Parser (Maybe a)
+        (.:??) Nothing  = const $ pure Nothing
+        (.:??) (Just a) = (.:?) a
+
+instance ToJSON Status where
+  toEncoding Status{..} =
+    pairs ("_id" .= statusId
+           <> "hib" .= statusCanHibernate
+           <> "bo" .= statusBatteryOptimizations
+           <> "loc" .= statusLocationPermission
+           <> "ps" .= statusPhonePowerSaveMode
+           <> "wifi" .= statusWifiOnOff
+          )
diff --git a/tracktrain.cabal b/tracktrain.cabal
index d22a0a9..12d70dd 100644
--- a/tracktrain.cabal
+++ b/tracktrain.cabal
@@ -36,6 +36,8 @@ executable tracktrain
     default-language: GHC2021
     default-extensions: OverloadedStrings
                       , ScopedTypeVariables
+                      , BlockArguments
+                      , LambdaCase
 
 
 library
@@ -121,11 +123,15 @@ library
                  , Server.Frontend.Gtfs
                  , Server.Frontend.SpaceTime
                  , Server.Frontend.Ticker
+                 , OwnTracks
                  , OwnTracks.Location
+                 , OwnTracks.Status
     default-language: GHC2021
     default-extensions: OverloadedStrings
                       , ScopedTypeVariables
                       , ViewPatterns
+                      , BlockArguments
+                      , LambdaCase
 
 library gtfs-realtime
     build-depends: base