diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,17 @@ # Changelog for tesla +# Release 0.5.0.0 + +Added: + +1. maxDefrost +2. bioweapon defense mode controls +3. setAmps +4. scheduled charging configuration +5. scheduled departure configuration + +Also added a prism for viewing `VehicleData` as an Aeson `Value`. + # Release 0.3.1.0 Authentication is supported again (though not yet MFA path). diff --git a/src/Tesla.hs b/src/Tesla.hs --- a/src/Tesla.hs +++ b/src/Tesla.hs @@ -41,7 +41,7 @@ import Data.Foldable (asum) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe (catMaybes, mapMaybe) +import Data.Maybe (catMaybes) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE @@ -124,8 +124,12 @@ . filter (\t -> isTagOpenName "input" t && fromAttrib "value" t /= "") . parseTags fopts = aOpts & header "content-type" .~ ["application/x-www-form-urlencoded"] - xcode u = head . mapMaybe (\s -> let [k,v] = T.splitOn "=" s in if k == "code" then Just v else Nothing) $ T.splitOn "&" (T.splitOn "?" (T.pack u) !! 1) - + xcode u = head [v | q <- tail (T.splitOn "?" (T.pack u)), + kv <- T.splitOn "&" q, + (k,v) <- paird (T.splitOn "=" kv), + k == "code"] + paird [a,b] = [(a,b)] + paird _ = [] findRedirect u opts a = preview (_Just . responseHeader "Location") <$> (inBody `catch` inException) where diff --git a/src/Tesla/Car.hs b/src/Tesla/Car.hs --- a/src/Tesla/Car.hs +++ b/src/Tesla/Car.hs @@ -30,16 +30,15 @@ -- * Charger Info Location(..), DestinationCharger(..), Supercharger(..), Charger(..), superchargers, destinationChargers, - -- * Lenses + -- * Lenses/Prisms lat, lon, _SC, _DC, - name, location, distance_miles, available_stalls, total_stalls, site_closed, + vdata, name, location, distance_miles, available_stalls, total_stalls, site_closed, -- * Probably uninteresting internals vehicleURL, currentVehicleID ) where import Control.Exception (Exception, throwIO) import Control.Lens -import Data.Foldable (fold) import Control.Monad ((<=<)) import Control.Monad.Catch (MonadCatch (..), MonadMask (..), MonadThrow (..)) import Control.Monad.IO.Class (MonadIO (..)) @@ -47,9 +46,10 @@ 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, _String) + encode, fieldLabelModifier, fromJSON, genericParseJSON, withObject, (.:)) +import Data.Aeson.Lens (_Bool, _Integer, _String, key, values) import qualified Data.ByteString.Lazy as BL +import Data.Foldable (fold) import qualified Data.Map.Strict as Map import Data.Maybe (fromJust, fromMaybe) import Data.Ratio @@ -131,8 +131,7 @@ vehicleStatus = do v <- currentVehicleID r <- jgetAuth (fold [baseURL, "api/1/vehicles/", unpack v]) - let (Just x) = (r :: Value) ^? (key "response" . key "state" . _String . to vsFromString) - pure x + pure $ (r :: Value) ^?! (key "response" . key "state" . _String . to vsFromString) -- | isAwake returns true if the current vehicle is awake and online. isAwake :: MonadIO m => Car m Bool @@ -147,21 +146,21 @@ 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 +-- | Prism for viewing 'VehicleData' as an Aeson 'Value'. +vdata :: Prism' VehicleData Value +vdata = prism' encode decode -- | True if a user is present in the vehicle. isUserPresent :: VehicleData -> Bool -isUserPresent = (Just True ==) . preview (_Just . key "vehicle_state" . key "is_user_present" . _Bool) . maybeVal +isUserPresent = (Just True ==) . preview (vdata . key "vehicle_state" . key "is_user_present" . _Bool) -- | True of the vehicle is currently charging. isCharging :: VehicleData -> Bool -isCharging = maybe False (> 0) . preview (_Just . key "charge_state" . key "charger_power" . _Integer) . maybeVal +isCharging = maybe False (> 0) . preview (vdata . key "charge_state" . key "charger_power" . _Integer) -- | Get the timestamp from this VehicleData if present. maybeTeslaTS :: VehicleData -> Maybe UTCTime -maybeTeslaTS b = maybeVal b ^? _Just . key "vehicle_state" . key "timestamp" . _Integer . to pt +maybeTeslaTS b = b ^? vdata . 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. @@ -192,7 +191,8 @@ 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 + vs = b ^? vdata . key "vehicle_state" + ds (k,d) = c d <$> vs ^? _Just . key k . _Integer c d 0 = Closed d c d _ = Open d 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,5 +1,9 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-| Module : Tesla.Car.Command Description : Commands executed on a car. @@ -9,6 +13,7 @@ {-# OPTIONS_GHC -Wno-orphans #-} module Tesla.Car.Command ( + Time(..), mkTime, fromTime, runCmd, runCmd', CommandResponse, Car, -- * TH support for generating commands. mkCommand, mkCommands, mkNamedCommands) where @@ -16,9 +21,11 @@ import Control.Lens import Control.Monad.IO.Class (MonadIO (..)) import Data.Aeson -import Data.Aeson.Lens (key, _Bool, _String) +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 GHC.TypeNats import Language.Haskell.TH import Network.Wreq.Types (FormValue (..), Postable) import Text.Casing (fromSnake, toCamel) @@ -29,6 +36,33 @@ -- | A CommandResponse wraps an Either such that Left represents a -- failure message and Right suggests the command was successful. type CommandResponse = Either Text () + +-- | Data type representing local time in minutes since midnight. +newtype Time = Time (Finite 1440) + +instance Show Time where show (Time t) = show (toInteger t) + +instance Num Time where + fromInteger = Time . modulo + abs = id + signum = const 1 + (Time f1) * (Time f2) = Time (f1 * f2) + (Time f1) + (Time f2) = Time (f1 + f2) + (Time f1) - (Time f2) = Time (f1 - f2) + +instance FormValue Time where + renderFormValue (Time x) = renderFormValue (getFinite x) + +-- | Make a 'Time' with the given hours and minutes. +mkTime :: Finite 24 -> Finite 60 -> Time +mkTime h m = Time $ modulo (toInteger h * 60 + toInteger m) + +-- | Get the hours and minutes out of a 'Time'. +fromTime :: Time -> (Finite 24, Finite 60) +fromTime (Time t) = bimap f f (t `divMod` 60) + where + f :: forall m n. (KnownNat m, KnownNat n, n <= m) => Finite m -> Finite n + f = modulo . toInteger -- | Run a command with a payload. runCmd :: (MonadIO m, Postable p) => String -> p -> Car m CommandResponse 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 @@ -2,7 +2,9 @@ {-# LANGUAGE TemplateHaskell #-} module Tesla.Car.Command.Charging ( - startCharging, stopCharging, setLimit, openChargePort, closeChargePort + startCharging, stopCharging, setLimit, openChargePort, closeChargePort, + setAmps, + scheduledChargingOff, scheduleCharging ) where import Control.Monad.IO.Class (MonadIO (..)) @@ -10,8 +12,21 @@ import Tesla.Car.Command +-- | Set the desired charge level (percent). setLimit :: MonadIO m => Int -> Car m CommandResponse setLimit to = runCmd "set_charge_limit" ["percent" := to ] + +-- | Set the charge current. +setAmps :: MonadIO m => Int -> Car m CommandResponse +setAmps to = runCmd "set_charging_amps" ["charging_amps" := to] + +-- | Disable scheduled charging. +scheduledChargingOff :: MonadIO m => Car m CommandResponse +scheduledChargingOff = runCmd "set_scheduled_charging" [ "enable" := False ] + +-- | Schedule charging for the given number of minutes after midnight (local time). +scheduleCharging :: MonadIO m => Time -> Car m CommandResponse +scheduleCharging mins = runCmd "set_scheduled_charging" [ "enable" := True, "time" := mins ] mkNamedCommands [("startCharging", "charge_start"), ("stopCharging", "charge_stop"), 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 @@ -1,10 +1,15 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module Tesla.Car.Command.Climate ( hvacOn, hvacOff, heatSeat, Seat(..), setTemps, wheelHeater, wheelHeaterOff, wheelHeaterOn, - wakeUp + maxDefrost, + wakeUp, + bioweaponMode, + Sometimes(..), OffPeakConfig(..), Preconditioning, + scheduledDepartureOff, scheduleDeparture ) where import Control.Monad.IO.Class (MonadIO (..)) @@ -22,6 +27,12 @@ wheelHeaterOff :: MonadIO m => Car m CommandResponse wheelHeaterOff = wheelHeater False +-- | Turn on or off bioweapon defense mode. +-- +-- If HVAC is off, turning on bioweapon defense mode will also turn on HVAC. +bioweaponMode :: MonadIO m => Bool -> Car m CommandResponse +bioweaponMode on = runCmd "set_bioweapon_mode" ["on" := on] + data Seat = DriverSeat | PassengerSeat | RearLeftSeat | RearCenterSeat | RearRightSeat -- | Set heating levels for various seats. @@ -39,6 +50,41 @@ setTemps :: MonadIO m => (Double, Double) -> Car m CommandResponse setTemps (driver, passenger) = runCmd "set_temps" ["driver_temp" := driver, "passenger_temp" := passenger] +maxDefrost :: MonadIO m => Bool -> Car m CommandResponse +maxDefrost on = runCmd "set_preconditioning_max" ["on" := on] + +scheduledDepartureOff :: MonadIO m => Car m CommandResponse +scheduledDepartureOff = runCmd "set_scheduled_departure" [ "enable" := False ] + +-- | When configuring scheduled departure, preconditioning and +-- off-peak charging both have weekday only options. +data Sometimes = Never | Always | WeekdaysOnly + +-- | Type alias to make 'scheduleDeparture' more readable. +type Preconditioning = Sometimes + +-- | Configuration for off-peak charging for a schedule departure. +data OffPeakConfig = OffPeakConfig { + _offPeakEnabled :: Sometimes, + _offPeakEndTime :: Time + } + +-- | Schedule a departure. +-- +-- For this to do anything useful, you need to specify at least one of +-- 'Preconditioning' and/or 'OffPeakConfig'. +scheduleDeparture :: MonadIO m => Time -> Preconditioning -> Maybe OffPeakConfig -> Car m CommandResponse +scheduleDeparture t p o = runCmd "set_scheduled_departure" (["enable" := True, "departure_time" := t] <> pp <> op o) + where + pp = s "preconditioning_enabled" "preconditioning_weekdays_only" p + op Nothing = opp (OffPeakConfig Never (Time 0)) + op (Just x) = opp x + opp OffPeakConfig{..} = ("end_off_peak_time" := _offPeakEndTime) : s "off_peak_charging_enabled" "off_peak_charging_weekdays_only" _offPeakEnabled + + s e w = \case + Never -> [e := False, w := False] + Always -> [e := True, w := False] + WeekdaysOnly -> [e := True, w := True] mkNamedCommands [("hvacOn", "auto_conditioning_start"), ("hvacOff", "auto_conditioning_stop"), 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.34.4. +-- This file has been generated from package.yaml by hpack version 0.34.5. -- -- see: https://github.com/sol/hpack -- --- hash: 5822d046f556526df7df83678077d331881386b90f7f164b89597b8f4997c04b +-- hash: 4b13596c9991ae6a3294f3b1f6ac466fe9c7bf0a81479506fbd15c939f169d02 name: tesla -version: 0.4.1.3 +version: 0.5.0.0 synopsis: Tesla API client. description: Please see the README on GitHub at category: Web @@ -67,6 +67,7 @@ , containers ==0.6.* , cryptonite , exceptions + , finite-typelits , generic-deriving >=1.12 && <1.15 , http-client , lens >=4.17 && <5.2 @@ -107,6 +108,7 @@ , containers ==0.6.* , cryptonite , exceptions + , finite-typelits , generic-deriving >=1.12 && <1.15 , http-client , lens >=4.17 && <5.2 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} import Test.Tasty @@ -5,14 +6,17 @@ import Test.Tasty.QuickCheck as QC import Data.Aeson +import Data.Finite import qualified Data.Map.Strict as Map import Data.Maybe (fromJust) import Data.Ratio import Data.Time.Clock (UTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import GHC.TypeNats (KnownNat (..)) import Tesla import Tesla.Car +import Tesla.Car.Command 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\"}}" @@ -29,6 +33,9 @@ testTimestamp :: Assertion testTimestamp = assertEqual "timestamp" (posixSecondsToUTCTime . fromRational $ 1569718275489 % 1000) (teslaTS sampleVehicleData) +instance KnownNat n => Arbitrary (Finite n) where + arbitrary = arbitraryBoundedEnum + testDoors :: Assertion testDoors = assertEqual "doors" (Just [Closed DriverFront, Closed DriverRear, @@ -47,8 +54,12 @@ assertEqual "vehicles" (Map.fromList [("MyCar", "848528")]) $ vehicles prods assertEqual "energy" [2848535] $ energyIDs prods +propTimeConversion :: Finite 24 -> Finite 60 -> Property +propTimeConversion h m = (h, m) === fromTime (mkTime h m) + tests :: [TestTree] tests = [ + testProperty "time conversion" propTimeConversion, testCase "is user present" testIsUserPresent, testCase "charging" testIsCharging, testCase "timestamp" testTimestamp,