{-# 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, runCar, runNamedCar,
VehicleID,
vehicleData, nearbyChargers,
VehicleData, isUserPresent, isCharging, teslaTS, maybeTeslaTS,
Door(..), OpenState(..), _Open, _Closed, doors, openDoors,
Location(..), DestinationCharger(..), Supercharger(..), Charger(..),
superchargers, destinationChargers,
lat, lon, _SC, _DC,
name, location, distance_miles, available_stalls, total_stalls, site_closed,
vehicleURL, currentVehicleID
) where
import Control.Exception (Exception, throwIO)
import Control.Lens
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 Generics.Deriving.Base (Generic)
import Network.Wreq (getWith, responseBody)
import Tesla
import Tesla.Auth
import Tesla.Internal.HTTP
vehicleURL :: VehicleID -> String -> String
vehicleURL v c = mconcat [baseURL, "api/1/vehicles/", unpack v, "/", c]
data CarEnv = CarEnv {
_authInfo :: IO AuthInfo,
_vid :: VehicleID
}
currentVehicleID :: MonadReader CarEnv m => m VehicleID
currentVehicleID = asks _vid
newtype Car m a = Car { runCarM :: ReaderT CarEnv m a }
deriving (Applicative, Functor, Monad, MonadIO,
MonadCatch, MonadThrow, MonadMask, MonadReader CarEnv,
MonadFail, MonadLogger)
instance MonadUnliftIO m => MonadUnliftIO (Car m) where
withRunInIO inner = Car $ withRunInIO $ \run -> inner (run . runCarM)
instance (Monad m, MonadIO m, MonadReader CarEnv m) => HasTeslaAuth m where
teslaAuth = liftIO =<< asks _authInfo
runCar :: MonadIO m => IO AuthInfo -> VehicleID -> Car m a -> m a
runCar ai vi f = runReaderT (runCarM f) (CarEnv ai vi)
newtype BadCarException = BadCar String deriving Eq
instance Show BadCarException where
show (BadCar s) = "BadCar: " <> s
instance Exception BadCarException
runNamedCar :: MonadIO m => Text -> IO AuthInfo -> Car m a -> m a
runNamedCar name ai f = do
a <- liftIO ai
vs <- vehicles a
c <- case Map.lookup name vs of
Nothing -> throw $ mconcat [show name, " is not a valid vehicle name. Try one of: ",
show $ Map.keys vs]
Just c -> pure c
runCar ai c f
where
throw = liftIO . throwIO . BadCar
type VehicleData = BL.ByteString
vehicleData :: MonadIO m => Car m VehicleData
vehicleData = do
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 "}"
maybeVal :: VehicleData -> Maybe Value
maybeVal = decode
isUserPresent :: VehicleData -> Bool
isUserPresent = fromMaybe False . preview (_Just . key "vehicle_state" . key "is_user_present" . _Bool) . maybeVal
isCharging :: VehicleData -> Bool
isCharging = maybe False (> 0) . preview (_Just . key "charge_state" . key "charger_power" . _Integer) . maybeVal
maybeTeslaTS :: VehicleData -> Maybe UTCTime
maybeTeslaTS b = maybeVal b ^? _Just . key "vehicle_state" . key "timestamp" . _Integer . to pt
where pt x = posixSecondsToUTCTime . fromRational $ x % 1000
teslaTS :: VehicleData -> UTCTime
teslaTS b = fromMaybe (error . show $ b) . maybeTeslaTS $ b
data Door = DriverFront
| DriverRear
| PassengerFront
| PassengerRear
| FrontTrunk
| RearTrunk
deriving (Show, Bounded, Enum, Eq)
data OpenState a = Closed a | Open a deriving (Show, Eq)
makePrisms ''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
openDoors :: VehicleData -> [Door]
openDoors = toListOf (_Just . folded . _Open) . doors
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 (== '_')
}
data DestinationCharger = DestinationCharger {
_location :: Location,
_name :: Text,
_distance_miles :: Double
} deriving (Show, Generic)
makeFieldsNoPrefix ''DestinationCharger
instance FromJSON DestinationCharger where
parseJSON = genericParseJSON chargeOpts
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
data Charger = SC Supercharger | DC DestinationCharger deriving(Show)
makePrisms ''Charger
superchargers :: [Charger] -> [Supercharger]
superchargers = toListOf (folded . _SC)
destinationChargers :: [Charger] -> [DestinationCharger]
destinationChargers = toListOf (folded . _DC)
nearbyChargers :: MonadIO m => Car m [Charger]
nearbyChargers = do
v <- currentVehicleID
rb <- jgetAuth (vehicleURL v "nearby_charging_sites")
pure $ parseOne rb SC "superchargers" <> parseOne rb DC "destination_charging"
where
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