tesla 0.1.0.1 → 0.2.0.0

raw patch · 37 files changed

+712/−521 lines, 37 filesdep +exceptionsdep +monad-loggerdep +unliftio-corePVP ok

version bump matches the API change (PVP)

Dependencies added: exceptions, monad-logger, unliftio-core

API changes (from Hackage documentation)

Files

• src/Tesla.hs +57/−69
• src/Tesla/Auth.hs +58/−0
• src/Tesla/Car.hs +66/−66
• src/Tesla/Car/Command.hs +83/−0
• src/Tesla/Car/Command/Alerts.hs +11/−0
• src/Tesla/Car/Command/Charging.hs +19/−0
• src/Tesla/Car/Command/Climate.hs +46/−0
• src/Tesla/Car/Command/Doors.hs +23/−0
• src/Tesla/Car/Command/Homelink.hs +11/−0
• src/Tesla/Car/Command/Media.hs +18/−0
• src/Tesla/Car/Command/RemoteStart.hs +14/−0
• src/Tesla/Car/Command/Sentry.hs +13/−0
• src/Tesla/Car/Command/Sharing.hs +20/−0
• src/Tesla/Car/Command/Software.hs +19/−0
• src/Tesla/Car/Command/SpeedLimit.hs +24/−0
• src/Tesla/Car/Command/Valet.hs +16/−0
• src/Tesla/Car/Command/Windows.hs +29/−0
• src/Tesla/Car/Commands.hs +25/−0
• src/Tesla/Command.hs +0/−87
• src/Tesla/Command/Alerts.hs +0/−11
• src/Tesla/Command/Charging.hs +0/−19
• src/Tesla/Command/Climate.hs +0/−46
• src/Tesla/Command/Doors.hs +0/−18
• src/Tesla/Command/Homelink.hs +0/−11
• src/Tesla/Command/Media.hs +0/−18
• src/Tesla/Command/RemoteStart.hs +0/−14
• src/Tesla/Command/Sentry.hs +0/−12
• src/Tesla/Command/Sharing.hs +0/−20
• src/Tesla/Command/Software.hs +0/−19
• src/Tesla/Command/SpeedLimit.hs +0/−24
• src/Tesla/Command/Valet.hs +0/−15
• src/Tesla/Command/Windows.hs +0/−28
• src/Tesla/Commands.hs +0/−25
• src/Tesla/Energy.hs +84/−0
• src/Tesla/Internal/HTTP.hs +37/−0
• tesla.cabal +27/−18
• test/Spec.hs +12/−1

@@ -6,105 +6,93 @@ documented at https://tesla-api.timdorr.com/ -} -{-# LANGUAGE DeriveGeneric     #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE TupleSections     #-}  module Tesla     ( authenticate, refreshAuth, AuthResponse(..),-      AuthInfo(..),-      vehicles,-      fromToken, authOpts, baseURL+      Product(..), vehicleName, vehicleID, energyID, _ProductVehicle, _ProductEnergy, _ProductPowerWall,+      VehicleID, vehicles, products,+      EnergyID, energyIDs,+      fromToken, authOpts, baseURL,+      decodeProducts     ) where   import           Control.Lens import           Control.Monad.IO.Class (MonadIO (..))-import           Data.Aeson             (FromJSON (..), Options (..),-                                         Value (..), defaultOptions,-                                         fieldLabelModifier, genericParseJSON)-import           Data.Aeson.Lens        (key, values, _String)-import qualified Data.ByteString.Char8  as BC+import           Data.Aeson             (Value (..))+import           Data.Aeson.Lens        (key, _Array, _Integer, _String)+import           Data.Foldable          (asum) import           Data.Map.Strict        (Map) import qualified Data.Map.Strict        as Map+import           Data.Maybe             (catMaybes) import           Data.Text              (Text)-import           Generics.Deriving.Base (Generic)-import           Network.Wreq           (FormParam (..), Options, Response,-                                         asJSON, defaults, getWith, header,-                                         postWith, responseBody)+import           Network.Wreq           (FormParam (..)) +import           Tesla.Auth+import           Tesla.Internal.HTTP+ baseURL :: String baseURL = "https://owner-api.teslamotors.com/" authURL :: String authURL = baseURL <> "oauth/token" authRefreshURL :: String authRefreshURL = baseURL <> "oauth/token"-vehiclesURL :: String-vehiclesURL = baseURL <> "api/1/vehicles"+productsURL :: String+productsURL = baseURL <> "api/1/products"  -userAgent :: BC.ByteString-userAgent = "github.com/dustin/tesla 0.1"+-- | Authenticate to the Tesla service.+authenticate :: AuthInfo -> IO AuthResponse+authenticate AuthInfo{..} =+  jpostWith defOpts authURL ["grant_type" := ("password" :: String),+                             "client_id" := _clientID,+                             "client_secret" := _clientSecret,+                             "email" := _email,+                             "password" := _password] -defOpts :: Network.Wreq.Options-defOpts = defaults & header "User-Agent" .~ [userAgent]+-- | Refresh authentication credentials using a refresh token.+refreshAuth :: AuthInfo -> AuthResponse -> IO AuthResponse+refreshAuth AuthInfo{..} AuthResponse{..} =+  jpostWith defOpts authRefreshURL ["grant_type" := ("refresh_token" :: String),+                                    "client_id" := _clientID,+                                    "client_secret" := _clientSecret,+                                    "refresh_token" := _refresh_token] --- | An Authentication request.-data AuthInfo = AuthInfo {-  _clientID       :: String-  , _clientSecret :: String-  , _email        :: String-  , _password     :: String-  , _bearerToken  :: String-  } deriving(Show) --- | Get an AuthInfo instance from a bearer token.-fromToken :: String -> AuthInfo-fromToken t = AuthInfo{_bearerToken=t, _clientID="", _clientSecret="", _email="", _password=""}--jsonOpts :: Data.Aeson.Options-jsonOpts = defaultOptions {-  fieldLabelModifier = dropWhile (== '_')-  }---- | An Authentication response.-data AuthResponse = AuthResponse {-  _access_token    :: String-  , _expires_in    :: Int-  , _refresh_token :: String-  } deriving(Generic, Show)+-- | A VehicleID.+type VehicleID = Text -instance FromJSON AuthResponse where-  parseJSON = genericParseJSON jsonOpts+-- | An energy site ID.+type EnergyID = Integer --- | Authenticate to the Tesla service.-authenticate :: AuthInfo -> IO AuthResponse-authenticate AuthInfo{..} = do-  r <- asJSON =<< postWith defOpts authURL ["grant_type" := ("password" :: String),-                                            "client_id" := _clientID,-                                            "client_secret" := _clientSecret,-                                            "email" := _email,-                                            "password" := _password] :: IO (Response AuthResponse)-  pure $ r ^. responseBody+-- | Tesla Product Types.+data Product = ProductVehicle { _vehicleName :: Text, _vehicleID :: VehicleID }+             | ProductEnergy { _energyID :: EnergyID }+             | ProductPowerWall deriving (Show, Read, Eq) --- | Refresh authentication credentials using a refresh token.-refreshAuth :: AuthInfo -> AuthResponse -> IO AuthResponse-refreshAuth AuthInfo{..} AuthResponse{..} = do-  r <- asJSON =<< postWith defOpts authRefreshURL ["grant_type" := ("refresh_token" :: String),-                                                   "client_id" := _clientID,-                                                   "client_secret" := _clientSecret,-                                                   "refresh_token" := _refresh_token] :: IO (Response AuthResponse)-  pure $ r ^. responseBody+makePrisms ''Product+makeLenses ''Product +decodeProducts :: Value -> [Product]+decodeProducts = catMaybes . toListOf (key "response" . _Array . folded . to prod)+  where+    prod o = asum [ prodCar, prodSolar, Nothing ]+      where+        prodCar = ProductVehicle <$> (o ^? key "display_name" . _String) <*> (o ^? key "id_s" . _String)+        prodSolar = ProductEnergy <$> (o ^? key "energy_site_id" . _Integer) --- | Get a set of wreq options from an 'AuthInfo'.-authOpts :: AuthInfo -> Network.Wreq.Options-authOpts AuthInfo{..} = defOpts & header "Authorization" .~ ["Bearer " <> BC.pack _bearerToken]+-- | Get all products associated with this account.+products :: MonadIO m => AuthInfo -> m [Product]+products ai = decodeProducts <$> jgetWith (authOpts ai) productsURL  -- | Get a mapping of vehicle name to vehicle ID. vehicles :: MonadIO m => AuthInfo -> m (Map Text Text)-vehicles ai = do-  r <- liftIO (asJSON =<< getWith (authOpts ai) vehiclesURL :: IO (Response Value))-  let vals = r ^.. responseBody . key "response" . values . key "id_s" . _String-      keys = r ^.. responseBody . key "response" . values . key "display_name" . _String-  pure (Map.fromList $ zip keys vals)+vehicles = fmap (Map.fromList . toListOf (folded . _ProductVehicle)) . products++-- | Get a list of Solar ID installations.+energyIDs :: MonadIO m => AuthInfo -> m [EnergyID]+energyIDs = fmap (toListOf $ folded . _ProductEnergy) . products

