module HueAPI (
HueData(..)
, Light(..)
, LightState(..)
, Group(..)
, Name
, Hue
, runHue
, getState
, getLightState
, updateLight
, initLight
) where
import GHC.Generics
import Data.Aeson
import Data.ByteString.Lazy.UTF8 (fromString)
import Network.HTTP.Conduit
import Network
import Data.Map.Strict (Map, toList, (!), adjust)
import Control.Applicative
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.State (StateT(..), get, put)
import Control.Monad.Reader (ReaderT(..), ask)
import Control.Concurrent
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)
instance FromJSON HueData
instance FromJSON Light
instance FromJSON LightState
instance FromJSON Group where
parseJSON (Object v) = Group <$> v .: "action" <*> v .: "name" <*> v .: "lights"
data HueResult = HueResult HueError deriving Show
instance FromJSON HueResult where
parseJSON (Object v) = HueResult <$> v .: "error"
data HueError = HueError Int String deriving Show
instance FromJSON HueError where
parseJSON (Object v) = HueError <$> v .: "type" <*> v .: "description"
type Hue = StateT HueData (ReaderT String IO)
runHue :: String -> String -> Hue a -> IO a
runHue host key hm = do
hueData <- withSocketsDo go
runReaderT (fst <$> runStateT hm hueData) url
where
url = "http://" ++ host ++ "/api/" ++ key ++ "/"
go = do
request' <- parseUrl url
let request = request' { responseTimeout = Nothing }
resp <- withManager $ httpLbs request
either doConnect return (eitherDecode (responseBody resp))
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
when (on l /= on l') $
updateLightProp name "on" (if on l then "true" else "false")
when (on l) $ do
when (bri l /= bri l') $
updateLightProp name "bri" (show $ bri l)
when (hue l /= hue l') $
updateLightProp name "hue" (show $ hue l)
when (sat l /= sat l') $
updateLightProp name "sat" (show $ sat l)
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
updateLightProp name "on" "true"
updateLightProp name "bri" (show $ bri l)
updateLightProp name "hue" (show $ hue l)
updateLightProp name "sat" (show $ sat l)
updateLightProp name "on" (if on l then "true" else "false")
d <- get
put $ d { lights = adjust (\light -> light { state = l }) name (lights d) }
updateLightProp :: Name -> String -> String -> Hue ()
updateLightProp name prop value = do
url <- ask
resp <- liftIO $ withSocketsDo $ do
initReq <- parseUrl $ url ++ "lights/" ++ name ++ "/state"
let request = initReq {
requestBody = RequestBodyLBS (fromString $ "{\"" ++ prop ++ "\":" ++ value ++ "}")
, method = "PUT"
, responseTimeout = Nothing
}
withManager (httpLbs request)
case eitherDecode $ responseBody resp of
Right [HueResult (HueError 901 _)] -> do
liftIO $ threadDelay 100000
updateLightProp name prop value
Right [HueResult (HueError i m)] -> fail $ "Error " ++ show i ++ ": " ++ m
_ -> return ()
connect :: String -> String -> IO ()
connect key host = do
initReq <- parseUrl $ "http://" ++ host ++ "/api/"
let request = initReq {
requestBody = RequestBodyLBS (fromString $
"{\"username\":\"" ++ key ++ "\",\"devicetype\":\"Unknown\"}")
, method = "POST"
, responseTimeout = Nothing
}
resp <- withManager (httpLbs request)
case eitherDecode $ responseBody resp of
Right [HueResult (HueError 101 _)] -> do
liftIO $ threadDelay 100000
connect key host
Right [HueResult (HueError i m)] -> fail $ "Error " ++ show i ++ ": " ++ m
_ -> return ()