module HueAPI (
HueData(..)
, Light(..)
, LightState(..)
, Group(..)
, Name
, Hue
, runHue
, getState
, getLightState
, updateLight
, initLight
) where
import GHC.Generics
import Data.Aeson
import Data.Aeson.Lens (_JSON)
import Data.Map.Strict (Map, fromList, (!), adjust)
import Control.Applicative
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.State (StateT(..), runStateT, get, put)
import Control.Monad.Reader (ReaderT(..), runReaderT, ask)
import Control.Concurrent
import Control.Lens
import qualified Network.Wreq as Wreq
type Name = String
data HueData = Hue
{ lights :: Map Name Light
, groups :: Map Name Group
} deriving (Show, Generic)
data Light = Light
{ state :: LightState
, name :: Name
, modelid :: String
, swversion :: String
} deriving (Show, Generic)
data LightState = LightState
{ on :: Bool
, bri :: Int
, hue :: Int
, sat :: Int
} deriving (Show, Generic)
data Group = Group
{ action :: LightState
, groupName :: Name
, groupLights :: [Name]
} deriving (Show, Generic)
instance FromJSON HueData
instance FromJSON Light
instance FromJSON LightState
instance FromJSON Group where
parseJSON (Object v) = Group <$> v .: "action" <*> v .: "name" <*> v .: "lights"
instance ToJSON HueData
instance ToJSON Light
instance ToJSON LightState
instance ToJSON Group
data HueResult = HueResult HueError deriving (Show, Generic)
instance FromJSON HueResult where
parseJSON (Object v) = HueResult <$> v .: "error"
instance ToJSON HueResult
data HueError = HueError Int String deriving (Show, Generic)
instance FromJSON HueError where
parseJSON (Object v) = HueError <$> v .: "type" <*> v .: "description"
instance ToJSON HueError
type Hue = StateT HueData (ReaderT String IO)
runHue :: String -> String -> Hue a -> IO a
runHue host key hm = do
hueData <- go
runReaderT (fst <$> runStateT hm hueData) url
where
url = "http://" ++ host ++ "/api/" ++ key ++ "/"
go = do
r <- Wreq.get url
maybe doConnect return $ r ^? Wreq.responseBody . _JSON
doConnect = do
putStrLn "Press the link button on the base station"
connect key host
go
getState :: Hue HueData
getState = get
getLightState :: Name -> Hue LightState
getLightState name = do
d <- get
return $ state $ lights d ! name
updateLight :: Name -> LightState -> Hue ()
updateLight name l = do
l' <- getLightState name
if on l then do
when (not $ on l') $ updateLightProps name [("on", True)]
updateLightProps name $
[("bri", toJSON $ bri l)|bri l /= bri l']
++ [("hue", toJSON $ hue l)|hue l /= hue l']
++ [("sat", toJSON $ sat l)|sat l /= sat l']
else
when (on l') $ updateLightProps name [("on", False)]
d <- get
put $ d { lights = adjust (\light -> light { state = if on l then l else l' { on = False } }) name (lights d) }
initLight :: Name -> LightState -> Hue ()
initLight name l = do
updateLightProps name [("on", True)]
updateLightProps name $
[ ("bri", toJSON $ bri l)
, ("hue", toJSON $ hue l)
, ("sat", toJSON $ sat l)
]
updateLightProps name [("on", on l)]
d <- get
put $ d { lights = adjust (\light -> light { state = l }) name (lights d) }
updateLightProps :: ToJSON a => Name -> [(String, a)] -> Hue ()
updateLightProps _ [] = return ()
updateLightProps name m = do
url <- ask
resp <- liftIO $ Wreq.put (url ++ "lights/" ++ name ++ "/state") $ toJSON (fromList m)
case resp ^? Wreq.responseBody . _JSON of
Just [HueResult (HueError i msg)] -> do
when (i /= 901) $
liftIO $ putStrLn $ "Error " ++ show i ++ ": " ++ msg
liftIO $ threadDelay 100000
updateLightProps name m
_ -> return ()
connect :: String -> String -> IO ()
connect key host = do
resp <- Wreq.post ("http://" ++ host ++ "/api/") $ toJSON $ fromList
[ ("username", key)
, ("devicetype" :: String, "Unknown" :: String)
]
case resp ^? Wreq.responseBody . _JSON of
Just [HueResult (HueError i msg)] -> do
when (i /= 101) $
putStrLn $ "Error " ++ show i ++ ": " ++ msg
threadDelay 100000
connect key host
_ -> return ()