b397f65 · typeable/pagerduty

git.iko.soy/typeable/pagerduty

Updating Services API to use more succinct path/query lenses

commitb397f658e77fb8d212b114907d9b9d2627df4bf6 authorBrendan Hay <brendan.g.hay@gmail.com> dateTue 30 Sep 2014, 11:39 (12 years ago) parent0624660

4 files changed+139−112

compare with develop

unifiedsplit

pagerduty.cabal+6−6 src/Network/PagerDuty.hs+14−15 src/Network/PagerDuty/Services.hs+63−47 src/Network/PagerDuty/Types.hs+56−44

pagerduty.cabal+6−6

@@ -31,8 +31,8 @@ library

3131

3232 exposed-modules:

3333 Network.PagerDuty

34− , Network.PagerDuty.Alerts

35− , Network.PagerDuty.EscalationPolicies

34+ -- , Network.PagerDuty.Alerts

35+ -- , Network.PagerDuty.EscalationPolicies

3636 , Network.PagerDuty.Services

3737

3838 -- , Network.PagerDuty.Incidents

@@ -44,9 +44,9 @@ library

4444 -- , Network.PagerDuty.Users

4545

4646 other-modules:

47− Network.PagerDuty.Alerts.Types

48− , Network.PagerDuty.EscalationPolicies.Types

49− , Network.PagerDuty.Services.Types

47+ Network.PagerDuty.Alerts.Types

48+ -- , Network.PagerDuty.EscalationPolicies.Types

49+-- Network.PagerDuty.Services.Types

5050 , Network.PagerDuty.TH

5151 , Network.PagerDuty.Types

5252

@@ -58,6 +58,7 @@ library

5858 , bytestring-conversion >= 0.2.1

5959 , conduit >= 0.5.5

6060 , data-default >= 0.5

61+ , formatting >= 5.4

6162 , http-client >= 0.3.6 && < 0.5

6263 , http-client-lens >= 0.1

6364 , http-types >= 0.8 && < 1.0

@@ -68,4 +69,3 @@ library

6869 , time >= 1.4 && < 2.0

6970 , transformers >= 0.3 && < 0.5

7071 , unordered-containers >= 0.2.3

71−

src/Network/PagerDuty.hs+14−15

@@ -44,20 +44,20 @@ import Network.PagerDuty.Types

4444-- , _envManager :: Manager

4545-- }

4646

47−send :: (MonadIO m, FromJSON r)

47+send :: (MonadIO m, FromJSON b)

4848 => Auth s

4949 -> SubDomain

5050 -> Manager

51− -> Request a s r

52− -> m (Either Error r)

51+ -> Request a s b

52+ -> m (Either Error b)

5353send a s m = liftM (fmap fst) . http a s m

5454

55−paginate :: (MonadIO m, Paginate a, FromJSON r)

55+paginate :: (MonadIO m, Paginate a, FromJSON b)

5656 => Auth s

5757 -> SubDomain

5858 -> Manager

59− -> Request a s r

60− -> Source m (Either Error r)

59+ -> Request a s b

60+ -> Source m (Either Error b)

6161paginate a d m = go

6262 where

6363 go rq = do

@@ -67,26 +67,25 @@ paginate a d m = go

6767 (maybe (return ()) go . next rq . snd)

6868 rs

6969

70−http :: (MonadIO m, FromJSON r)

70+http :: (MonadIO m, FromJSON b)

7171 => Auth s

7272 -> SubDomain

7373 -> Manager

74− -> Request a s r

75− -> m (Either Error (r, Maybe Pager))

74+ -> Request a s b

75+ -> m (Either Error (b, Maybe Pager))

7676http a (SubDomain h) m rq = liftIO (httpLbs raw m) >>= response rq

7777 where

7878 raw = authorise

7979 & Lens.secure .~ True

8080 & Lens.port .~ 443

81− & Lens.path .~ renderPath (rq^.path)

