diff --git a/src/Tesla/Car/Command.hs b/src/Tesla/Car/Command.hs --- a/src/Tesla/Car/Command.hs +++ b/src/Tesla/Car/Command.hs @@ -1,9 +1,13 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + {-| Module : Tesla.Car.Command Description : Commands executed on a car. @@ -14,26 +18,28 @@ module Tesla.Car.Command ( Time(..), mkTime, fromTime, + Percent(..), mkPercent, runCmd, runCmd', CommandResponse, Car, (.=), -- * TH support for generating commands. mkCommand, mkCommands, mkNamedCommands) where -import Control.Lens hiding ((.=)) -import Control.Monad.IO.Class (MonadIO (..)) +import Control.Lens hiding ((.=)) +import Control.Monad.IO.Class (MonadIO (..)) import Data.Aeson -import Data.Aeson.Lens (_Bool, _String, key) -import qualified Data.ByteString.Lazy as BL -import Data.Finite (Finite, getFinite, modulo) -import Data.Text (Text) +import Data.Aeson.Lens (_Bool, _String, key) +import Data.Finite (Finite, getFinite, modulo, packFinite) +import Data.Text (Text) +import GHC.Read import GHC.TypeNats import Language.Haskell.TH -import Network.Wreq.Types (FormValue (..)) -import Text.Casing (fromSnake, toCamel) +import Network.Wreq.Types (FormValue (..)) +import Text.Casing (fromSnake, toCamel) +import Data.Aeson.Types (Pair) import Tesla.Car import Tesla.Internal.HTTP -import Data.Aeson.Types (Pair) +import qualified Text.ParserCombinators.ReadPrec as TextParser -- | A CommandResponse wraps an Either such that Left represents a -- failure message and Right suggests the command was successful. @@ -69,6 +75,20 @@ f :: forall m n. (KnownNat m, KnownNat n, n <= m) => Finite m -> Finite n f = modulo . toInteger +-- | A type representing a whole number percnetage between 0 and 100 (inclusive). +newtype Percent = Percent (Finite 101) + +instance Read Percent where + readPrec = TextParser.prec 10 (maybe TextParser.pfail pure . mkPercent @Int =<< readPrec) + +instance Show Percent where show (Percent t) = show (toInteger t) + +mkPercent :: Integral n => n -> Maybe Percent +mkPercent = fmap Percent . packFinite . toInteger + +instance ToJSON Percent where + toJSON (Percent x) = toJSON (getFinite x) + -- | Run a command with a JSON payload. runCmd :: MonadIO m => String -> [Pair] -> Car m CommandResponse runCmd cmd p = do @@ -81,12 +101,7 @@ -- | Run command without a payload runCmd' :: MonadIO m => String -> Car m CommandResponse -runCmd' cmd = do - v <- currentVehicleID - j :: Value <- jpostAuth (vehicleURL v $ "command/" <> cmd) BL.empty - pure $ case j ^? key "response" . key "result" . _Bool of - Just True -> Right () - _ -> Left $ j ^. key "response" . key "reason" . _String +runCmd' = (`runCmd` []) instance FormValue Bool where renderFormValue True = "true" diff --git a/src/Tesla/Car/Command/Charging.hs b/src/Tesla/Car/Command/Charging.hs --- a/src/Tesla/Car/Command/Charging.hs +++ b/src/Tesla/Car/Command/Charging.hs @@ -12,7 +12,7 @@ import Tesla.Car.Command -- | Set the desired charge level (percent). -setLimit :: MonadIO m => Int -> Car m CommandResponse +setLimit :: MonadIO m => Percent -> Car m CommandResponse setLimit to = runCmd "set_charge_limit" ["percent" .= to] -- | Set the charge current. diff --git a/src/Tesla/Car/Command/Climate.hs b/src/Tesla/Car/Command/Climate.hs --- a/src/Tesla/Car/Command/Climate.hs +++ b/src/Tesla/Car/Command/Climate.hs @@ -4,7 +4,7 @@ module Tesla.Car.Command.Climate ( hvacOn, hvacOff, ClimateKeeper(..), climateKeeper, - heatSeat, coolSeat, Seat(..), + seatClimate, Seat(..), SeatLevel(..), SeatClimate(..), SeatMode(..), setTemps, wheelHeater, wheelHeaterOff, wheelHeaterOn, maxDefrost, bioweaponMode, @@ -32,7 +32,9 @@ bioweaponMode :: MonadIO m => Bool -> Car m CommandResponse bioweaponMode on = runCmd "set_bioweapon_mode" ["on" .= on] +-- | Which seat to control. data Seat = DriverSeat | PassengerSeat | RearLeftSeat | RearCenterSeat | RearRightSeat + deriving (Eq, Show, Bounded, Enum) seatNum :: Seat -> Int seatNum DriverSeat = 0 @@ -41,16 +43,32 @@ seatNum RearCenterSeat = 4 seatNum RearRightSeat = 5 +-- | For seat climate control, how much heating or cooling to apply. +data SeatLevel = SeatLeast | SeatMedium | SeatMost + deriving (Eq, Show, Bounded, Enum) --- | 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] +instance ToJSON SeatLevel where + toJSON = toJSON . fromEnum --- | Set cooling levels for various seats. -coolSeat :: MonadIO m => Seat -> Int -> Car m CommandResponse -coolSeat seat level = runCmd "remote_seat_cooler_request" ["seat_position" .= seatNum seat, "seat_cooler_level" .= level] +-- | For seat climate control, whether to heat or cool. +data SeatMode = SeatHeat | SeatCool + deriving (Eq, Show, Bounded, Enum) --- | Set the main HVAC temperatures. +-- 'seatClimate' parameter for specifying whether to heat or cool and how much. +data SeatClimate = SeatClimate SeatMode SeatLevel + deriving (Eq, Show) + +-- | Adjust the climate control settings for a seat. +seatClimate :: MonadIO m => Seat -> Maybe SeatClimate -> Car m CommandResponse +seatClimate seat Nothing = do + _ <- runCmd "remote_seat_heater_request" ["heater" .= seatNum seat, "level" .= (0::Int)] + runCmd "remote_seat_cooler_request" ["seat_position" .= seatNum seat, "seat_cooler_level" .= (0 :: Int)] +seatClimate seat (Just (SeatClimate SeatHeat level)) = + runCmd "remote_seat_heater_request" ["heater" .= seatNum seat, "level" .= level] +seatClimate seat (Just (SeatClimate SeatCool level)) = + runCmd "remote_seat_cooler_request" ["seat_position" .= seatNum seat, "seat_cooler_level" .= level] + +-- | Set the main HVAC temperatures (driver and passenger). setTemps :: MonadIO m => (Double, Double) -> Car m CommandResponse setTemps (driver, passenger) = runCmd "set_temps" ["driver_temp" .= driver, "passenger_temp" .= passenger] @@ -63,6 +81,7 @@ -- | When configuring scheduled departure, preconditioning and -- off-peak charging both have weekday only options. data Sometimes = Never | Always | WeekdaysOnly + deriving (Eq, Show, Bounded, Enum) -- | Type alias to make 'scheduleDeparture' more readable. type Preconditioning = Sometimes @@ -96,6 +115,7 @@ instance ToJSON ClimateKeeper where toJSON = toJSON . fromEnum +-- | Configure the climate keeper. climateKeeper :: MonadIO m => ClimateKeeper -> Car m CommandResponse climateKeeper ck = runCmd "set_climate_keeper_mode" [ "climate_keeper_mode" .= ck] diff --git a/src/Tesla/Car/Command/Homelink.hs b/src/Tesla/Car/Command/Homelink.hs --- a/src/Tesla/Car/Command/Homelink.hs +++ b/src/Tesla/Car/Command/Homelink.hs @@ -1,10 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} -module Tesla.Car.Command.Homelink (trigger) where +module Tesla.Car.Command.Homelink (homelink) where import Control.Monad.IO.Class (MonadIO (..)) 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] +homelink :: MonadIO m => (Double, Double) -> Car m CommandResponse +homelink (lat,lon) = runCmd "flash_lights" ["lat" .= lat, "lon" .= lon] diff --git a/src/Tesla/Car/Command/Sharing.hs b/src/Tesla/Car/Command/Sharing.hs --- a/src/Tesla/Car/Command/Sharing.hs +++ b/src/Tesla/Car/Command/Sharing.hs @@ -9,6 +9,8 @@ import Tesla.Car.Command +-- | Share something to the car. +-- The "something" in this case can be an address or video URL share :: MonadIO m => Text -> Car m CommandResponse share to = do now <- fst . properFraction . utcTimeToPOSIXSeconds <$> liftIO getCurrentTime diff --git a/src/Tesla/Car/Command/Valet.hs b/src/Tesla/Car/Command/Valet.hs --- a/src/Tesla/Car/Command/Valet.hs +++ b/src/Tesla/Car/Command/Valet.hs @@ -9,6 +9,7 @@ import Tesla.Car.Command +-- | Enable valet mode with a four digit pin. setValetMode :: MonadIO m => Bool -> Int -> Car m CommandResponse setValetMode on pin = runCmd "set_valet_mode" [ "on" .= on, "password" .= pin] diff --git a/src/Tesla/Car/Command/Wake.hs b/src/Tesla/Car/Command/Wake.hs --- a/src/Tesla/Car/Command/Wake.hs +++ b/src/Tesla/Car/Command/Wake.hs @@ -1,14 +1,11 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE OverloadedStrings #-} module Tesla.Car.Command.Wake ( wakeUp ) where -import Control.Lens import Control.Monad.IO.Class (MonadIO (..)) import Data.Aeson -import Data.Aeson.Lens import qualified Data.ByteString.Lazy as BL @@ -16,7 +13,7 @@ import Tesla.Car.Command import Tesla.Internal.HTTP (jpostAuth) -wakeUp :: MonadIO m => Car m (Maybe Value) -wakeUp = do - v <- currentVehicleID - preview (_Just . key "response") <$> jpostAuth @_ @(Maybe Value) (vehicleURL v "wake_up") BL.empty +-- | Request the car to wake up. +-- This function should return pretty quickly, but the car may take a few seconds to wake up. +wakeUp :: (FromJSON j, MonadIO m) => Car m j +wakeUp = currentVehicleID >>= \v -> jpostAuth (vehicleURL v "wake_up") BL.empty diff --git a/src/Tesla/Car/Command/Windows.hs b/src/Tesla/Car/Command/Windows.hs --- a/src/Tesla/Car/Command/Windows.hs +++ b/src/Tesla/Car/Command/Windows.hs @@ -12,9 +12,11 @@ windowControl :: MonadIO m => Text -> (Double, Double) -> Car m CommandResponse windowControl x (lat,lon) = runCmd "window_control" [ "command" .= x, "lat" .= lat, "lon" .= lon] +-- | Roll the windows down slightly. ventWindows :: MonadIO m => Car m CommandResponse ventWindows = windowControl "vent" (0,0) +-- | Close the windows. This command will fail if the (lat,lon) passed in is too far from the car. closeWindows :: MonadIO m => (Double, Double) -> Car m CommandResponse closeWindows = windowControl "close" diff --git a/tesla.cabal b/tesla.cabal --- a/tesla.cabal +++ b/tesla.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 10fd401a397b5deea0c592f1f9fd9ee0443e0aa037897aa94ea4dd12f8379dfc +-- hash: e0d2e2f773d615d0ece057d0010a09010354337fbe9736a6489f13ab7c0d11f9 name: tesla -version: 0.7.2.0 +version: 0.7.4.0 synopsis: Tesla API client. description: Please see the README on GitHub at category: Web