@@ -0,0 +1,58 @@+{-|+Module:      Tesla.Auth+Description: Tesla Authentication structures.++Authentication related data structures.+-}++{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}++module Tesla.Auth (AuthInfo(..),+                   clientID, clientSecret, email, password, bearerToken,+                   fromToken,+                   AuthResponse(..), access_token, expires_in, refresh_token,+                   HasTeslaAuth(..)+                  ) where++import           Control.Lens+import           Data.Aeson             (FromJSON (..), Options, defaultOptions, fieldLabelModifier, genericParseJSON)+import           Generics.Deriving.Base (Generic)++-- | An Authentication request.+data AuthInfo = AuthInfo {+  _clientID       :: String+  , _clientSecret :: String+  , _email        :: String+  , _password     :: String+  , _bearerToken  :: String+  } deriving(Show)++makeLenses ''AuthInfo++-- | Get an AuthInfo instance from a bearer token.+fromToken :: String -> AuthInfo+fromToken t = AuthInfo{_bearerToken=t, _clientID="", _clientSecret="", _email="", _password=""}++jsonOpts :: Data.Aeson.Options+jsonOpts = defaultOptions {+  fieldLabelModifier = dropWhile (== '_')+  }++-- | An Authentication response.+data AuthResponse = AuthResponse {+  _access_token    :: String+  , _expires_in    :: Int+  , _refresh_token :: String+  } deriving(Generic, Show)++makeLenses ''AuthResponse++-- | A Monad may have a 'HasTeslaAuth' instance to indicate it knows+-- how to authenticate against the Tesla service.+class Monad m => HasTeslaAuth m where+  teslaAuth :: m AuthInfo++instance FromJSON AuthResponse where+  parseJSON = genericParseJSON jsonOpts