82− & Lens.queryString .~ renderQuery False (rq^.query)

81+ & Lens.path .~ renderPath (rq ^. path)

82+ & Lens.queryString .~ renderQuery False (rq ^. query)

8383 & Lens.requestHeaders <>~ headers

8484 & Lens.requestBody .~ Client.RequestBodyLBS (encode rq)

8585

8686 authorise = case a of

8787 AuthBasic u p -> Client.applyBasicAuth u p def & Lens.host .~ h

8888 AuthToken t -> def & Lens.host .~ h & Lens.requestHeaders <>~ [token t]

89− _ -> def

9089

9190 token t = ("Authorization", "Token token=" <> t)

9291

@@ -95,10 +94,10 @@ http a (SubDomain h) m rq = liftIO (httpLbs raw m) >>= response rq

9594 , ("Accept", "application/json")

9695 ]

9796

98−response :: (MonadIO m, FromJSON r)

99− => Request a s r

97+response :: (MonadIO m, FromJSON b)

98+ => Request a s b

10099 -> Client.Response LBS.ByteString

101− -> m (Either Error (r, Maybe Pager))

100+ -> m (Either Error (b, Maybe Pager))

102101response _ x = case statusCode (Client.responseStatus x) of

103102 200 -> success

104103 201 -> success

src/Network/PagerDuty/Services.hs+63−47

@@ -1,6 +1,9 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE TemplateHaskell #-}

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE ExtendedDefaultRules #-}

3+{-# LANGUAGE OverloadedStrings #-}

4+{-# LANGUAGE TemplateHaskell #-}

6+{-# OPTIONS_GHC -fno-warn-type-defaults #-}

58-- Module : Network.PagerDuty.Services

@@ -30,10 +33,10 @@ module Network.PagerDuty.Services

3033 -- * Create Service

3134 , createService

3235 , csName

33− , csEscalationPolicyId

36+ , csDescription

3437 , csType

3538 , csVendorId

36− , csDescription

39+ , csEscalationPolicyId

3740 , csAcknowledgementTimeout

3841 , csAutoResolveTimeout

3942 , csSeverityFilter

@@ -43,6 +46,12 @@ module Network.PagerDuty.Services

4346

4447 -- * Update Service

4548 , updateService

49+ , usName

50+ , usEscalationPolicyId

51+ , usDescription

52+ , usAcknowledgementTimeout

53+ , usAutoResolveTimeout

54+ , usSeverityFilter

4655

4756 -- * Delete Service

4857 , deleteService

@@ -105,14 +114,17 @@ module Network.PagerDuty.Services

105114

106115import Control.Lens

107116import Data.Aeson.Lens

117+import Data.ByteString.Builder (Builder)

108118import Data.Text (Text)

109119import Network.HTTP.Types

110120import Network.PagerDuty.Services.Types

111121import Network.PagerDuty.TH

112122import Network.PagerDuty.Types

113123

114−services :: Setter (Request a s r) (Request a s r) Path [Path]

115−services = base "services"

124+default (Builder)

125+

126+services :: Path

127+services = "services"

116128

117129includes :: Query

118130includes =

@@ -138,9 +150,9 @@ listServices :: Request ListServices Token [Service]

138150listServices =

139151 mk ListServices

140152 { _lsTimeZone' = Nothing

141− } & services .~ []

142− & unwrap .~ key "escalation_policies"

143− & query <>~ includes

153+ } & path .~ services

154+ & query <>~ includes

155+ & unwrap .~ key "escalation_policies"

144156

145157-- | Time zone in which dates in the result will be rendered.

146158--

@@ -181,16 +193,16 @@ createService n p t =

181193 , _csAcknowledgementTimeout' = Nothing

182194 , _csAutoResolveTimeout' = Nothing

183195 , _csSeverityFilter' = Nothing

184− } & services .~ []

185− & unwrap .~ key "service"

196+ } & path .~ services

