-
Notifications
You must be signed in to change notification settings - Fork 22
/
Copy pathHueREST.hs
193 lines (174 loc) · 8.17 KB
/
HueREST.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
{-# LANGUAGE ScopedTypeVariables, OverloadedStrings, LambdaCase, RecordWildCards #-}
module HueREST ( BridgeRequestMethod(..)
, noBody
, bridgeRequest
, bridgeRequestTrace
, bridgeRequestRetryTrace
, BridgeError(..)
, BridgeResponse(..)
) where
import Control.Monad
import Control.Applicative
import Control.Monad.IO.Class
import Control.Monad.Catch
import Data.Aeson
import Data.Monoid
import Network.HTTP.Simple
import Util
import Trace
-- Interface to make calls to the REST / HTTP / JSON based API of a Hue bridge
--
-- http://www.developers.meethue.com/philips-hue-api
-- TODO: Add 'Offline' mode, returning captured bridge responses
data BridgeRequestMethod = MethodGET | MethodPOST | MethodPUT
deriving (Eq, Enum)
instance Show BridgeRequestMethod where
show MethodGET = "GET"
show MethodPOST = "POST"
show MethodPUT = "PUT"
-- Makes it a little easier to do a request without a body
noBody :: Maybe Int
noBody = Nothing
-- Call a REST API on the Hue bridge
bridgeRequest :: forall m a body. (MonadIO m, MonadThrow m, FromJSON a, ToJSON body)
=> BridgeRequestMethod
-> IPAddress
-> Maybe body
-> BridgeUserID
-> String
-> m a
bridgeRequest method bridgeIP mbBody userID apiEndPoint = do
request' <- parseRequest $ show method <> " http://" <> fromIPAddress bridgeIP <> "/api/"
<> fromBridgeUserID userID <> "/" <> apiEndPoint
let request = case mbBody of
Just j -> setRequestBodyJSON j request'
Nothing -> request'
response <- httpJSON request
return (getResponseBody response :: a)
-- TODO: Would be good to have an exception type to restart the entire server to recover
-- from a bridge IP change or something like that
-- Wrapper around bridgeRequest which traces errors and doesn't return anything, fire and forget
bridgeRequestTrace :: forall m body. ( MonadIO m
, MonadThrow m
, MonadCatch m
, ToJSON body
, Show body
)
=> BridgeRequestMethod
-> IPAddress
-> Maybe body
-> BridgeUserID
-> String
-> m ()
bridgeRequestTrace method bridgeIP mbBody userID apiEndPoint = do
-- Trace requests where we change state / request something
when (method == MethodPUT || method == MethodPOST) $
traceS TLInfo $ "bridgeRequestTrace: " <> show method <> " " <>
apiEndPoint <> " - " <>
case mbBody of Just b -> show b; _ -> ""
r <- (Just <$> bridgeRequest method bridgeIP mbBody userID apiEndPoint) `catches`
[ Handler $ \(e :: HttpException) -> do
-- Network / IO error
traceS TLError $ "bridgeRequestTrace: HTTP exception while contacting '"
<> apiEndPoint <> "' : " <> show e
return Nothing
, Handler $ \(e :: JSONException) -> do
-- Parsing error
traceS TLError $ "bridgeRequestTrace: JSON exception while contacting '"
<> apiEndPoint <> "' : " <> show e
return Nothing
]
case r of
Just (ResponseOK (_ :: Value)) ->
-- Success
return ()
Just err@(ResponseError { .. }) -> do
-- Got an error from the bridge
traceS TLError $ "bridgeRequestTrace: Error response from '"
<> apiEndPoint <> "' : " <> show err
Nothing -> return ()
-- Wrapper around bridgeRequest which traces errors and retries automatically
bridgeRequestRetryTrace :: forall m a body. ( MonadIO m
, MonadThrow m
, MonadCatch m
, FromJSON a
, Show a -- TODO: For the show instance of the
--- response, we actually never
-- print the result...
, ToJSON body
, Show body
)
=> BridgeRequestMethod
-> IPAddress
-> Maybe body
-> BridgeUserID
-> String
-> m a
bridgeRequestRetryTrace method bridgeIP mbBody userID apiEndPoint = do
-- Trace requests where we change state / request something
when (method == MethodPUT || method == MethodPOST) $
traceS TLInfo $ "bridgeRequestRetryTrace: " <> show method <> " " <>
apiEndPoint <> " - " <>
case mbBody of Just b -> show b; _ -> ""
-- TODO: It makes sense to retry if we have a connection error, but in case of
-- something like a parsing error or an access denied type response, an
-- endless retry loop might not do anything productive
r <- (Just <$> bridgeRequest method bridgeIP mbBody userID apiEndPoint) `catches`
[ Handler $ \(e :: HttpException) -> do
-- Network / IO error
traceS TLError $ "bridgeRequestRetryTrace: HTTP exception while contacting '"
<> apiEndPoint <> "' (retry in 5s): " <> show e
return Nothing
, Handler $ \(e :: JSONException) -> do
-- Parsing error
traceS TLError $ "bridgeRequestRetryTrace: JSON exception while contacting '"
<> apiEndPoint <> "' (retry in 5s): " <> show e
return Nothing
]
case r of
Just (ResponseOK (val :: a)) ->
-- Success
return val
Just err@(ResponseError { .. }) -> do
-- Got an error from the bridge
traceS TLError $ "bridgeRequestRetryTrace: Error response from '"
<> apiEndPoint <> "' (retry in 5s): " <> show err
waitNSec 5
retry
Nothing -> do
waitNSec 5
retry
where
retry = bridgeRequestRetryTrace method bridgeIP mbBody userID apiEndPoint
-- We add custom constructors for the bridge errors we actually want to handle, default
-- all others to BEOther
--
-- http://www.developers.meethue.com/documentation/error-messages
--
data BridgeError = BEUnauthorizedUser
| BELinkButtonNotPressed
| BEOther !Int
deriving (Eq, Show)
instance Enum BridgeError where
toEnum 1 = BEUnauthorizedUser
toEnum 101 = BELinkButtonNotPressed
toEnum err = BEOther err
fromEnum BEUnauthorizedUser = 1
fromEnum BELinkButtonNotPressed = 101
fromEnum (BEOther err) = err
-- Generic response type from the bridge. Either we get an array containing an object with
-- the 'error' key and the type / address / description fields, or we get our wanted response
data BridgeResponse a = ResponseError { reType :: !BridgeError
, reAddr :: !String
, reDesc :: !String
}
| ResponseOK a
deriving Show
instance FromJSON a => FromJSON (BridgeResponse a) where
parseJSON j = let parseError = do [(Object o)] <- parseJSON j
err <- o .: "error"
ResponseError <$> (toEnum <$> err .: "type")
<*> err .: "address"
<*> err .: "description"
parseOK = ResponseOK <$> parseJSON j
in parseError <|> parseOK