diff --git a/src/Tesla.hs b/src/Tesla.hs --- a/src/Tesla.hs +++ b/src/Tesla.hs @@ -13,8 +13,10 @@ module Tesla ( authenticate, refreshAuth, AuthResponse(..), - Product(..), vehicleName, vehicleID, energyID, _ProductVehicle, _ProductEnergy, _ProductPowerWall, + Product(..), vehicleName, vehicleID, vehicleState, + energyID, _ProductVehicle, _ProductEnergy, _ProductPowerWall, VehicleID, vehicles, products, + VehicleState(..), vsFromString, EnergyID, energyIDs, fromToken, authOpts, baseURL, decodeProducts @@ -123,7 +125,7 @@ xcode u = head . mapMaybe (\s -> let [k,v] = T.splitOn "=" s in if k == "code" then Just v else Nothing) $ T.splitOn "&" (T.splitOn "?" (T.pack u) !! 1) translateCreds :: AuthInfo -> AuthResponse -> IO AuthResponse -translateCreds ai@AuthInfo{..} AuthResponse{..} = do +translateCreds AuthInfo{..} AuthResponse{..} = do -- 4. And we finally get the useful credentials by exchanging the temporary credentials. let jreq2 = encode $ Object (mempty & at "grant_type" ?~ "urn:ietf:params:oauth:grant-type:jwt-bearer" @@ -149,12 +151,7 @@ jOpts = aOpts & header "content-type" .~ ["application/json"] aOpts :: Options -aOpts = defaults - & header "Accept" .~ ["*/*"] - & header "User-Agent" .~ [ua] - & header "x-tesla-user-agent" .~ [userAgent] - & header "X-Requested-With" .~ ["com.teslamotors.tesla"] - where ua = "Mozilla/5.0 (Linux; Android 10; Pixel 3 Build/QQ2A.200305.002; wv) AppleWebKit/537.36 (KHTML, like Gecko) Version/4.0 Chrome/85.0.4183.81 Mobile Safari/537.36" +aOpts = defaults & header "Accept" .~ ["*/*"] -- | A VehicleID. type VehicleID = Text @@ -162,8 +159,19 @@ -- | An energy site ID. type EnergyID = Integer +-- | Possible states a vehicle may be in. +data VehicleState = VOnline | VOffline | VAsleep | VWaking | VUnknown + deriving (Show, Read, Eq) + +vsFromString :: Text -> VehicleState +vsFromString "online" = VOnline +vsFromString "offline" = VOffline +vsFromString "asleep" = VAsleep +vsFromString "waking" = VWaking +vsFromString _ = VUnknown + -- | Tesla Product Types. -data Product = ProductVehicle { _vehicleName :: Text, _vehicleID :: VehicleID } +data Product = ProductVehicle { _vehicleName :: Text, _vehicleID :: VehicleID, _vehicleState :: VehicleState } | ProductEnergy { _energyID :: EnergyID } | ProductPowerWall deriving (Show, Read, Eq) @@ -175,7 +183,10 @@ where prod o = asum [ prodCar, prodSolar, Nothing ] where - prodCar = ProductVehicle <$> (o ^? key "display_name" . _String) <*> (o ^? key "id_s" . _String) + prodCar = ProductVehicle + <$> (o ^? key "display_name" . _String) + <*> (o ^? key "id_s" . _String) + <*> (o ^? key "state" . _String . to vsFromString) prodSolar = ProductEnergy <$> (o ^? key "energy_site_id" . _Integer) -- | Get all products associated with this account. @@ -184,7 +195,7 @@ -- | Get a mapping of vehicle name to vehicle ID. vehicles :: [Product] -> Map Text Text -vehicles = Map.fromList . toListOf (folded . _ProductVehicle) +vehicles = Map.fromList . fmap (\(a,b,_) -> (a,b)) . toListOf (folded . _ProductVehicle) -- | Get a list of Solar ID installations. energyIDs :: [Product] -> [EnergyID] diff --git a/src/Tesla/Car.hs b/src/Tesla/Car.hs --- a/src/Tesla/Car.hs +++ b/src/Tesla/Car.hs @@ -23,7 +23,7 @@ Car, runCar, runNamedCar, VehicleID, -- * Requests - vehicleData, nearbyChargers, + vehicleData, nearbyChargers, vehicleStatus, isAwake, -- * Convenience functions for examining VehicleData VehicleData, isUserPresent, isCharging, teslaTS, maybeTeslaTS, Door(..), OpenState(..), _Open, _Closed, doors, openDoors, @@ -39,6 +39,7 @@ import Control.Exception (Exception, throwIO) import Control.Lens +import Data.Foldable (fold) import Control.Monad ((<=<)) import Control.Monad.Catch (MonadCatch (..), MonadMask (..), MonadThrow (..)) import Control.Monad.IO.Class (MonadIO (..)) @@ -47,7 +48,7 @@ import Control.Monad.Reader (MonadReader, ReaderT (..), asks, runReaderT) import Data.Aeson (FromJSON (..), Options (..), Result (..), Value (..), decode, defaultOptions, fieldLabelModifier, fromJSON, genericParseJSON, withObject, (.:)) -import Data.Aeson.Lens (key, values, _Bool, _Integer) +import Data.Aeson.Lens (key, values, _Bool, _Integer, _String) import qualified Data.ByteString.Lazy as BL import qualified Data.Map.Strict as Map import Data.Maybe (fromJust, fromMaybe) @@ -124,6 +125,18 @@ -- Lens when you need it but some convenience methods for common -- | A VehicleIDaccesses are available in this module. type VehicleData = BL.ByteString + +-- | vehicleStatus returns the current status of the current vehicle. +vehicleStatus :: MonadIO m => Car m VehicleState +vehicleStatus = do + v <- currentVehicleID + r <- jgetAuth (fold [baseURL, "api/1/vehicles/", unpack v]) + let (Just x) = (r :: Value) ^? (key "response" . key "state" . _String . to vsFromString) + pure x + +-- | isAwake returns true if the current vehicle is awake and online. +isAwake :: MonadIO m => Car m Bool +isAwake = (== VOnline) <$> vehicleStatus -- | Fetch the VehicleData. vehicleData :: MonadIO m => Car m VehicleData diff --git a/tesla.cabal b/tesla.cabal --- a/tesla.cabal +++ b/tesla.cabal @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: 236741807bd9077d0f64ee24d77b18f02891eb559659adf6c66a91c5b5216fe5 +-- hash: 24dfc3529bdcf280c4391d9a54fb35f858c54887d78fd748fb93b47ef664b88d name: tesla -version: 0.3.1.0 +version: 0.4.0.0 synopsis: Tesla API client. description: Please see the README on GitHub at category: Web @@ -53,32 +53,35 @@ Paths_tesla hs-source-dirs: src - default-extensions: OverloadedStrings RecordWildCards NamedFieldPuns + default-extensions: + OverloadedStrings + RecordWildCards + NamedFieldPuns ghc-options: -Wall build-depends: - aeson >=1.4.5 && <1.5 + aeson >=1.4.5 && <1.6 , base >=4.7 && <5 , base64-bytestring - , bytestring >=0.10 && <0.11 + , bytestring ==0.10.* , casing >=0.1.4 && <0.2 - , containers >=0.6 && <0.7 + , containers ==0.6.* , cryptonite , exceptions , generic-deriving >=1.12 && <1.14 - , lens >=4.17 && <4.19 + , lens >=4.17 && <4.20 , lens-aeson >=1.0 && <1.2 , memory , monad-logger - , mtl >=2.2 && <2.3 + , mtl ==2.2.* , random , retry , tagsoup - , template-haskell >=2.14 && <2.16 - , text >=1.2 && <1.3 + , template-haskell >=2.14 && <2.17 + , text ==1.2.* , time >=1.8 && <1.10 , unliftio-core , vector >=0.12.0 && <0.13 - , wreq >=0.5 && <0.6 + , wreq ==0.5.* default-language: Haskell2010 test-suite tesla-test @@ -88,35 +91,38 @@ Paths_tesla hs-source-dirs: test - default-extensions: OverloadedStrings RecordWildCards NamedFieldPuns + default-extensions: + OverloadedStrings + RecordWildCards + NamedFieldPuns ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: HUnit - , aeson >=1.4.5 && <1.5 + , aeson >=1.4.5 && <1.6 , base >=4.7 && <5 , base64-bytestring - , bytestring >=0.10 && <0.11 + , bytestring ==0.10.* , casing >=0.1.4 && <0.2 - , containers >=0.6 && <0.7 + , containers ==0.6.* , cryptonite , exceptions , generic-deriving >=1.12 && <1.14 - , lens >=4.17 && <4.19 + , lens >=4.17 && <4.20 , lens-aeson >=1.0 && <1.2 , memory , monad-logger - , mtl >=2.2 && <2.3 + , mtl ==2.2.* , random , retry , tagsoup , tasty , tasty-hunit , tasty-quickcheck - , template-haskell >=2.14 && <2.16 + , template-haskell >=2.14 && <2.17 , tesla - , text >=1.2 && <1.3 + , text ==1.2.* , time >=1.8 && <1.10 , unliftio-core , vector >=0.12.0 && <0.13 - , wreq >=0.5 && <0.6 + , wreq ==0.5.* default-language: Haskell2010