@@ -5,13 +5,18 @@ Access of car-specific APIs. -} -{-# LANGUAGE DeriveGeneric          #-}-{-# LANGUAGE DuplicateRecordFields  #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses  #-}-{-# LANGUAGE OverloadedStrings      #-}-{-# LANGUAGE RecordWildCards        #-}-{-# LANGUAGE TemplateHaskell        #-}+{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE DuplicateRecordFields      #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE FunctionalDependencies     #-}+{-# LANGUAGE GeneralisedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE UndecidableInstances       #-}  module Tesla.Car (   -- * Car Monad and related types.@@ -21,7 +26,7 @@   vehicleData, nearbyChargers,   -- * Convenience functions for examining VehicleData   VehicleData, isUserPresent, isCharging, teslaTS, maybeTeslaTS,-  Door(..), OpenState(..), doors, openDoors,+  Door(..), OpenState(..), _Open, _Closed, doors, openDoors,   -- * Charger Info   Location(..), DestinationCharger(..), Supercharger(..), Charger(..),   superchargers, destinationChargers,@@ -29,60 +34,68 @@   lat, lon, _SC, _DC,   name, location, distance_miles, available_stalls, total_stalls, site_closed,   -- * Probably uninteresting internals-  vehicleURL, authInfo, vehicleID+  vehicleURL, currentVehicleID       ) where -import           Control.Exception      (Exception, throwIO)+import           Control.Exception       (Exception, throwIO) import           Control.Lens-import           Control.Monad          ((<=<))-import           Control.Monad.IO.Class (MonadIO (..))-import           Control.Monad.Reader   (ReaderT (..), asks, runReaderT)-import           Data.Aeson             (FromJSON (..), Options (..),-                                         Result (..), Value (..), decode,-                                         defaultOptions, fieldLabelModifier,-                                         fromJSON, genericParseJSON, withObject,-                                         (.:))-import           Data.Aeson.Lens        (key, _Array, _Bool, _Integer)-import qualified Data.ByteString.Lazy   as BL-import qualified Data.Map.Strict        as Map-import           Data.Maybe             (fromJust, fromMaybe)+import           Control.Monad           ((<=<))+import           Control.Monad.Catch     (MonadCatch (..), MonadMask (..), MonadThrow (..))+import           Control.Monad.Fail      (MonadFail (..))+import           Control.Monad.IO.Class  (MonadIO (..))+import           Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO)+import           Control.Monad.Logger    (MonadLogger)+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 qualified Data.ByteString.Lazy    as BL+import qualified Data.Map.Strict         as Map+import           Data.Maybe              (fromJust, fromMaybe) import           Data.Ratio-import           Data.Text              (Text, unpack)-import           Data.Time.Clock        (UTCTime)-import           Data.Time.Clock.POSIX  (posixSecondsToUTCTime)-import qualified Data.Vector            as V-import           Generics.Deriving.Base (Generic)-import           Network.Wreq           (Response, asJSON, getWith,-                                         responseBody)+import           Data.Text               (Text, unpack)+import           Data.Time.Clock         (UTCTime)+import           Data.Time.Clock.POSIX   (posixSecondsToUTCTime)+import           Generics.Deriving.Base  (Generic)+import           Network.Wreq            (getWith, responseBody)  import           Tesla+import           Tesla.Auth+import           Tesla.Internal.HTTP  -- | Get the URL for a named endpoint for a given vehicle. vehicleURL :: VehicleID -> String -> String vehicleURL v c = mconcat [baseURL, "api/1/vehicles/", unpack v, "/", c] --- | A VehicleID.-type VehicleID = Text- data CarEnv = CarEnv {   _authInfo :: IO AuthInfo,   _vid      :: VehicleID   } --- | Get authInfo from the Car Monad.-authInfo :: MonadIO m => Car m AuthInfo-authInfo = liftIO =<< asks _authInfo- -- | Get the current vehicle ID from the Car Monad.-vehicleID :: Monad m => Car m VehicleID-vehicleID = asks _vid+currentVehicleID :: MonadReader CarEnv m => m VehicleID+currentVehicleID = asks _vid  -- | Car Monad for accessing car-specific things.-type Car = ReaderT CarEnv+newtype Car m a = Car { runCarM :: ReaderT CarEnv m a }+  deriving (Applicative, Functor, Monad, MonadIO,+            MonadCatch, MonadThrow, MonadMask, MonadReader CarEnv,+            MonadFail, MonadLogger) +{- solonarv's thing almost works:+deriving newtype instance (MonadUnliftIO m, forall a a'. Coercible a a' => Coercible (m a) (m a')) => MonadUnliftIO (Car m)+-}++instance MonadUnliftIO m => MonadUnliftIO (Car m) where+  -- ((forall a. m a -> IO a) -> IO b) -> m b+  withRunInIO inner = Car $ withRunInIO $ \run -> inner (run . runCarM)++instance (Monad m, MonadIO m, MonadReader CarEnv m) => HasTeslaAuth m where+  teslaAuth = liftIO =<< asks _authInfo+ -- | Run a Car Monad with the given Vehicle ID runCar :: MonadIO m => IO AuthInfo -> VehicleID -> Car m a -> m a-runCar ai vi f = runReaderT f (CarEnv ai vi)+runCar ai vi f = runReaderT (runCarM f) (CarEnv ai vi)  newtype BadCarException = BadCar String deriving Eq @@ -116,8 +129,8 @@ -- | Fetch the VehicleData. vehicleData :: MonadIO m => Car m VehicleData vehicleData = do-  a <- authInfo-  v <- vehicleID+  a <- teslaAuth+  v <- currentVehicleID   r <- liftIO $ getWith (authOpts a) (vehicleURL v "vehicle_data")   pure . fromJust . inner $ r ^. responseBody     where inner = BL.stripPrefix "{\"response\":" <=< BL.stripSuffix "}"@@ -128,19 +141,16 @@  -- | True if a user is present in the vehicle. isUserPresent :: VehicleData -> Bool-isUserPresent b = let mb = maybeVal b ^? _Just . key "vehicle_state" . key "is_user_present" . _Bool in-                    fromMaybe False mb+isUserPresent = fromMaybe False . preview (_Just . key "vehicle_state" . key "is_user_present" . _Bool) . maybeVal  -- | True of the vehicle is currently charging. isCharging :: VehicleData -> Bool-isCharging b = let mi = maybeVal b ^? _Just . key "charge_state" . key "charger_power" . _Integer in-                 fromMaybe 0 mi > 0+isCharging = maybe False (> 0) . preview (_Just . key "charge_state" . key "charger_power" . _Integer) . maybeVal  -- | Get the timestamp from this VehicleData if present. maybeTeslaTS :: VehicleData -> Maybe UTCTime-maybeTeslaTS b = pt <$> mv-  where mv = maybeVal b ^? _Just . key "vehicle_state" . key "timestamp" . _Integer-        pt x = posixSecondsToUTCTime . fromRational $ x % 1000+maybeTeslaTS b = maybeVal b ^? _Just . key "vehicle_state" . key "timestamp" . _Integer . to pt+  where pt x = posixSecondsToUTCTime . fromRational $ x % 1000  -- | Get the timestamp from this VehicleData or error if there isn't one. teslaTS :: VehicleData -> UTCTime@@ -164,15 +174,7 @@ -- 0 or 32 for rt data OpenState a = Closed a | Open a deriving (Show, Eq) --- | True if the given OpenState represents an open door.-isOpen :: OpenState a -> Bool-isOpen (Closed _) = False-isOpen _          = True---- | Return the thing that is open in this OpenState.-fromOpenState :: OpenState a -> a-fromOpenState (Open d)   = d-fromOpenState (Closed d) = d+makePrisms ''OpenState  -- | Return a list of doors and their OpenState. doors :: VehicleData -> Maybe [OpenState Door]@@ -184,7 +186,7 @@  -- | Return a list of open doors. openDoors :: VehicleData -> [Door]-openDoors b = maybe [] (map fromOpenState . filter isOpen) (doors b)+openDoors = toListOf (_Just . folded . _Open) . doors  -- | Location, Location, Location. data Location = Location { _lat :: Double, _lon :: Double } deriving (Show, Generic)@@ -242,15 +244,13 @@ -- | Get the nearby chargers. nearbyChargers :: MonadIO m => Car m [Charger] nearbyChargers = do-  a <- authInfo-  v <- vehicleID-  r <- liftIO (asJSON =<< getWith (authOpts a) (vehicleURL v "nearby_charging_sites") :: IO (Response Value))-  let rb = r ^. responseBody-      chargers = parseOne rb SC "superchargers" <> parseOne rb DC "destination_charging"-  pure (V.toList chargers)+  v <- currentVehicleID+  rb <- jgetAuth (vehicleURL v "nearby_charging_sites")+  pure $ parseOne rb SC "superchargers" <> parseOne rb DC "destination_charging"      where-      parseOne rb f k =  let rs = traverse fromJSON (rb ^. key "response" . key k . _Array) in+      parseOne :: FromJSON a => Value -> (a -> Charger) -> Text -> [Charger]+      parseOne rb f k =  let rs = traverse fromJSON (rb ^.. key "response" . key k . values) in                            f <$> case rs of                                    Error e   -> error e                                    Success s -> s

@@ -0,0 +1,83 @@+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-|+Module      : Tesla.Car.Command+Description : Commands executed on a car.++Executing commands within the Car Monad.+-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Tesla.Car.Command (+  runCmd, runCmd', CommandResponse, Car,+  -- * TH support for generating commands.+  mkCommand, mkCommands, mkNamedCommands) where++import           Control.Lens+import           Control.Monad.IO.Class (MonadIO (..))+import           Data.Aeson+import           Data.Aeson.Lens        (key, _Bool, _String)+import qualified Data.ByteString.Lazy   as BL+import           Data.Text              (Text)+import           Language.Haskell.TH+import           Network.Wreq.Types     (FormValue (..), Postable)+import           Text.Casing            (fromSnake, toCamel)++import           Tesla.Car+import           Tesla.Internal.HTTP++-- | A CommandResponse wraps an Either such that Left represents a+-- failure message and Right suggests the command was successful.+type CommandResponse = Either Text ()++-- | Run a command with a payload.+runCmd :: (MonadIO m, Postable p) => String -> p -> Car m CommandResponse+runCmd cmd p = do+  v <- currentVehicleID+  j :: Value <- jpostAuth (vehicleURL v $ "command/" <> cmd) p+  pure $ case j ^? key "response" . key "result" . _Bool of+    Just True -> Right ()+    _         -> Left $ j ^. key "response" . key "reason" . _String++-- | Run command without a payload+runCmd' :: MonadIO m => String -> Car m CommandResponse+runCmd' cmd = runCmd cmd BL.empty++instance FormValue Bool where+  renderFormValue True  = "true"+  renderFormValue False = "false"++-- | Build a simple named command car that posts to the given named endpoint.+mkCommand :: String -> String -> Q [Dec]+mkCommand s u = do+  let m = mkName "m"+  pure [+    SigD (mkName s) (ForallT [PlainTV m] [AppT (ConT (mkName "MonadIO")) (VarT m)]+                     (AppT (AppT (ConT (mkName "Car")) (VarT m)) (ConT (mkName "CommandResponse")))),+    FunD (mkName s) [Clause [] (NormalB expr) []]]+  where expr = LamE [] (AppE (VarE (mkName "runCmd'")) (LitE (StringL u)))++cmapM :: (Monoid b, Applicative f) => (a -> f b) -> [a] -> f b+cmapM f xs = mconcat <$> traverse f xs++-- | Build a bunch of commands from a list of named endpoints, defining+-- functions by removing the common prefix.+mkCommands :: [String] -> Q [Dec]+mkCommands targets = cmapM easyCMD targets+  where+    prefix = commonPrefix targets+    easyCMD :: String -> Q [Dec]+    easyCMD target = do+      let s = drop (length prefix) target+          mn = (toCamel . fromSnake) s+      mkCommand mn target++    commonPrefix = fmap head . takeWhile (\(x:xs) -> all (== x) xs) . tp+      where+        tp xs+          | any null xs = []+          | otherwise = (head <$> xs) : tp (tail <$> xs)++-- | Make commands with given names.+mkNamedCommands :: [(String, String)] -> Q [Dec]+mkNamedCommands = cmapM (uncurry mkCommand)

@@ -0,0 +1,11 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}++module Tesla.Car.Command.Alerts (+  honkHorn, flashLights+  ) where++import           Control.Monad.IO.Class (MonadIO (..))+import           Tesla.Car.Command++mkCommands ["honk_horn", "flash_lights"]

@@ -0,0 +1,19 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}++module Tesla.Car.Command.Charging (+  startCharging, stopCharging, setLimit, openChargePort, closeChargePort+  ) where++import           Control.Monad.IO.Class (MonadIO (..))+import           Network.Wreq           (FormParam (..))++import           Tesla.Car.Command++setLimit :: MonadIO m => Int -> Car m CommandResponse+setLimit to = runCmd "set_charge_limit" ["percent" := to ]++mkNamedCommands [("startCharging", "charge_start"),+                 ("stopCharging", "charge_stop"),+                 ("openChargePort", "charge_port_door_open"),+                 ("closeChargePort", "charge_port_door_close")]

