{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Tesla.Car.Command (
runCmd, runCmd', CommandResponse, Car,
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
type CommandResponse = Either Text ()
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
runCmd' :: MonadIO m => String -> Car m CommandResponse
runCmd' cmd = runCmd cmd BL.empty
instance FormValue Bool where
renderFormValue True = "true"
renderFormValue False = "false"
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
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)
mkNamedCommands :: [(String, String)] -> Q [Dec]
mkNamedCommands = cmapM (uncurry mkCommand)