diff --git a/src/Tesla.hs b/src/Tesla.hs --- a/src/Tesla.hs +++ b/src/Tesla.hs @@ -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 diff --git a/src/Tesla/Auth.hs b/src/Tesla/Auth.hs new file mode 100644 --- /dev/null +++ b/src/Tesla/Auth.hs @@ -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 diff --git a/src/Tesla/Car.hs b/src/Tesla/Car.hs --- a/src/Tesla/Car.hs +++ b/src/Tesla/Car.hs @@ -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 diff --git a/src/Tesla/Car/Command.hs b/src/Tesla/Car/Command.hs new file mode 100644 --- /dev/null +++ b/src/Tesla/Car/Command.hs @@ -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) diff --git a/src/Tesla/Car/Command/Alerts.hs b/src/Tesla/Car/Command/Alerts.hs new file mode 100644 --- /dev/null +++ b/src/Tesla/Car/Command/Alerts.hs @@ -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"] diff --git a/src/Tesla/Car/Command/Charging.hs b/src/Tesla/Car/Command/Charging.hs new file mode 100644 --- /dev/null +++ b/src/Tesla/Car/Command/Charging.hs @@ -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")] diff --git a/src/Tesla/Car/Command/Climate.hs b/src/Tesla/Car/Command/Climate.hs new file mode 100644 --- /dev/null +++ b/src/Tesla/Car/Command/Climate.hs @@ -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")] + diff --git a/src/Tesla/Car/Command/Doors.hs b/src/Tesla/Car/Command/Doors.hs new file mode 100644 --- /dev/null +++ b/src/Tesla/Car/Command/Doors.hs @@ -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")] diff --git a/src/Tesla/Car/Command/Homelink.hs b/src/Tesla/Car/Command/Homelink.hs new file mode 100644 --- /dev/null +++ b/src/Tesla/Car/Command/Homelink.hs @@ -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] diff --git a/src/Tesla/Car/Command/Media.hs b/src/Tesla/Car/Command/Media.hs new file mode 100644 --- /dev/null +++ b/src/Tesla/Car/Command/Media.hs @@ -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" + ] diff --git a/src/Tesla/Car/Command/RemoteStart.hs b/src/Tesla/Car/Command/RemoteStart.hs new file mode 100644 --- /dev/null +++ b/src/Tesla/Car/Command/RemoteStart.hs @@ -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] diff --git a/src/Tesla/Car/Command/Sentry.hs b/src/Tesla/Car/Command/Sentry.hs new file mode 100644 --- /dev/null +++ b/src/Tesla/Car/Command/Sentry.hs @@ -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 ] diff --git a/src/Tesla/Car/Command/Sharing.hs b/src/Tesla/Car/Command/Sharing.hs new file mode 100644 --- /dev/null +++ b/src/Tesla/Car/Command/Sharing.hs @@ -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)) + ] diff --git a/src/Tesla/Car/Command/Software.hs b/src/Tesla/Car/Command/Software.hs new file mode 100644 --- /dev/null +++ b/src/Tesla/Car/Command/Software.hs @@ -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" + diff --git a/src/Tesla/Car/Command/SpeedLimit.hs b/src/Tesla/Car/Command/SpeedLimit.hs new file mode 100644 --- /dev/null +++ b/src/Tesla/Car/Command/SpeedLimit.hs @@ -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" diff --git a/src/Tesla/Car/Command/Valet.hs b/src/Tesla/Car/Command/Valet.hs new file mode 100644 --- /dev/null +++ b/src/Tesla/Car/Command/Valet.hs @@ -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" diff --git a/src/Tesla/Car/Command/Windows.hs b/src/Tesla/Car/Command/Windows.hs new file mode 100644 --- /dev/null +++ b/src/Tesla/Car/Command/Windows.hs @@ -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" diff --git a/src/Tesla/Car/Commands.hs b/src/Tesla/Car/Commands.hs new file mode 100644 --- /dev/null +++ b/src/Tesla/Car/Commands.hs @@ -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 diff --git a/src/Tesla/Command.hs b/src/Tesla/Command.hs deleted file mode 100644 --- a/src/Tesla/Command.hs +++ /dev/null @@ -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) diff --git a/src/Tesla/Command/Alerts.hs b/src/Tesla/Command/Alerts.hs deleted file mode 100644 --- a/src/Tesla/Command/Alerts.hs +++ /dev/null @@ -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"] diff --git a/src/Tesla/Command/Charging.hs b/src/Tesla/Command/Charging.hs deleted file mode 100644 --- a/src/Tesla/Command/Charging.hs +++ /dev/null @@ -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")] diff --git a/src/Tesla/Command/Climate.hs b/src/Tesla/Command/Climate.hs deleted file mode 100644 --- a/src/Tesla/Command/Climate.hs +++ /dev/null @@ -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")] - diff --git a/src/Tesla/Command/Doors.hs b/src/Tesla/Command/Doors.hs deleted file mode 100644 --- a/src/Tesla/Command/Doors.hs +++ /dev/null @@ -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" diff --git a/src/Tesla/Command/Homelink.hs b/src/Tesla/Command/Homelink.hs deleted file mode 100644 --- a/src/Tesla/Command/Homelink.hs +++ /dev/null @@ -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] diff --git a/src/Tesla/Command/Media.hs b/src/Tesla/Command/Media.hs deleted file mode 100644 --- a/src/Tesla/Command/Media.hs +++ /dev/null @@ -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" - ] diff --git a/src/Tesla/Command/RemoteStart.hs b/src/Tesla/Command/RemoteStart.hs deleted file mode 100644 --- a/src/Tesla/Command/RemoteStart.hs +++ /dev/null @@ -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] diff --git a/src/Tesla/Command/Sentry.hs b/src/Tesla/Command/Sentry.hs deleted file mode 100644 --- a/src/Tesla/Command/Sentry.hs +++ /dev/null @@ -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 ] diff --git a/src/Tesla/Command/Sharing.hs b/src/Tesla/Command/Sharing.hs deleted file mode 100644 --- a/src/Tesla/Command/Sharing.hs +++ /dev/null @@ -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)) - ] diff --git a/src/Tesla/Command/Software.hs b/src/Tesla/Command/Software.hs deleted file mode 100644 --- a/src/Tesla/Command/Software.hs +++ /dev/null @@ -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" - diff --git a/src/Tesla/Command/SpeedLimit.hs b/src/Tesla/Command/SpeedLimit.hs deleted file mode 100644 --- a/src/Tesla/Command/SpeedLimit.hs +++ /dev/null @@ -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" diff --git a/src/Tesla/Command/Valet.hs b/src/Tesla/Command/Valet.hs deleted file mode 100644 --- a/src/Tesla/Command/Valet.hs +++ /dev/null @@ -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" diff --git a/src/Tesla/Command/Windows.hs b/src/Tesla/Command/Windows.hs deleted file mode 100644 --- a/src/Tesla/Command/Windows.hs +++ /dev/null @@ -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" diff --git a/src/Tesla/Commands.hs b/src/Tesla/Commands.hs deleted file mode 100644 --- a/src/Tesla/Commands.hs +++ /dev/null @@ -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 diff --git a/src/Tesla/Energy.hs b/src/Tesla/Energy.hs new file mode 100644 --- /dev/null +++ b/src/Tesla/Energy.hs @@ -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") +-} diff --git a/src/Tesla/Internal/HTTP.hs b/src/Tesla/Internal/HTTP.hs new file mode 100644 --- /dev/null +++ b/src/Tesla/Internal/HTTP.hs @@ -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 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.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 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 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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\":\"\",\"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 ()