diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for tesla + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Dustin Sallings (c) 2019 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Dustin Sallings nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,5 @@ +# tesla + +Tesla API for Haskell. + +See also: https://tesla-api.timdorr.com/ diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Tesla.hs b/src/Tesla.hs new file mode 100644 --- /dev/null +++ b/src/Tesla.hs @@ -0,0 +1,110 @@ +{-| +Module: Tesla +Description: Tesla API implementation. + +'Tesla' is intended to provide access to all known Tesla APIs as +documented at https://tesla-api.timdorr.com/ +-} + +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Tesla + ( authenticate, refreshAuth, AuthResponse(..), + AuthInfo(..), + vehicles, + fromToken, authOpts, baseURL + ) 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.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import Generics.Deriving.Base (Generic) +import Network.Wreq (FormParam (..), Options, Response, + asJSON, defaults, getWith, header, + postWith, responseBody) + +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" + + +userAgent :: BC.ByteString +userAgent = "github.com/dustin/tesla 0.1" + +defOpts :: Network.Wreq.Options +defOpts = defaults & header "User-Agent" .~ [userAgent] + +-- | 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) + +instance FromJSON AuthResponse where + parseJSON = genericParseJSON jsonOpts + +-- | 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 + +-- | 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 + + +-- | Get a set of wreq options from an 'AuthInfo'. +authOpts :: AuthInfo -> Network.Wreq.Options +authOpts AuthInfo{..} = defOpts & header "Authorization" .~ ["Bearer " <> BC.pack _bearerToken] + +-- | 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) diff --git a/src/Tesla/Car.hs b/src/Tesla/Car.hs new file mode 100644 --- /dev/null +++ b/src/Tesla/Car.hs @@ -0,0 +1,241 @@ +{-| +Module: Tesla.Car +Description: Tesla car-specific APIs. + +Access of car-specific APIs. +-} + +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +module Tesla.Car ( + -- * Car Monad and related types. + Car, runCar, runNamedCar, + VehicleID, + -- * Requests + vehicleData, nearbyChargers, + -- * Convenience functions for examining VehicleData + VehicleData, isUserPresent, isCharging, teslaTS, maybeTeslaTS, + Door(..), OpenState(..), doors, openDoors, + -- * Charger Info + Location(..), DestinationCharger(..), Supercharger(..), Charger(..), + superchargers, destinationChargers, + -- * Lenses + lat, lon, _SC, _DC, + name, location, distance_miles, available_stalls, total_stalls, site_closed, + -- * Probably uninteresting internals + vehicleURL, authInfo, vehicleID + ) where + +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 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 Tesla + +-- | 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 + +-- | Car Monad for accessing car-specific things. +type Car = ReaderT CarEnv + +-- | 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) + +-- | Run a Car Monad by looking up a car by name. +runNamedCar :: MonadIO m => Text -> IO AuthInfo -> Car m a -> m a +runNamedCar name ai f = do + a <- liftIO ai + vs <- vehicles a + runCar ai (vs Map.! name) f + +-- | Giant blob of VehicleData describing all known state of the vehicle. +-- +-- This is not separated into discrete +-- A VehicleIDfields because that's easy enough to do with Aeson and +-- Lens when you need it but some convenience methods for common +-- | A VehicleIDaccesses are available in this module. +type VehicleData = BL.ByteString + +-- | Fetch the VehicleData. +vehicleData :: MonadIO m => Car m VehicleData +vehicleData = do + a <- authInfo + v <- vehicleID + r <- liftIO $ getWith (authOpts a) (vehicleURL v "vehicle_data") + pure . fromJust . inner $ r ^. responseBody + where inner = BL.stripPrefix "{\"response\":" <=< BL.stripSuffix "}" + +-- | Get an Aeson Value from this VehicleData. +maybeVal :: VehicleData -> Maybe Value +maybeVal = decode + +-- | 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 + +-- | 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 + +-- | 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 + +-- | Get the timestamp from this VehicleData or error if there isn't one. +teslaTS :: VehicleData -> UTCTime +teslaTS b = fromMaybe (error . show $ b) . maybeTeslaTS $ b + +-- | The various doors. +data Door = DriverFront + | DriverRear + | PassengerFront + | PassengerRear + | FrontTrunk + | RearTrunk + deriving (Show, Bounded, Enum, Eq) + +-- I only care about 0, but these are the observed values: +-- 0 or 1 for df +-- 0 or 2 for pf +-- 0 or 4 for dr +-- 0 or 8 for pr +-- 0 or 16 for ft +-- 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 + +-- | Return a list of doors and their OpenState. +doors :: VehicleData -> Maybe [OpenState Door] +doors b = traverse ds $ zip ["df", "dr", "pf", "pr", "ft", "rt"] [minBound..] + where + ds (k,d) = c d <$> maybeVal b ^? _Just . key "vehicle_state" . key k . _Integer + c d 0 = Closed d + c d _ = Open d + +-- | Return a list of open doors. +openDoors :: VehicleData -> [Door] +openDoors b = maybe [] (map fromOpenState . filter isOpen) (doors b) + +-- | Location, Location, Location. +data Location = Location { _lat :: Double, _lon :: Double } deriving (Show, Generic) + +makeLenses ''Location + +instance FromJSON Location where + parseJSON = withObject "location" $ \v -> Location <$> v .: "lat" <*> v .: "long" + +chargeOpts :: Data.Aeson.Options +chargeOpts = defaultOptions { + fieldLabelModifier = dropWhile (== '_') + } + +-- | A destination charger (provided by nearbyChargers). +data DestinationCharger = DestinationCharger { + _location :: Location, + _name :: Text, + _distance_miles :: Double + } deriving (Show, Generic) + +makeFieldsNoPrefix ''DestinationCharger + +instance FromJSON DestinationCharger where + parseJSON = genericParseJSON chargeOpts + +-- | A supercharger (provided by nearbyChargers). +data Supercharger = Supercharger { + _location :: Location, + _name :: Text, + _distance_miles :: Double, + _available_stalls :: Int, + _total_stalls :: Int, + _site_closed :: Bool + } deriving(Show, Generic) + +makeFieldsNoPrefix ''Supercharger + +instance FromJSON Supercharger where + parseJSON = genericParseJSON chargeOpts + +-- | Eitehr a Supercharger or Destination charger. +data Charger = SC Supercharger | DC DestinationCharger deriving(Show) + +makePrisms ''Charger + +-- | Return only the superchargers from a Charger list. +superchargers :: [Charger] -> [Supercharger] +superchargers = toListOf (folded . _SC) + +-- | Return only the destination chargers from a Charger list. +destinationChargers :: [Charger] -> [DestinationCharger] +destinationChargers = toListOf (folded . _DC) + +-- | 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) + + where + parseOne rb f k = let rs = traverse fromJSON (rb ^. key "response" . key k . _Array) in + f <$> case rs of + Error e -> error e + Success s -> s diff --git a/src/Tesla/Command.hs b/src/Tesla/Command.hs new file mode 100644 --- /dev/null +++ b/src/Tesla/Command.hs @@ -0,0 +1,87 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Tesla/Command/Alerts.hs @@ -0,0 +1,11 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Tesla/Command/Charging.hs @@ -0,0 +1,19 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Tesla/Command/Climate.hs @@ -0,0 +1,46 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Tesla/Command/Doors.hs @@ -0,0 +1,18 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Tesla/Command/Homelink.hs @@ -0,0 +1,11 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Tesla/Command/Media.hs @@ -0,0 +1,18 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Tesla/Command/RemoteStart.hs @@ -0,0 +1,14 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Tesla/Command/Sentry.hs @@ -0,0 +1,12 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Tesla/Command/Sharing.hs @@ -0,0 +1,20 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Tesla/Command/Software.hs @@ -0,0 +1,19 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Tesla/Command/SpeedLimit.hs @@ -0,0 +1,24 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Tesla/Command/Valet.hs @@ -0,0 +1,15 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Tesla/Command/Windows.hs @@ -0,0 +1,28 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Tesla/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.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/tesla.cabal b/tesla.cabal new file mode 100644 --- /dev/null +++ b/tesla.cabal @@ -0,0 +1,101 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 8cdeecd446c907e59d314404de69be9fd58fd7e9276d2d0e1b34f4f222b77c1f + +name: tesla +version: 0.1.0.0 +synopsis: Tesla API client. +description: Please see the README on GitHub at +category: Web +homepage: https://github.com/dustin/tesla#readme +bug-reports: https://github.com/dustin/tesla/issues +author: Dustin Sallings +maintainer: dustin@spy.net +copyright: MIT +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/dustin/tesla + +library + exposed-modules: + Tesla + 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 + other-modules: + Paths_tesla + hs-source-dirs: + src + default-extensions: OverloadedStrings RecordWildCards NamedFieldPuns + ghc-options: -Wall + build-depends: + aeson >=1.4.5 && <1.5 + , base >=4.7 && <5 + , bytestring >=0.10 && <0.11 + , casing >=0.1.4 && <0.2 + , containers >=0.6 && <0.7 + , generic-deriving >=1.12 && <1.14 + , lens >=4.17 && <4.19 + , lens-aeson >=1.0 && <1.2 + , mtl >=2.2 && <2.3 + , template-haskell >=2.14 && <2.16 + , text >=1.2 && <1.3 + , time >=1.8 && <1.10 + , vector >=0.12.0 && <0.13 + , wreq >=0.5 && <0.6 + default-language: Haskell2010 + +test-suite tesla-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_tesla + hs-source-dirs: + test + default-extensions: OverloadedStrings RecordWildCards NamedFieldPuns + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + HUnit + , aeson >=1.4.5 && <1.5 + , base >=4.7 && <5 + , bytestring >=0.10 && <0.11 + , casing >=0.1.4 && <0.2 + , containers >=0.6 && <0.7 + , generic-deriving >=1.12 && <1.14 + , lens >=4.17 && <4.19 + , lens-aeson >=1.0 && <1.2 + , mtl >=2.2 && <2.3 + , tasty + , tasty-hunit + , tasty-quickcheck + , template-haskell >=2.14 && <2.16 + , tesla + , text >=1.2 && <1.3 + , time >=1.8 && <1.10 + , vector >=0.12.0 && <0.13 + , wreq >=0.5 && <0.6 + default-language: Haskell2010 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck as QC + +import Data.Ratio +import Data.Time.Clock (UTCTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) + +import Tesla +import Tesla.Car + +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\"}}" + +testIsUserPresent :: Assertion +testIsUserPresent = assertBool "expected user not present" $ isUserPresent sampleVehicleData + +testIsCharging :: Assertion +testIsCharging = assertBool "expected charging" $ isCharging sampleVehicleData + +testTimestamp :: Assertion +testTimestamp = assertEqual "timestamp" (posixSecondsToUTCTime . fromRational $ 1569718275489 % 1000) (teslaTS sampleVehicleData) + +testDoors :: Assertion +testDoors = assertEqual "doors" (Just [Closed DriverFront, + Closed DriverRear, + Closed PassengerFront, + Closed PassengerRear, + Closed FrontTrunk, + Open RearTrunk]) (doors sampleVehicleData) + +testOpenDoors :: Assertion +testOpenDoors = assertEqual "open" [RearTrunk] (openDoors sampleVehicleData) + +tests :: [TestTree] +tests = [ + testCase "is user present" testIsUserPresent, + testCase "charging" testIsCharging, + testCase "timestamp" testTimestamp, + testCase "doors" testDoors, + testCase "open doors" testOpenDoors + ] + +main :: IO () +main = defaultMain $ testGroup "All Tests" tests