@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}++module Tesla.Car.Command.Climate (+  hvacOn, hvacOff, heatSeat, Seat(..),+  setTemps, wheelHeater, wheelHeaterOff, wheelHeaterOn,+  wakeUp+  ) where++import           Control.Monad.IO.Class (MonadIO (..))+import           Network.Wreq           (FormParam (..))++import           Tesla.Car.Command++-- | Turn on the steering wheel heater+wheelHeater :: MonadIO m => Bool -> Car m CommandResponse+wheelHeater on = runCmd "remote_steering_wheel_heater_request" ["on" := on]++wheelHeaterOn :: MonadIO m => Car m CommandResponse+wheelHeaterOn = wheelHeater True++wheelHeaterOff :: MonadIO m => Car m CommandResponse+wheelHeaterOff = wheelHeater False++data Seat = DriverSeat | PassengerSeat | RearLeftSeat | RearCenterSeat | RearRightSeat++-- | Set heating levels for various seats.+heatSeat :: MonadIO m => Seat -> Int -> Car m CommandResponse+heatSeat seat level = runCmd "remote_seat_heater_request" ["heater" := seatNum seat, "level" := level]+  where+    seatNum :: Seat -> Int+    seatNum DriverSeat     = 0+    seatNum PassengerSeat  = 1+    seatNum RearLeftSeat   = 2+    seatNum RearCenterSeat = 4+    seatNum RearRightSeat  = 5++-- | Set the main HVAC temperatures.+setTemps :: MonadIO m => (Double, Double) -> Car m CommandResponse+setTemps (driver, passenger) = runCmd "set_temps" ["driver_temp" := driver, "passenger_temp" := passenger]+++mkNamedCommands [("hvacOn", "auto_conditioning_start"),+                 ("hvacOff", "auto_conditioning_stop"),+                 ("wakeUp", "wake_up")]+

@@ -0,0 +1,23 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}++module Tesla.Car.Command.Doors (+  actuateFrontTrunk, actuateRearTrunk,+  lockDoors, unlockDoors+  ) where++import           Control.Monad.IO.Class (MonadIO (..))+import           Network.Wreq           (FormParam (..))+import           Tesla.Car.Command++atr :: MonadIO m => String -> Car m CommandResponse+atr w = runCmd "actuate_trunk" [ "which_trunk" := w ]++actuateFrontTrunk :: MonadIO m => Car m CommandResponse+actuateFrontTrunk = atr "front"++actuateRearTrunk :: MonadIO m => Car m CommandResponse+actuateRearTrunk = atr "rear"++mkNamedCommands [("lockDoors", "door_lock"),+                 ("unlockDoors", "door_unlock")]

@@ -0,0 +1,11 @@+{-# LANGUAGE OverloadedStrings #-}++module Tesla.Car.Command.Homelink (trigger) where++import           Control.Monad.IO.Class (MonadIO (..))+import           Network.Wreq           (FormParam (..))+import           Tesla.Car.Command++-- | Trigger nearby homelink with the given (lat,lon)+trigger :: MonadIO m => (Double, Double) -> Car m CommandResponse+trigger (lat,lon) = runCmd "flash_lights" ["lat" := lat, "lon" := lon]

@@ -0,0 +1,18 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}++module Tesla.Car.Command.Media where++import           Control.Monad.IO.Class (MonadIO (..))++import           Tesla.Car.Command++mkCommands [+  "media_toggle_playback",+  "media_next_track",+  "media_prev_track",+  "media_next_fav",+  "media_prev_fav",+  "media_volume_up",+  "media_volume_down"+  ]