197+ & unwrap .~ key "service"

186198

187199-- | The name of the service.

188200csName :: Lens' (Request CreateService s r) Text

189201csName = upd.csName'

190202

191−-- | The id of the escalation policy to be used by this service.

192−csEscalationPolicyId :: Lens' (Request CreateService s r) PolicyId

193−csEscalationPolicyId = upd.csEscalationPolicyId'

203+-- | A description for your service. 1024 character maximum.

204+csDescription :: Lens' (Request CreateService s r) (Maybe Text)

205+csDescription = upd.csDescription'

194206

195207-- | The type of service to create.

196208csType :: Lens' (Request CreateService s r) ServiceType

@@ -201,9 +213,9 @@ csType = upd.csType'

201213csVendorId :: Lens' (Request CreateService s r) (Maybe VendorId)

202214csVendorId = upd.csVendorId'

203215

204−-- | A description for your service. 1024 character maximum.

205−csDescription :: Lens' (Request CreateService s r) (Maybe Text)

206−csDescription = upd.csDescription'

216+-- | The id of the escalation policy to be used by this service.

217+csEscalationPolicyId :: Lens' (Request CreateService s r) PolicyId

218+csEscalationPolicyId = upd.csEscalationPolicyId'

207219

208220-- | The duration in seconds before an incidents acknowledged in this service

209221-- become triggered again.

@@ -229,15 +241,14 @@ csSeverityFilter = upd.csSeverityFilter'

229241-- See: <http://developer.pagerduty.com/documentation/rest/services/show>

230242getService :: ServiceId -> Request Empty Token Service

231243getService i = empty

232− & services .~ [P i]

233− & unwrap .~ key "service"

234− & query <>~ includes

244+ & path .~ services % i

245+ & query <>~ includes

246+ & unwrap .~ key "service"

235247

236248data UpdateService = UpdateService

