{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-|
Module      : Tesla.Car.Command
Description : Commands executed on a car.

Executing commands within the Car Monad.
-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Tesla.Car.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.Types     (FormValue (..), Postable)
import           Text.Casing            (fromSnake, toCamel)

import           Tesla.Car
import           Tesla.Internal.HTTP

-- | 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 :: String -> p -> Car m CommandResponse
runCmd String
cmd p
p = do
  VehicleID
v <- Car m VehicleID
forall (m :: * -> *). MonadReader CarEnv m => m VehicleID
currentVehicleID
  Value
j :: Value <- String -> p -> Car m Value
forall (m :: * -> *) j a.
(HasTeslaAuth m, FromJSON j, Postable a, MonadIO m) =>
String -> a -> m j
jpostAuth (VehicleID -> String -> String
vehicleURL VehicleID
v (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"command/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
cmd) p
p
  CommandResponse -> Car m CommandResponse
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CommandResponse -> Car m CommandResponse)
-> CommandResponse -> Car m CommandResponse
forall a b. (a -> b) -> a -> b
$ case Value
j Value -> Getting (First Bool) Value Bool -> Maybe Bool
forall s a. s -> Getting (First a) s a -> Maybe a
^? VehicleID -> Traversal' Value Value
forall t. AsValue t => VehicleID -> Traversal' t Value
key VehicleID
"response" ((Value -> Const (First Bool) Value)
 -> Value -> Const (First Bool) Value)
-> Getting (First Bool) Value Bool
-> Getting (First Bool) Value Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VehicleID -> Traversal' Value Value
forall t. AsValue t => VehicleID -> Traversal' t Value
key VehicleID
"result" ((Value -> Const (First Bool) Value)
 -> Value -> Const (First Bool) Value)
-> Getting (First Bool) Value Bool
-> Getting (First Bool) Value Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First Bool) Value Bool
forall t. AsPrimitive t => Prism' t Bool
_Bool of
    Just Bool
True -> () -> CommandResponse
forall a b. b -> Either a b
Right ()
    Maybe Bool
_         -> VehicleID -> CommandResponse
forall a b. a -> Either a b
Left (VehicleID -> CommandResponse) -> VehicleID -> CommandResponse
forall a b. (a -> b) -> a -> b
$ Value
j Value -> Getting VehicleID Value VehicleID -> VehicleID
forall s a. s -> Getting a s a -> a
^. VehicleID -> Traversal' Value Value
forall t. AsValue t => VehicleID -> Traversal' t Value
key VehicleID
"response" ((Value -> Const VehicleID Value)
 -> Value -> Const VehicleID Value)
-> Getting VehicleID Value VehicleID
-> Getting VehicleID Value VehicleID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VehicleID -> Traversal' Value Value
forall t. AsValue t => VehicleID -> Traversal' t Value
key VehicleID
"reason" ((Value -> Const VehicleID Value)
 -> Value -> Const VehicleID Value)
-> Getting VehicleID Value VehicleID
-> Getting VehicleID Value VehicleID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting VehicleID Value VehicleID
forall t. AsPrimitive t => Prism' t VehicleID
_String

-- | Run command without a payload
runCmd' :: MonadIO m => String -> Car m CommandResponse
runCmd' :: String -> Car m CommandResponse
runCmd' String
cmd = String -> ByteString -> Car m CommandResponse
forall (m :: * -> *) p.
(MonadIO m, Postable p) =>
String -> p -> Car m CommandResponse
runCmd String
cmd ByteString
BL.empty

instance FormValue Bool where
  renderFormValue :: Bool -> ByteString
renderFormValue Bool
True  = ByteString
"true"
  renderFormValue Bool
False = ByteString
"false"

-- | Build a simple named command car that posts to the given named endpoint.
mkCommand :: String -> String -> Q [Dec]
mkCommand :: String -> String -> Q [Dec]
mkCommand String
s String
u = do
  let m :: Name
m = String -> Name
mkName String
"m"
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [
    Name -> Type -> Dec
SigD (String -> Name
mkName String
s) ([TyVarBndr] -> Cxt -> Type -> Type
ForallT [Name -> TyVarBndr
PlainTV Name
m] [Type -> Type -> Type
AppT (Name -> Type
ConT (String -> Name
mkName String
"MonadIO")) (Name -> Type
VarT Name
m)]
                     (Type -> Type -> Type
AppT (Type -> Type -> Type
AppT (Name -> Type
ConT (String -> Name
mkName String
"Car")) (Name -> Type
VarT Name
m)) (Name -> Type
ConT (String -> Name
mkName String
"CommandResponse")))),
    Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
s) [[Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
expr) []]]
  where expr :: Exp
expr = [Pat] -> Exp -> Exp
LamE [] (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE (String -> Name
mkName String
"runCmd'")) (Lit -> Exp
LitE (String -> Lit
StringL String
u)))

cmapM :: (Monoid b, Applicative f) => (a -> f b) -> [a] -> f b
cmapM :: (a -> f b) -> [a] -> f b
cmapM a -> f b
f [a]
xs = [b] -> b
forall a. Monoid a => [a] -> a
mconcat ([b] -> b) -> f [b] -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> [a] -> f [b]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f [a]
xs

-- | Build a bunch of commands from a list of named endpoints, defining
-- functions by removing the common prefix.
mkCommands :: [String] -> Q [Dec]
mkCommands :: [String] -> Q [Dec]
mkCommands [String]
targets = (String -> Q [Dec]) -> [String] -> Q [Dec]
forall b (f :: * -> *) a.
(Monoid b, Applicative f) =>
(a -> f b) -> [a] -> f b
cmapM String -> Q [Dec]
easyCMD [String]
targets
  where
    prefix :: String
prefix = [String] -> String
commonPrefix [String]
targets
    easyCMD :: String -> Q [Dec]
    easyCMD :: String -> Q [Dec]
easyCMD String
target = do
      let s :: String
s = Int -> String -> String
forall a. Int -> [a] -> [a]
drop (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
prefix) String
target
          mn :: String
mn = (Identifier String -> String
toCamel (Identifier String -> String)
-> (String -> Identifier String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Identifier String
fromSnake) String
s
      String -> String -> Q [Dec]
mkCommand String
mn String
target

    commonPrefix :: [String] -> String
commonPrefix = (String -> Char) -> [String] -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Char
forall a. [a] -> a
head ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\(Char
x:String
xs) -> (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
x) String
xs) ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall (f :: * -> *) a. (Foldable f, Functor f) => f [a] -> [f a]
tp
      where
        tp :: f [a] -> [f a]
tp f [a]
xs
          | ([a] -> Bool) -> f [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null f [a]
xs = []
          | Bool
otherwise = ([a] -> a
forall a. [a] -> a
head ([a] -> a) -> f [a] -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f [a]
xs) f a -> [f a] -> [f a]
forall a. a -> [a] -> [a]
: f [a] -> [f a]
tp ([a] -> [a]
forall a. [a] -> [a]
tail ([a] -> [a]) -> f [a] -> f [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f [a]
xs)

-- | Make commands with given names.
mkNamedCommands :: [(String, String)] -> Q [Dec]
mkNamedCommands :: [(String, String)] -> Q [Dec]
mkNamedCommands = ((String, String) -> Q [Dec]) -> [(String, String)] -> Q [Dec]
forall b (f :: * -> *) a.
(Monoid b, Applicative f) =>
(a -> f b) -> [a] -> f b
cmapM ((String -> String -> Q [Dec]) -> (String, String) -> Q [Dec]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> String -> Q [Dec]
mkCommand)