HueAPI (empty) → 0

raw patch · 4 files changed

+198/−0 lines, 4 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, containers, http-conduit, mtl, network, transformers

Files

HueAPI.cabal +23/−0
HueAPI.hs +143/−0
LICENSE +30/−0
Setup.hs +2/−0

+ HueAPI.cabal view

@@ -0,0 +1,23 @@+name:                HueAPI+version:             0+synopsis:            API for controlling Philips Hue lights+description:+homepage:            https://github.com/sjoerdvisscher/HueAPI+license:             BSD3+license-file:        LICENSE+author:              Sjoerd Visscher+maintainer:          sjoerd@q42.nl+category:            Hardware+build-type:          Simple+cabal-version:       >=1.8++library+  exposed-modules:     HueAPI+  build-depends:       base ==4.6.*,+                       aeson ==0.6.*,+                       bytestring ==0.10.*,+                       http-conduit ==1.8.*,+                       network ==2.4.*,+                       containers ==0.5.*,+                       transformers ==0.3.*,+                       mtl ==2.1.*

+ HueAPI.hs view

@@ -0,0 +1,143 @@+ {-# LANGUAGE OverloadedStrings, DeriveGeneric #-}+module HueAPI (+  +    HueData(..)+  , Light(..)+  , LightState(..)+  , Group(..)+  , Name+  +  , HueMonad+  , runHueMonad+  +  , getLightState+  , updateLight+  , initLight+  +) where++import GHC.Generics+import Data.Aeson+import qualified Data.ByteString as B (breakSubstring, null)+import qualified Data.ByteString.Lazy as B hiding (null)+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"+++type HueMonad = StateT HueData (ReaderT String IO)++runHueMonad :: String -> String -> HueMonad a -> IO a+runHueMonad host key api =+  let url = "http://" ++ host ++ "/api/" ++ key ++ "/" in+  withSocketsDo $ do+    connect key host+    request' <- parseUrl url+    let request = request' { responseTimeout = Nothing }+    resp <- withManager $ httpLbs request+    d <- either fail return (eitherDecode (responseBody resp))+    runReaderT (fst <$> runStateT api d) url+++getLightState :: Name -> HueMonad LightState+getLightState name = do+  d <- get+  return $ state $ lights d ! name+++updateLight :: Name -> LightState -> HueMonad ()+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 -> HueMonad ()+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 -> HueMonad ()+updateLightProp name prop value = do+  url <- ask+  resp <- liftIO $ withSocketsDo $ do+    initReq <- parseUrl $ url ++ "lights/" ++ name ++ "/state"+    let request = initReq {+        requestBody = RequestBodyLBS (B.pack $ map(toEnum.fromEnum) $ "{\"" ++ prop ++ "\":" ++ value ++ "}")+      , method = "PUT"+      , responseTimeout = Nothing+      }+    withManager (httpLbs request)+  if B.null . snd . B.breakSubstring "Internal error, 503" . B.toStrict $ responseBody resp then return () else do+    liftIO $ print resp+    liftIO $ threadDelay 100000+    updateLightProp name prop value++connect :: String -> String -> IO ()+connect key host = do+  initReq <- parseUrl $ "http://" ++ host ++ "/api/"+  let request = initReq {+      requestBody = RequestBodyLBS (B.pack $ map(toEnum.fromEnum) $+        "{\"username\":\"" ++ key ++ "\",\"devicetype\":\"Unknown\"}")+    , method = "POST"+    , responseTimeout = Nothing+    }+  resp <- withManager (httpLbs request)+  if B.null . snd . B.breakSubstring "error" . B.toStrict $ responseBody resp then return () else do+    liftIO $ print resp+    liftIO $ threadDelay 100000+    connect key host

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2012, Sjoerd Visscher++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Sjoerd Visscher nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain