Command.hs

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

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

module Tesla.Car.Command (
  Time(..), mkTime, fromTime,
  runCmd, runCmd', CommandResponse, Car,
  (.=),
  -- * TH support for generating commands.
  mkCommand, mkCommands, mkNamedCommands) where

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           GHC.TypeNats
import           Language.Haskell.TH
import           Network.Wreq.Types     (FormValue (..))
import           Text.Casing            (fromSnake, toCamel)

import           Tesla.Car
import           Tesla.Internal.HTTP
import Data.Aeson.Types (Pair)

-- | 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)

instance ToJSON Time where
  toJSON (Time x) = toJSON (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 JSON payload.
runCmd :: MonadIO m => String -> [Pair] -> Car m CommandResponse
runCmd cmd p = do
  v <- currentVehicleID
  j :: Value <- jpostAuth (vehicleURL v $ "command/" <> cmd) (object p)
  pure $ case j ^? key "response" . key "result" . _Bool of
    Just True -> Right ()
    _         -> Left $ j ^. key "response" . key "reason" . _String


-- | 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

instance FormValue Bool where
  renderFormValue True  = "true"
  renderFormValue False = "false"

-- | Build a simple named command car that posts to the given named endpoint.
mkCommand :: String -> String -> Q [Dec]
mkCommand s u = do
  let m = mkName "m"
  pure [
    SigD (mkName s) (ForallT [PlainTV m inferredSpec] [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

-- | Build a bunch of commands from a list of named endpoints, defining
-- functions by removing the common prefix.
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)

-- | Make commands with given names.
mkNamedCommands :: [(String, String)] -> Q [Dec]
mkNamedCommands = cmapM (uncurry mkCommand)