@@ -0,0 +1,14 @@+{-# LANGUAGE OverloadedStrings #-}++module Tesla.Car.Command.RemoteStart where++import           Control.Monad.IO.Class (MonadIO (..))+import           Network.Wreq           (FormParam (..))++import           Tesla.Car.Command++-- | Enables keyless driving.+--+-- This requires your account password, so, you know, be careful where you use it.+remoteStart :: MonadIO m => String -> Car m CommandResponse+remoteStart pw = runCmd "remote_start_drive" ["password" := pw]

@@ -0,0 +1,13 @@+{-# LANGUAGE OverloadedStrings #-}++module Tesla.Car.Command.Sentry (+  setSentryMode+  ) where++import           Control.Monad.IO.Class (MonadIO (..))+import           Network.Wreq           (FormParam (..))++import           Tesla.Car.Command++setSentryMode :: MonadIO m => Bool -> Car m CommandResponse+setSentryMode on = runCmd "set_sentry_mode" [ "on" := on ]

@@ -0,0 +1,20 @@+{-# LANGUAGE OverloadedStrings #-}++module Tesla.Car.Command.Sharing (share) where++import           Control.Monad.IO.Class (MonadIO (..))+import           Data.Aeson+import           Data.Text              (Text)+import           Data.Time.Clock.POSIX  (getCurrentTime, utcTimeToPOSIXSeconds)++import           Tesla.Car.Command++share :: MonadIO m => Text -> Car m CommandResponse+share to = do+  now <- fst . properFraction . utcTimeToPOSIXSeconds <$> liftIO getCurrentTime+  runCmd "share" $ object [+    "type" .= ("share_ext_content_raw" :: Text),+    "value" .= object [ "android.intent.extra.TEXT" .= to ],+    "locale" .= ("en-US" :: Text),+    "timestamp_ms" .= (now * (1000::Int))+    ]

@@ -0,0 +1,19 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}++module Tesla.Car.Command.Software (+  scheduleUpdate, cancelUpdate+  ) where++import           Control.Monad.IO.Class (MonadIO (..))+import           Network.Wreq           (FormParam (..))++import           Tesla.Car.Command++-- | Schedule a software update in this many seconds.+scheduleUpdate :: MonadIO m => Int -> Car m CommandResponse+scheduleUpdate secs = runCmd "schedule_software_update" ["offset_sec" := secs]++-- | Cancel a scheduled software update.+mkCommand "cancelUpdate" "cancel_software_update"+

@@ -0,0 +1,24 @@+{-# LANGUAGE OverloadedStrings #-}++module Tesla.Car.Command.SpeedLimit (+  speedLimit, activateSpeedLimit, deactivateSpeedLimit, clearSpeedLimitPIN+  ) where++import           Control.Monad.IO.Class (MonadIO (..))+import           Network.Wreq           (FormParam (..))+import           Tesla.Car.Command++speedLimit :: MonadIO m => Int -> Car m CommandResponse+speedLimit to = runCmd "speed_limit_set_limit" ["limit_mph" := to ]++speedo :: MonadIO m => String -> Int -> Car m CommandResponse+speedo c pin = runCmd c ["pin" := pin ]++activateSpeedLimit :: MonadIO m => Int -> Car m CommandResponse+activateSpeedLimit = speedo "speed_limit_activate"++deactivateSpeedLimit :: MonadIO m => Int -> Car m CommandResponse+deactivateSpeedLimit = speedo "speed_limit_deactivate"++clearSpeedLimitPIN :: MonadIO m => Int -> Car m CommandResponse+clearSpeedLimitPIN = speedo "speed_limit_clear_pin"

@@ -0,0 +1,16 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell   #-}++module Tesla.Car.Command.Valet (+  setValetMode, clearValetPIN+  ) where++import           Control.Monad.IO.Class (MonadIO (..))+import           Network.Wreq           (FormParam (..))++import           Tesla.Car.Command++setValetMode :: MonadIO m => Bool -> Int -> Car m CommandResponse+setValetMode on pin = runCmd "set_valet_mode" [ "on" := on, "password" := pin]++mkCommand "clearValetPIN" "reset_valet_pin"

@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}++module Tesla.Car.Command.Windows (+  ventWindows, closeWindows, ventSunroof, closeSunroof+  ) where++import           Control.Monad.IO.Class (MonadIO (..))+import           Data.Text              (Text)+import           Network.Wreq           (FormParam (..))++import           Tesla.Car.Command++windowControl :: MonadIO m => Text -> (Double, Double) -> Car m CommandResponse+windowControl x (lat,lon) = runCmd "window_control" [ "command" := x, "lat" := lat, "lon" := lon]++ventWindows :: MonadIO m => Car m CommandResponse+ventWindows = windowControl "vent" (0,0)++closeWindows :: MonadIO m => (Double, Double) -> Car m CommandResponse+closeWindows = windowControl "close"++sc :: MonadIO m => Text -> Car m CommandResponse+sc c = runCmd "sun_roof_control" [ "state" := c ]++ventSunroof :: MonadIO m => Car m CommandResponse+ventSunroof = sc "vent"++closeSunroof :: MonadIO m => Car m CommandResponse+closeSunroof = sc "close"

@@ -0,0 +1,25 @@+{-|+Module:      Tesla.Commands+Description: Convenience module for importing all commands at once.++All of the commands supported by this library.++This is meant to be imported qualified, e.g.:++> import qualified Tesla.Commands as CMD+-}++module Tesla.Car.Commands ( module CMD ) where++import           Tesla.Car.Command.Alerts     as CMD+import           Tesla.Car.Command.Charging   as CMD+import           Tesla.Car.Command.Climate    as CMD+import           Tesla.Car.Command.Doors      as CMD+import           Tesla.Car.Command.Homelink   as CMD+import           Tesla.Car.Command.Media      as CMD+import           Tesla.Car.Command.Sentry     as CMD+import           Tesla.Car.Command.Sharing    as CMD+import           Tesla.Car.Command.Software   as CMD+import           Tesla.Car.Command.SpeedLimit as CMD+import           Tesla.Car.Command.Valet      as CMD+import           Tesla.Car.Command.Windows    as CMD

@@ -1,87 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-|-Module      : Tesla.Command-Description : Commands executed on a car.--Executing commands within the Car Monad.--}-{-# OPTIONS_GHC -Wno-orphans #-}--module Tesla.Command (-  runCmd, runCmd', CommandResponse, Car,-  -- * TH support for generating commands.-  mkCommand, mkCommands, mkNamedCommands) where--import           Control.Lens-import           Control.Monad.IO.Class (MonadIO (..))-import           Data.Aeson-import           Data.Aeson.Lens        (key, _Bool, _String)-import qualified Data.ByteString.Lazy   as BL-import           Data.Text              (Text)-import           Language.Haskell.TH-import           Network.Wreq           (Response, asJSON, postWith,-                                         responseBody)-import           Network.Wreq.Types     (FormValue (..), Postable)-import           Text.Casing            (fromSnake, toCamel)---import           Tesla-import           Tesla.Car---- | A CommandResponse wraps an Either such that Left represents a--- failure message and Right suggests the command was successful.-type CommandResponse = Either Text ()---- | Run a command with a payload.-runCmd :: (MonadIO m, Postable p) => String -> p -> Car m CommandResponse-runCmd cmd p = do-  a <- authInfo-  v <- vehicleID-  r <- liftIO (asJSON =<< postWith (authOpts a) (vehicleURL v $ "command/" <> cmd) p :: IO (Response Value))-  pure $ case r ^? responseBody . key "response" . key "result" . _Bool of-    Just True  -> Right ()-    _ -> Left $ r ^. responseBody . key "response" . key "reason" . _String---- | Run command without a payload-runCmd' :: MonadIO m => String -> Car m CommandResponse-runCmd' cmd = runCmd cmd BL.empty--instance FormValue Bool where-  renderFormValue True  = "true"-  renderFormValue False = "false"----- | Build a simple named command car that posts to the given named endpoint.-mkCommand :: String -> String -> Q [Dec]-mkCommand s u = do-  let m = mkName "m"-  pure $ [-    SigD (mkName s) (ForallT [PlainTV m] [AppT (ConT (mkName "MonadIO")) (VarT m)]-                     (AppT (AppT (ConT (mkName "Car")) (VarT m)) (ConT (mkName "CommandResponse")))),-    FunD (mkName s) [Clause [] (NormalB expr) []]]-  where expr = LamE [] (AppE (VarE (mkName "runCmd'")) (LitE (StringL u)))--cmapM :: (Monoid b, Applicative f) => (a -> f b) -> [a] -> f b-cmapM f xs = mconcat <$> traverse f xs---- | Build a bunch of commands from a list of named endpoints, defining--- functions by removing the common prefix.-mkCommands :: [String] -> Q [Dec]-mkCommands targets = cmapM easyCMD targets-  where-    prefix = commonPrefix targets-    easyCMD :: String -> Q [Dec]-    easyCMD target = do-      let s = drop (length prefix) target-          mn = (toCamel . fromSnake) s-      mkCommand mn target--    commonPrefix = fmap head . takeWhile (\(x:xs) -> all (== x) xs) . tp-      where-        tp xs-          | any null xs = []-          | otherwise = (head <$> xs) : tp (tail <$> xs)---- Make commands with given names.-mkNamedCommands :: [(String, String)] -> Q [Dec]-mkNamedCommands = cmapM (uncurry mkCommand)

@@ -1,11 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell   #-}--module Tesla.Command.Alerts (-  honkHorn, flashLights-  ) where--import           Control.Monad.IO.Class (MonadIO (..))-import           Tesla.Command--mkCommands ["honk_horn", "flash_lights"]

@@ -1,19 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell   #-}--module Tesla.Command.Charging (-  startCharging, stopCharging, setLimit, openChargePort, closeChargePort-  ) where--import           Control.Monad.IO.Class (MonadIO (..))-import           Network.Wreq           (FormParam (..))--import           Tesla.Command--setLimit :: MonadIO m => Int -> Car m CommandResponse-setLimit to = runCmd "set_charge_limit" ["percent" := to ]--mkNamedCommands [("startCharging", "charge_start"),-                 ("stopCharging", "charge_stop"),-                 ("openChargePort", "charge_port_door_open"),-                 ("closeChargePort", "charge_port_door_close")]

@@ -1,46 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell   #-}--module Tesla.Command.Climate (-  hvacOn, hvacOff, heatSeat, Seat(..),-  setTemps, wheelHeater, wheelHeaterOff, wheelHeaterOn,-  wakeUp-  ) where--import           Control.Monad.IO.Class (MonadIO (..))-import           Network.Wreq           (FormParam (..))--import           Tesla.Command---- | Turn on the steering wheel heater-wheelHeater :: MonadIO m => Bool -> Car m CommandResponse-wheelHeater on = runCmd "remote_steering_wheel_heater_request" ["on" := on]--wheelHeaterOn :: MonadIO m => Car m CommandResponse-wheelHeaterOn = wheelHeater True--wheelHeaterOff :: MonadIO m => Car m CommandResponse-wheelHeaterOff = wheelHeater False--data Seat = DriverSeat | PassengerSeat | RearLeftSeat | RearCenterSeat | RearRightSeat---- | Set heating levels for various seats.-heatSeat :: MonadIO m => Seat -> Int -> Car m CommandResponse-heatSeat seat level = runCmd "remote_seat_heater_request" ["heater" := seatNum seat, "level" := level]-  where-    seatNum :: Seat -> Int-    seatNum DriverSeat     = 0-    seatNum PassengerSeat  = 1-    seatNum RearLeftSeat   = 2-    seatNum RearCenterSeat = 4-    seatNum RearRightSeat  = 5---- | Set the main HVAC temperatures.-setTemps :: MonadIO m => (Double, Double) -> Car m CommandResponse-setTemps (driver, passenger) = runCmd "set_temps" ["driver_temp" := driver, "passenger_temp" := passenger]---mkNamedCommands [("hvacOn", "auto_conditioning_start"),-                 ("hvacOff", "auto_conditioning_stop"),-                 ("wakeUp", "wake_up")]-

@@ -1,18 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Tesla.Command.Doors (-  actuateFrontTrunk, actuateRearTrunk-  ) where--import           Control.Monad.IO.Class (MonadIO (..))-import           Network.Wreq           (FormParam (..))-import           Tesla.Command--atr :: MonadIO m => String -> Car m CommandResponse-atr w = runCmd "actuate_trunk" [ "which_trunk" := w ]--actuateFrontTrunk :: MonadIO m => Car m CommandResponse-actuateFrontTrunk = atr "front"--actuateRearTrunk :: MonadIO m => Car m CommandResponse-actuateRearTrunk = atr "rear"

@@ -1,11 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Tesla.Command.Homelink (trigger) where--import           Control.Monad.IO.Class (MonadIO (..))-import           Network.Wreq           (FormParam (..))-import           Tesla.Command---- | Trigger nearby homelink with the given (lat,lon)-trigger :: MonadIO m => (Double, Double) -> Car m CommandResponse-trigger (lat,lon) = runCmd "flash_lights" ["lat" := lat, "lon" := lon]

@@ -1,18 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell   #-}--module Tesla.Command.Media where--import           Control.Monad.IO.Class (MonadIO (..))--import           Tesla.Command--mkCommands [-  "media_toggle_playback",-  "media_next_track",-  "media_prev_track",-  "media_next_fav",-  "media_prev_fav",-  "media_volume_up",-  "media_volume_down"-  ]

@@ -1,14 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Tesla.Command.RemoteStart where--import           Control.Monad.IO.Class (MonadIO (..))-import           Network.Wreq           (FormParam (..))--import           Tesla.Command---- | Enables keyless driving.------ This requires your account password, so, you know, be careful where you use it.-remoteStart :: MonadIO m => String -> Car m CommandResponse-remoteStart pw = runCmd "remote_start_drive" ["password" := pw]

@@ -1,12 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Tesla.Command.Sentry (-  setSentryMode-  ) where--import           Control.Monad.IO.Class (MonadIO (..))-import           Network.Wreq           (FormParam (..))-import           Tesla.Command--setSentryMode :: MonadIO m => Bool -> Car m CommandResponse-setSentryMode on = runCmd "set_sentry_mode" [ "on" := on ]

@@ -1,20 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Tesla.Command.Sharing (share) where--import           Control.Monad.IO.Class (MonadIO (..))-import           Data.Aeson-import           Data.Text              (Text)-import           Data.Time.Clock.POSIX  (getCurrentTime, utcTimeToPOSIXSeconds)--import           Tesla.Command--share :: MonadIO m => Text -> Car m CommandResponse-share to = do-  now <- fst . properFraction . utcTimeToPOSIXSeconds <$> liftIO getCurrentTime-  runCmd "share" $ object [-    "type" .= ("share_ext_content_raw" :: Text),-    "value" .= object [ "android.intent.extra.TEXT" .= to ],-    "locale" .= ("en-US" :: Text),-    "timestamp_ms" .= (now * (1000::Int))-    ]

@@ -1,19 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell   #-}--module Tesla.Command.Software (-  scheduleUpdate, cancelUpdate-  ) where--import           Control.Monad.IO.Class (MonadIO (..))-import           Network.Wreq           (FormParam (..))--import           Tesla.Command---- | Schedule a software update in this many seconds.-scheduleUpdate :: MonadIO m => Int -> Car m CommandResponse-scheduleUpdate secs = runCmd "schedule_software_update" ["offset_sec" := secs]---- | Cancel a scheduled software update.-mkCommand "cancelUpdate" "cancel_software_update"-

@@ -1,24 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Tesla.Command.SpeedLimit (-  speedLimit, activateSpeedLimit, deactivateSpeedLimit, clearSpeedLimitPIN-  ) where--import           Control.Monad.IO.Class (MonadIO (..))-import           Network.Wreq           (FormParam (..))-import           Tesla.Command--speedLimit :: MonadIO m => Int -> Car m CommandResponse-speedLimit to = runCmd "speed_limit_set_limit" ["limit_mph" := to ]--speedo :: MonadIO m => String -> Int -> Car m CommandResponse-speedo c pin = runCmd c ["pin" := pin ]--activateSpeedLimit :: MonadIO m => Int -> Car m CommandResponse-activateSpeedLimit = speedo "speed_limit_activate"--deactivateSpeedLimit :: MonadIO m => Int -> Car m CommandResponse-deactivateSpeedLimit = speedo "speed_limit_deactivate"--clearSpeedLimitPIN :: MonadIO m => Int -> Car m CommandResponse-clearSpeedLimitPIN = speedo "speed_limit_clear_pin"

@@ -1,15 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell   #-}--module Tesla.Command.Valet (-  setValetMode, clearValetPIN-  ) where--import           Control.Monad.IO.Class (MonadIO (..))-import           Network.Wreq           (FormParam (..))-import           Tesla.Command--setValetMode :: MonadIO m => Bool -> Int -> Car m CommandResponse-setValetMode on pin = runCmd "set_valet_mode" [ "on" := on, "password" := pin]--mkCommand "clearValetPIN" "reset_valet_pin"

@@ -1,28 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Tesla.Command.Windows (-  ventWindows, closeWindows, ventSunroof, closeSunroof-  ) where--import           Control.Monad.IO.Class (MonadIO (..))-import           Data.Text              (Text)-import           Network.Wreq           (FormParam (..))-import           Tesla.Command--windowControl :: MonadIO m => Text -> (Double, Double) -> Car m CommandResponse-windowControl x (lat,lon) = runCmd "window_control" [ "command" := x, "lat" := lat, "lon" := lon]--ventWindows :: MonadIO m => Car m CommandResponse-ventWindows = windowControl "vent" (0,0)--closeWindows :: MonadIO m => (Double, Double) -> Car m CommandResponse-closeWindows = windowControl "close"--sc :: MonadIO m => Text -> Car m CommandResponse-sc c = runCmd "sun_roof_control" [ "state" := c ]--ventSunroof :: MonadIO m => Car m CommandResponse-ventSunroof = sc "vent"--closeSunroof :: MonadIO m => Car m CommandResponse-closeSunroof = sc "close"

@@ -1,25 +0,0 @@-{-|-Module:      Tesla.Commands-Description: Convenience module for importing all commands at once.--All of the commands supported by this library.--This is meant to be imported qualified, e.g.:--> import qualified Tesla.Commands as CMD--}--module Tesla.Commands ( module CMD ) where--import           Tesla.Command.Alerts     as CMD-import           Tesla.Command.Charging   as CMD-import           Tesla.Command.Climate    as CMD-import           Tesla.Command.Doors      as CMD-import           Tesla.Command.Homelink   as CMD-import           Tesla.Command.Media      as CMD-import           Tesla.Command.Sentry     as CMD-import           Tesla.Command.Sharing    as CMD-import           Tesla.Command.Software   as CMD-import           Tesla.Command.SpeedLimit as CMD-import           Tesla.Command.Valet      as CMD-import           Tesla.Command.Windows    as CMD

@@ -0,0 +1,84 @@+{-|+Module:      Tesla.Energy+Description: Tesla energy-specific APIs.++Access of energy-specific APIs.+-}++{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE DuplicateRecordFields      #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralisedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE UndecidableInstances       #-}++module Tesla.Energy (+  runEnergy, siteData, siteConfig, Energy+  ) where++import           Control.Exception       (Exception)+import           Control.Monad.Catch     (MonadCatch (..), MonadMask (..), MonadThrow (..))+import           Control.Monad.Fail      (MonadFail (..))+import           Control.Monad.IO.Class  (MonadIO (..))+import           Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO)+import           Control.Monad.Logger    (MonadLogger)+import           Control.Monad.Reader    (MonadReader, ReaderT (..), asks, runReaderT)+import           Data.Aeson              (FromJSON (..))++import           Tesla+import           Tesla.Auth+import           Tesla.Internal.HTTP++-- | Get the URL for a named endpoint for a given vehicle.+energyURL :: EnergyID -> String -> String+energyURL v c = mconcat [baseURL, "api/1/energy_sites/", show v, "/", c]++data EnergyEnv = EnergyEnv {+  _authInfo :: IO AuthInfo,+  _eid      :: EnergyID+  }++-- | Get the current energy ID from the Energy Monad.+currentEnergyID :: Monad m => Energy m EnergyID+currentEnergyID = asks _eid++-- | Energy Monad for accessing energy-specific things.+newtype Energy m a = Energy { runEnergyM :: ReaderT EnergyEnv m a }+  deriving (Applicative, Functor, Monad, MonadIO,+            MonadCatch, MonadThrow, MonadMask, MonadReader EnergyEnv,+            MonadFail, MonadLogger)++instance MonadUnliftIO m => MonadUnliftIO (Energy m) where+  withRunInIO inner = Energy $ withRunInIO $ \run -> inner (run . runEnergyM)++instance (Monad m, MonadIO m, MonadReader EnergyEnv m) => HasTeslaAuth m where+  teslaAuth = liftIO =<< asks _authInfo++-- | Run a Energy Monad with the given Vehicle ID+runEnergy :: MonadIO m => IO AuthInfo -> EnergyID -> Energy m a -> m a+runEnergy ai ei f = runReaderT (runEnergyM f) (EnergyEnv ai ei)++newtype BadEnergyException = BadEnergy String deriving Eq++instance Show BadEnergyException where+  show (BadEnergy s) = "BadEnergy: " <> s++instance Exception BadEnergyException++{- 404?+siteSummary :: (FromJSON j, MonadIO m) => Energy m j+siteSummary = currentEnergyID >>= \e -> jget (energyURL e "status")+-}++siteData :: (FromJSON j, MonadIO m) => Energy m j+siteData = currentEnergyID >>= \e -> jgetAuth (energyURL e "live_status")++siteConfig :: (FromJSON j, MonadIO m) => Energy m j+siteConfig = currentEnergyID >>= \e -> jgetAuth (energyURL e "site_info")++{- Errors that 'kind' is required.+siteHistory :: (FromJSON j, MonadIO m) => Energy m j+siteHistory = currentEnergyID >>= \e -> jget (energyURL e "history")+-}

@@ -0,0 +1,37 @@+{-# OPTIONS_HADDOCK hide, prune, ignore-exports #-}++module Tesla.Internal.HTTP where++import           Control.Lens+import           Control.Monad.IO.Class (MonadIO (..))+import           Data.Aeson             (FromJSON (..))+import qualified Data.ByteString.Char8  as BC+import           Network.Wreq           (Options, asJSON, defaults, get, getWith, header, postWith, responseBody)+import           Network.Wreq.Types     (Postable)++import           Tesla.Auth++userAgent :: BC.ByteString+userAgent = "github.com/dustin/tesla 0.1"++defOpts :: Options+defOpts = defaults & header "User-Agent" .~ [userAgent]++-- | Get a set of wreq options from an 'AuthInfo'.+authOpts :: AuthInfo -> Options+authOpts AuthInfo{..} = defOpts & header "Authorization" .~ ["Bearer " <> BC.pack _bearerToken]++jget :: (FromJSON j, MonadIO m) => String -> m j+jget u = view responseBody <$> liftIO (asJSON =<< get u)++jgetWith :: (FromJSON j, MonadIO m) => Options -> String -> m j+jgetWith opts u = view responseBody <$> liftIO (asJSON =<< getWith opts u)++jgetAuth :: (HasTeslaAuth m, FromJSON j, MonadIO m) => String -> m j+jgetAuth u = teslaAuth >>= \a -> view responseBody <$> liftIO (asJSON =<< getWith (authOpts a) u)++jpostWith :: (FromJSON j, Postable a, MonadIO m) => Options -> String -> a -> m j+jpostWith opts u v = view responseBody <$> liftIO (postWith opts u v >>= asJSON)++jpostAuth :: (HasTeslaAuth m, FromJSON j, Postable a, MonadIO m) => String -> a -> m j+jpostAuth u v = teslaAuth >>= \a -> jpostWith (authOpts a) u v

@@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2.+-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack ----- hash: bc86432b798b84de1d75a14ba3e27975fe6c0c2431111c061bfcd48bdf851848+-- hash: 8d58aba9e4939289760f458ed52ae77cefb0e80437c28f6672627ef98afe987f  name:           tesla-version:        0.1.0.1+version:        0.2.0.0 synopsis:       Tesla API client. description:    Please see the README on GitHub at <https://github.com/dustin/tesla#readme> category:       Web@@ -30,22 +30,25 @@ library   exposed-modules:       Tesla+      Tesla.Auth       Tesla.Car-      Tesla.Command-      Tesla.Command.Alerts-      Tesla.Command.Charging-      Tesla.Command.Climate-      Tesla.Command.Doors-      Tesla.Command.Homelink-      Tesla.Command.Media-      Tesla.Command.RemoteStart-      Tesla.Command.Sentry-      Tesla.Command.Sharing-      Tesla.Command.Software-      Tesla.Command.SpeedLimit-      Tesla.Command.Valet-      Tesla.Command.Windows-      Tesla.Commands+      Tesla.Car.Command+      Tesla.Car.Command.Alerts+      Tesla.Car.Command.Charging+      Tesla.Car.Command.Climate+      Tesla.Car.Command.Doors+      Tesla.Car.Command.Homelink+      Tesla.Car.Command.Media+      Tesla.Car.Command.RemoteStart+      Tesla.Car.Command.Sentry+      Tesla.Car.Command.Sharing+      Tesla.Car.Command.Software+      Tesla.Car.Command.SpeedLimit+      Tesla.Car.Command.Valet+      Tesla.Car.Command.Windows+      Tesla.Car.Commands+      Tesla.Energy+      Tesla.Internal.HTTP   other-modules:       Paths_tesla   hs-source-dirs:@@ -58,13 +61,16 @@     , bytestring >=0.10 && <0.11     , casing >=0.1.4 && <0.2     , containers >=0.6 && <0.7+    , exceptions     , generic-deriving >=1.12 && <1.14     , lens >=4.17 && <4.19     , lens-aeson >=1.0 && <1.2+    , monad-logger     , mtl >=2.2 && <2.3     , template-haskell >=2.14 && <2.16     , text >=1.2 && <1.3     , time >=1.8 && <1.10+    , unliftio-core     , vector >=0.12.0 && <0.13     , wreq >=0.5 && <0.6   default-language: Haskell2010@@ -85,9 +91,11 @@     , bytestring >=0.10 && <0.11     , casing >=0.1.4 && <0.2     , containers >=0.6 && <0.7+    , exceptions     , generic-deriving >=1.12 && <1.14     , lens >=4.17 && <4.19     , lens-aeson >=1.0 && <1.2+    , monad-logger     , mtl >=2.2 && <2.3     , tasty     , tasty-hunit@@ -96,6 +104,7 @@     , tesla     , text >=1.2 && <1.3     , time >=1.8 && <1.10+    , unliftio-core     , vector >=0.12.0 && <0.13     , wreq >=0.5 && <0.6   default-language: Haskell2010

@@ -4,6 +4,8 @@ import           Test.Tasty.HUnit import           Test.Tasty.QuickCheck as QC +import           Data.Aeson+import           Data.Maybe            (fromJust) import           Data.Ratio import           Data.Time.Clock       (UTCTime) import           Data.Time.Clock.POSIX (posixSecondsToUTCTime)@@ -14,6 +16,9 @@ sampleVehicleData :: VehicleData sampleVehicleData = "{\"id\":484265022836,\"user_id\":872475,\"vehicle_id\":842742,\"vin\":\"5YJXCDE2XHF000001\",\"display_name\":\"Bob\",\"option_codes\":\"AD15,MDL3,PBSB,RENA,BT37,ID3W,RF3G,S3PB,DRLH,DV2W,W39B,APF0,COUS,BC3B,CH07,PC30,FC3P,FG31,GLFR,HL31,HM31,IL31,LTPB,MR31,FM3B,RS3H,SA3P,STCP,SC04,SU3C,T3CA,TW00,TM00,UT3P,WR00,AU3P,APH3,AF00,ZCST,MI00,CDM0\",\"color\":null,\"tokens\":[\"token1\",\"token2\"],\"state\":\"online\",\"in_service\":false,\"id_s\":\"484265022836\",\"calendar_enabled\":true,\"api_version\":6,\"backseat_token\":null,\"backseat_token_updated_at\":null,\"charge_state\":{\"battery_heater_on\":false,\"battery_level\":79,\"battery_range\":225.71,\"charge_current_request\":48,\"charge_current_request_max\":48,\"charge_enable_request\":false,\"charge_energy_added\":0.0,\"charge_limit_soc\":80,\"charge_limit_soc_max\":100,\"charge_limit_soc_min\":50,\"charge_limit_soc_std\":90,\"charge_miles_added_ideal\":0.0,\"charge_miles_added_rated\":0.0,\"charge_port_cold_weather_mode\":null,\"charge_port_door_open\":true,\"charge_port_latch\":\"Engaged\",\"charge_rate\":0.0,\"charge_to_max_range\":false,\"charger_actual_current\":0,\"charger_phases\":null,\"charger_pilot_current\":48,\"charger_power\":13,\"charger_voltage\":0,\"charging_state\":\"Stopped\",\"conn_charge_cable\":\"SAE\",\"est_battery_range\":161.61,\"fast_charger_brand\":\"<invalid>\",\"fast_charger_present\":false,\"fast_charger_type\":\"ACSingleWireCAN\",\"ideal_battery_range\":282.78,\"managed_charging_active\":false,\"managed_charging_start_time\":null,\"managed_charging_user_canceled\":false,\"max_range_charge_counter\":0,\"minutes_to_full_charge\":20,\"not_enough_power_to_heat\":false,\"scheduled_charging_pending\":true,\"scheduled_charging_start_time\":1569738600,\"time_to_full_charge\":0.33,\"timestamp\":1569718275490,\"trip_charging\":false,\"usable_battery_level\":79,\"user_charge_enable_request\":null},\"climate_state\":{\"battery_heater\":false,\"battery_heater_no_power\":false,\"climate_keeper_mode\":\"off\",\"defrost_mode\":0,\"driver_temp_setting\":22.0,\"fan_status\":0,\"inside_temp\":22.3,\"is_auto_conditioning_on\":false,\"is_climate_on\":false,\"is_front_defroster_on\":false,\"is_preconditioning\":false,\"is_rear_defroster_on\":false,\"left_temp_direction\":317,\"max_avail_temp\":28.0,\"min_avail_temp\":15.0,\"outside_temp\":15.5,\"passenger_temp_setting\":22.0,\"remote_heater_control_enabled\":false,\"right_temp_direction\":317,\"seat_heater_left\":0,\"seat_heater_rear_center\":0,\"seat_heater_rear_left\":0,\"seat_heater_rear_right\":0,\"seat_heater_right\":0,\"side_mirror_heaters\":false,\"smart_preconditioning\":false,\"steering_wheel_heater\":false,\"timestamp\":1569718275490,\"wiper_blade_heater\":false},\"drive_state\":{\"gps_as_of\":1569718274,\"heading\":125,\"latitude\":34.13245,\"longitude\":-120.823475,\"native_latitude\":34.13245,\"native_location_supported\":1,\"native_longitude\":-120.823475,\"native_type\":\"wgs\",\"power\":0,\"shift_state\":\"P\",\"speed\":null,\"timestamp\":1569718275490},\"gui_settings\":{\"gui_24_hour_time\":true,\"gui_charge_rate_units\":\"kW\",\"gui_distance_units\":\"mi/hr\",\"gui_range_display\":\"Rated\",\"gui_temperature_units\":\"C\",\"show_range_units\":true,\"timestamp\":1569718275490},\"vehicle_config\":{\"can_accept_navigation_requests\":true,\"can_actuate_trunks\":true,\"car_special_type\":\"base\",\"car_type\":\"modelx\",\"charge_port_type\":\"US\",\"eu_vehicle\":false,\"exterior_color\":\"SteelGrey\",\"has_air_suspension\":true,\"has_ludicrous_mode\":false,\"motorized_charge_port\":true,\"plg\":true,\"rear_seat_heaters\":3,\"rear_seat_type\":4,\"rhd\":false,\"roof_color\":\"None\",\"seat_type\":0,\"spoiler_type\":\"Passive\",\"sun_roof_installed\":0,\"third_row_seats\":\"None\",\"timestamp\":1569718275490,\"trim_badging\":\"100d\",\"use_range_badging\":false,\"wheel_type\":\"AeroTurbine20\"},\"vehicle_state\":{\"api_version\":6,\"autopark_state_v2\":\"standby\",\"autopark_style\":\"standard\",\"calendar_supported\":true,\"car_version\":\"2019.32.11 bac8c51\",\"center_display_state\":0,\"df\":0,\"dr\":0,\"fd_window\":0,\"fp_window\":0,\"ft\":0,\"homelink_device_count\":1,\"homelink_nearby\":false,\"is_user_present\":true,\"last_autopark_error\":\"no_error\",\"locked\":true,\"media_state\":{\"remote_control_enabled\":true},\"notifications_supported\":true,\"odometer\":49081.642123,\"parsed_calendar_supported\":true,\"pf\":0,\"pr\":0,\"rd_window\":0,\"remote_start\":false,\"remote_start_enabled\":true,\"remote_start_supported\":true,\"rp_window\":0,\"rt\":32,\"sentry_mode\":false,\"sentry_mode_available\":true,\"smart_summon_available\":true,\"software_update\":{\"download_perc\":0,\"expected_duration_sec\":2700,\"install_perc\":1,\"status\":\"\",\"version\":\"\"},\"speed_limit_mode\":{\"active\":false,\"current_limit_mph\":80.0,\"max_limit_mph\":90,\"min_limit_mph\":50,\"pin_code_set\":true},\"summon_standby_mode_enabled\":true,\"timestamp\":1569718275489,\"valet_mode\":false,\"vehicle_name\":\"Bob\"}}" +sampleProducts :: Value+sampleProducts = fromJust . decode $ "{\"response\":[{\"backseat_token_updated_at\":null,\"backseat_token\":null,\"state\":\"online\",\"display_name\":\"MyCar\",\"option_codes\":\"AD15,MDL3,PBSB,RENA,BT37,ID3W,RF3G,S3PB,DRLH,DV2W,W39B,APF0,COUS,BC3B,CH07,PC30,FC3P,FG31,GLFR,HL31,HM31,IL31,LTPB,MR31,FM3B,RS3H,SA3P,STCP,SC04,SU3C,T3CA,TW00,TM00,UT3P,WR00,AU3P,APH3,AF00,ZCST,MI00,CDM0\",\"color\":null,\"api_version\":7,\"tokens\":[\"tok1\",\"tok2\"],\"id_s\":\"848528\",\"vehicle_id\":87576,\"id\":848528,\"in_service\":false,\"calendar_enabled\":true,\"user_id\":361508,\"vin\":\"SOMEVIN\"},{\"solar_type\":\"pv_panel\",\"energy_site_id\":2848535,\"breaker_alert_enabled\":false,\"solar_power\":0,\"id\":\"SOME_UU_I_D\",\"resource_type\":\"solar\",\"sync_grid_alert_enabled\":false}],\"count\":2}"+ testIsUserPresent :: Assertion testIsUserPresent = assertBool "expected user not present" $ isUserPresent sampleVehicleData @@ -34,13 +39,19 @@ testOpenDoors :: Assertion testOpenDoors =  assertEqual "open" [RearTrunk] (openDoors sampleVehicleData) +testParseProducts :: Assertion+testParseProducts = assertEqual "products" [ProductVehicle "MyCar" "848528",+                                            ProductEnergy 2848535]+                    (decodeProducts sampleProducts)+ tests :: [TestTree] tests = [   testCase "is user present" testIsUserPresent,   testCase "charging" testIsCharging,   testCase "timestamp" testTimestamp,   testCase "doors" testDoors,-  testCase "open doors" testOpenDoors+  testCase "open doors" testOpenDoors,+  testCase "products parsing" testParseProducts   ]  main :: IO ()