HueAPI 0 → 0.1

raw patch · 2 files changed

+51/−31 lines, 2 filesdep +utf8-stringdep −bytestringPVP ok

version bump matches the API change (PVP)

Dependencies added: utf8-string

Dependencies removed: bytestring

API changes (from Hackage documentation)

Files

• HueAPI.cabal +2/−2
• HueAPI.hs +49/−29

@@ -1,5 +1,5 @@ name:                HueAPI-version:             0+version:             0.1 synopsis:            API for controlling Philips Hue lights description: homepage:            https://github.com/sjoerdvisscher/HueAPI@@ -15,7 +15,7 @@   exposed-modules:     HueAPI   build-depends:       base ==4.6.*,                        aeson ==0.6.*,-                       bytestring ==0.10.*,+                       utf8-string ==0.3.*,                        http-conduit ==1.8.*,                        network ==2.4.*,                        containers ==0.5.*,

@@ -7,9 +7,10 @@   , Group(..)   , Name   -  , HueMonad-  , runHueMonad+  , Hue+  , runHue   +  , getState   , getLightState   , updateLight   , initLight@@ -18,8 +19,7 @@  import GHC.Generics import Data.Aeson-import qualified Data.ByteString as B (breakSubstring, null)-import qualified Data.ByteString.Lazy as B hiding (null)+import Data.ByteString.Lazy.UTF8 (fromString) import Network.HTTP.Conduit import Network import Data.Map.Strict (Map, toList, (!), adjust)@@ -30,6 +30,7 @@ import Control.Monad.Reader (ReaderT(..), ask) import Control.Concurrent + type Name = String  data HueData = Hue@@ -63,28 +64,43 @@ 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 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+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+       -getLightState :: Name -> HueMonad LightState+getState :: Hue HueData+getState = get++getLightState :: Name -> Hue LightState getLightState name = do   d <- get   return $ state $ lights d ! name  -updateLight :: Name -> LightState -> HueMonad ()+updateLight :: Name -> LightState -> Hue () updateLight name l = do   l' <- getLightState name   when (on l /= on l') $@@ -100,7 +116,7 @@   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 -> LightState -> Hue () initLight name l = do   updateLightProp name "on" "true"   updateLightProp name "bri" (show $ bri l)@@ -111,33 +127,37 @@   put $ d { lights = adjust (\light -> light { state = l }) name (lights d) }      -updateLightProp :: Name -> String -> String -> HueMonad ()+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 (B.pack $ map(toEnum.fromEnum) $ "{\"" ++ prop ++ "\":" ++ value ++ "}")+        requestBody = RequestBodyLBS (fromString $ "{\"" ++ 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+  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 (B.pack $ map(toEnum.fromEnum) $+      requestBody = RequestBodyLBS (fromString $         "{\"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+  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 ()