237− { _usName' :: Text

238− , _usEscalationPolicyId' :: PolicyId

239− , _usType' :: !ServiceType

249+ { _usName' :: Maybe Text

240250 , _usDescription' :: Maybe Text

251+ , _usEscalationPolicyId' :: Maybe PolicyId

241252 , _usAcknowledgementTimeout' :: Maybe Int

242253 , _usAutoResolveTimeout' :: Maybe Int

243254 , _usSeverityFilter' :: Maybe SeverityFilter

@@ -251,36 +262,31 @@ makeLenses ''UpdateService

251262-- @PUT services\/\:id@

252263--

253264-- See: <http://developer.pagerduty.com/documentation/rest/services/update>

254−updateService ServiceId -> Request UpdateService Token Service

265+updateService :: ServiceId -> Request UpdateService Token Service

255266updateService i =

256267 mk UpdateService

257− { _usName' = n

258− , _usEscalationPolicyId' = p

259− , _usType' = t

268+ { _usName' = Nothing

269+ , _usEscalationPolicyId' = Nothing

260270 , _usDescription' = Nothing

261271 , _usAcknowledgementTimeout' = Nothing

262272 , _usAutoResolveTimeout' = Nothing

263273 , _usSeverityFilter' = Nothing

264− } & services .~ [P i]

265− & unwrap .~ key "service"

274+ } & meth .~ PUT

275+ & path .~ services % i

276+ & unwrap .~ key "service"

266277

267278-- | The name of the service.

268−usName :: Lens' (Request UpdateService s r) Text

279+usName :: Lens' (Request UpdateService s r) (Maybe Text)

269280usName = upd.usName'

270281

271−-- | The id of the escalation policy to be used by this service.

272−usEscalationPolicyId :: Lens' (Request UpdateService s r) PolicyId

273−usEscalationPolicyId = upd.usEscalationPolicyId'

274−

275−-- | PagerDuty's internal vendor identifier for this service. For more information

276−-- about a specific vendor, please contact PagerDuty Support.

277−usVendorId :: Lens' (Request UpdateService s r) (Maybe VendorId)

278−usVendorId = upd.usVendorId'

279−

280282-- | A description for your service. 1024 character maximum.

281283usDescription :: Lens' (Request UpdateService s r) (Maybe Text)

282284usDescription = upd.usDescription'

283285

286+-- | The id of the escalation policy to be used by this service.

287+usEscalationPolicyId :: Lens' (Request UpdateService s r) (Maybe PolicyId)

288+usEscalationPolicyId = upd.usEscalationPolicyId'

289+

284290-- | The duration in seconds before an incidents acknowledged in this service

285291-- become triggered again.

286292--

@@ -306,15 +312,20 @@ usSeverityFilter = upd.usSeverityFilter'

306312--

307313-- See: <http://developer.pagerduty.com/documentation/rest/services/delete>

308314deleteService :: ServiceId -> Request Empty Token Empty

309−deleteService i = empty & services .~ [P i] & meth .~ DELETE

315+deleteService i = empty & meth .~ DELETE & path .~ services % i

310316

311317-- | Enable a previously disabled service.

312318--

313319-- @PUT services\/\:id\/enable@

314320--

315321-- See: <http://developer.pagerduty.com/documentation/rest/services/enable>

316−enableService :: ServiceId -> Request Empty Token Empty

317−enableService i = empty & services .~ [P i, "enable"] & meth .~ PUT

322+enableService :: RequesterId -> ServiceId -> Request Empty s Empty

323+enableService r i = auth (enableServiceBasic i) & query .~ [("requester_id", r)]

324+

325+-- | A version of 'enableService' which uses HTTP Basic authentication and

326+-- doesn't require a 'RequesterId'.

327+enableServiceBasic :: ServiceId -> Request Empty Basic Empty

328+enableServiceBasic i = empty & meth .~ PUT & path .~ services % i % "enable"

318329

319330-- | Disable a service. Once a service is disabled, it will not be able to

320331-- create incidents until it is enabled again.

@@ -322,8 +333,13 @@ enableService i = empty & services .~ [P i, "enable"] & meth .~ PUT

322333-- @PUT services\/\:id\/disable@

323334--

324335-- See: <http://developer.pagerduty.com/documentation/rest/services/disable>

325−disableService :: ServiceId -> Request Empty Token Empty

326−disableService i = empty & services .~ [P i, "disable"] & meth .~ PUT

336+disableService :: RequesterId -> ServiceId -> Request Empty s Empty

337+disableService r i = auth (disableServiceBasic i) & query .~ [("requester_id", r)]

338+

339+-- | A version of 'disableService' which uses HTTP Basic authentication and

340+-- doesn't require a 'RequesterId'.

341+disableServiceBasic :: ServiceId -> Request Empty Basic Empty

342+disableServiceBasic i = empty & meth .~ PUT & path .~ services % i % "disable"

327343

328344-- | Regenerate a new service key for an existing service.

329345--

@@ -333,5 +349,5 @@ disableService i = empty & services .~ [P i, "disable"] & meth .~ PUT

333349-- @POST services\/\:id\/regenerate_key@

334350--

335351-- See: <http://developer.pagerduty.com/documentation/rest/services/regenerate_key>

336−regenerateKey :: ServiceId -> Request Empty Token Service

337−regenerateKey i = empty & services .~ [P i, "regenerate_key"] & meth .~ POST

352+regenerateKey :: ServiceId -> Request Empty s Service

353+regenerateKey i = empty & meth .~ POST & path .~ services % i % "regenerate_key"

src/Network/PagerDuty/Types.hs+56−44

@@ -51,21 +51,22 @@ module Network.PagerDuty.Types where

5151 -- ) where

5252

5353import Control.Applicative

54−import Control.Lens hiding ((.=))

55−import Data.Aeson hiding (Error)

56−import Data.Aeson.Types (Parser)

57−import Data.ByteString (ByteString)

58−import qualified Data.ByteString.Char8 as BS

54+import Control.Lens hiding ((.=))

55+import Data.Aeson hiding (Error)

56+import Data.Aeson.Types (Parser)

57+import Data.ByteString (ByteString)

58+import qualified Data.ByteString.Char8 as BS

5959import Data.ByteString.Conversion

6060import Data.Function

61−import qualified Data.HashMap.Strict as Map

61+import qualified Data.HashMap.Strict as Map

6262import Data.Monoid

6363import Data.String

64−import Data.Text (Text)

65−import qualified Data.Time as Time

66−import Data.Time hiding (TimeZone)

64+import Data.Text (Text)

65+import qualified Data.Time as Time

66+import Data.Time hiding (TimeZone)

6767import GHC.TypeLits

6868import Network.HTTP.Types

69+import Network.HTTP.Types.QueryLike

6970import Network.PagerDuty.TH

7071

7172-- FIXME: Query String parameters vs JSON bodies for GET

@@ -93,13 +94,13 @@ instance FromJSON TimeZone where

9394instance ToJSON TimeZone where

9495 toJSON = undefined

9596

96−data Security = Basic | Token | None

97+data Security = Basic | Token -- None

9798 deriving (Eq, Show)

9899

99100data Auth (a :: Security) where

100101 AuthBasic :: ByteString -> ByteString -> Auth Basic

101102 AuthToken :: ByteString -> Auth Token

102− AuthNone :: Auth None

103+-- AuthNone :: Auth None

103104

104105deriving instance Eq (Auth a)

105106deriving instance Show (Auth a)

@@ -189,21 +190,24 @@ instance ToJSON Pager where

189190

190191-- | A path segment.

191192data Path where

192− E :: Path

193− P :: ToByteString a => a -> Path

193+ Path :: Path

194+ Seg :: ToByteString a => a -> Path

194195

195196instance Monoid Path where

196− mempty = E

197− mappend x E = x

198− mappend E y = y

199− mappend (P x) (P y) = P (builder x <> "/" <> builder y)

197+ mempty = Path

198+ mappend x Path = x

199+ mappend Path y = y

200+ mappend (Seg x) (Seg y) = Seg (builder x <> "/" <> builder y)

200201

201202instance IsString Path where

202− fromString = P

203+ fromString = Seg

203204

204205instance ToByteString Path where

205− builder E = mempty

206− builder (P x) = builder x

206+ builder Path = mempty

207+ builder (Seg x) = builder x

208+

209+(%) :: ToByteString a => Path -> a -> Path

210+a % b = a <> Seg b

207211

208212renderPath :: Path -> ByteString

209213renderPath = toByteString' . mappend v1

@@ -211,18 +215,18 @@ renderPath = toByteString' . mappend v1

211215 v1 :: Path

212216 v1 = "/api/v1"

213217

214−data Request a (s :: Security) r where

218+data Request a (s :: Security) b where

215219 Request :: ToJSON a

216− => { _rqPayload :: a

217− , _rqMethod :: !StdMethod

218− , _rqPath :: Path

219− , _rqQuery :: Query

220− , _rqPager :: Maybe Pager

221− , _rqUnwrap :: Value -> Parser Value

220+ => { _rqPayload :: a

221+ , _rqMethod :: !StdMethod

222+ , _rqPath :: Path

223+ , _rqQuery :: Query

224+ , _rqPager :: Maybe Pager

225+ , _rqUnwrap :: Value -> Parser Value

222226 }

223− -> Request a s r

227+ -> Request a s b

224228

225−instance ToJSON (Request a s r) where

229+instance ToJSON (Request a s b) where

226230 -- Manually unwrapped to ensure GADT constraint holds.

227231 toJSON (Request p _ _ _ q _) = Object $

228232 let Object x = toJSON p

@@ -233,40 +237,42 @@ instance ToJSON (Request a s r) where

233237type Unwrap = Getting (First Value) Value Value

234238

235239-- | Create a defaulted request from the payload type.

236−mk :: ToJSON a => a -> Request a s r

237−mk x = Request x GET E mempty Nothing pure

240+mk :: ToJSON a => a -> Request a s b

241+mk x = Request x GET mempty mempty Nothing pure

238242

239243empty :: Request Empty s r

240244empty = mk Empty

241245

242246-- | Modify the request state.

243−upd :: ToJSON a => Lens' (Request a s r) a

247+upd :: ToJSON a => Lens' (Request a s b) a

244248upd = lens _rqPayload (\(Request _ m p q g u) x -> Request x m p q g u)

245249

246−meth :: Lens' (Request a s r) StdMethod

247−meth = lens _rqMethod (\r x -> r { _rqMethod = x })

250+-- | Drop the security constraint.

251+auth :: Request a s b -> Request a t b

252+auth (Request x m p q g u) = Request x m p q g u

248253

249−path :: Getter (Request a s r) Path

250−path = to _rqPath

254+meth :: Lens' (Request a s b) StdMethod

255+meth = lens _rqMethod (\r x -> r { _rqMethod = x })

251256

252−base :: Path -> Setter (Request a s r) (Request a s r) Path [Path]

253−base x = lens (view path) (\r xs -> r { _rqPath = mconcat (x:xs) })

257+path :: Lens' (Request a s b) Path

258+path = lens _rqPath (\r x -> r { _rqPath = x })

254259

255−query :: Lens' (Request a s r) Query

256−query = lens _rqQuery (\r x -> r { _rqQuery = x })

260+query :: QueryValueLike v

261+ => Lens (Request a s b) (Request a s b) Query [(ByteString, v)]

262+query = lens _rqQuery (\r x -> r { _rqQuery = toQuery x })

257263

258−pager :: Lens' (Request a s r) (Maybe Pager)

264+pager :: Lens' (Request a s b) (Maybe Pager)

259265pager = lens _rqPager (\r x -> r { _rqPager = x })

260266

261−unwrap :: Setter (Request a s r) (Request a s r) (Value -> Parser Value) Unwrap

262−unwrap f r = fmap (\k -> r { _rqUnwrap = g k }) (f (_rqUnwrap r))

267+unwrap :: Setter (Request a s b) (Request a s b) (Value -> Parser Value) Unwrap

268+unwrap f r = f (_rqUnwrap r) <&> \k -> r { _rqUnwrap = g k }

263269 where

264270 g k x = maybe (fail "Failed to extract nested keys.") return (x ^? k)

265271

266272-- | Primarily to obtain a constraint for the pagination function, as well as

267273-- the overrideable flexibility.

268274class Paginate a where

269− next :: Request a s r -> Maybe Pager -> Maybe (Request a s r)

275+ next :: Request a s b -> Maybe Pager -> Maybe (Request a s b)

270276 next _ Nothing = Nothing

271277 next rq (Just x)

272278 | x^.pgTotal == 0 = Nothing

@@ -284,6 +290,9 @@ instance FromJSON (Key a) where

284290instance ToJSON (Key a) where

285291 toJSON (Key k) = toJSON k

286292

293+instance QueryValueLike (Key a) where

294+ toQueryValue = Just . toByteString'

295+

287296type ServiceKey = Key "service"

288297type IncidentKey = Key "incident"

289298

@@ -299,6 +308,9 @@ instance FromJSON (Id a) where

299308instance ToJSON (Id a) where

300309 toJSON (Id i) = toJSON i

301310

311+instance QueryValueLike (Id a) where

312+ toQueryValue = Just . toByteString'

313+

302314type AlertId = Id "alert"

303315type PolicyId = Id "policy"

304316type RequesterId = Id "requester"