@@ -1,10 +1,12 @@
1−{-# LANGUAGE GADTs #-}
1+{-# LANGUAGE FlexibleInstances #-}
2−{-# LANGUAGE DefaultSignatures #-}
2+{-# LANGUAGE FunctionalDependencies #-}
3+{-# LANGUAGE LambdaCase #-}
4+{-# LANGUAGE MultiParamTypeClasses #-}
3−{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE TemplateHaskell #-}
6+{-# LANGUAGE TemplateHaskell #-}
6-- Module : Network.PagerDuty.Integration
8-- Module : Network.PagerDuty.Integration
7−-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
9+-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
8-- License : This Source Code Form is subject to the terms of
10-- License : This Source Code Form is subject to the terms of
9-- the Mozilla Public License, v. 2.0.
11-- the Mozilla Public License, v. 2.0.
10-- A copy of the MPL can be found in the LICENSE file or
12-- A copy of the MPL can be found in the LICENSE file or
@@ -36,52 +38,57 @@
36-- /See:/ <http://developer.pagerduty.com/documentation/integration/events>
38-- /See:/ <http://developer.pagerduty.com/documentation/integration/events>
37module Network.PagerDuty.Integration
39module Network.PagerDuty.Integration
39− -- * Events
41+ -- * Sending events
42 -- ** Trigger
45 -- ** Trigger
45− , tDescription
48+ , client
46− , tIncidentKey
49+ , clientUrl
51 -- ** Acknowledge
51 -- ** Acknowledge
52 , Acknowledge
52 , Acknowledge
53 , acknowledge
53 , acknowledge
57 -- ** Resolve
55 -- ** Resolve
61− , rDetails
59+ -- * Fields
61+ , HasIncidentKey (..)
62+ , HasDescription (..)
63 -- * Types
65 -- * Types
64− , Event
66+ , Event (..)
65− , AnyEvent (..)
67+ , _Trigger
67 , Response
71 , Response
68 , rsStatus
72 , rsStatus
69 , rsMessage
73 , rsMessage
70 , rsIncidentKey
74 , rsIncidentKey
78+ , module Network.PagerDuty.Types
73import Control.Lens
81import Control.Lens
74import Control.Monad.IO.Class
82import Control.Monad.IO.Class
75import Data.Aeson
83import Data.Aeson
76−import Data.Default.Class
77−import qualified Data.HashMap.Strict as Map
84+import qualified Data.Aeson.KeyMap as Map
78−import Data.Monoid
85+import Data.Text (Text)
79−import Data.Text (Text)
80−import Network.HTTP.Client (Manager)
86+import Network.HTTP.Client (Manager)
81−import qualified Network.HTTP.Client as Client
87+import qualified Network.HTTP.Client as Client
82−import Network.PagerDuty.IO
88+import Network.PagerDuty.Internal.IO
83−import Network.PagerDuty.TH
89+import Network.PagerDuty.Internal.TH
84−import Network.PagerDuty.Types
90+import Network.PagerDuty.Internal.Types
91+import Network.PagerDuty.Types hiding (description, message)
86data Response = Response
93data Response = Response
87 { _rsStatus :: Text
94 { _rsStatus :: Text
@@ -100,128 +107,161 @@ makeLens "_rsMessage" ''Response
100-- | The key of the incident that will be affected by the request.
107-- | The key of the incident that will be affected by the request.
101makeLens "_rsIncidentKey" ''Response
108makeLens "_rsIncidentKey" ''Response
103−class Event a where
110+class HasServiceKey s a | s -> a where
104− eventType :: a -> Text
111+ -- | The GUID of one of your "Generic API" services. This is the "service key"
105− eventPayload :: a -> Object
112+ -- listed on a Generic API's service detail page.
106−
113+ serviceKey :: Lens' s a
107− default eventPayload :: ToJSON a => a -> Object
114+
108− eventPayload x = let Object o = toJSON x in o
115+class HasIncidentKey s a | s -> a where
109−
116+ -- | Identifies the incident to which this trigger event should be applied.
110−data AnyEvent where
117+ -- If there's no open (i.e. unresolved) incident with this key, a new one
111− Event :: Event a => a -> AnyEvent
118+ -- will be created. If there's already an open incident with a matching key,
112−
119+ -- this event will be appended to that incident's log. The event key provides
113−instance Event AnyEvent where
120+ -- an easy way to "de-dup" problem reports. If this field isn't provided,
114− eventType (Event x) = eventType x
121+ -- PagerDuty will automatically open a new incident with a unique key.
115− eventPayload (Event x) = eventPayload x
122+ incidentKey :: Lens' s a
117−data Generic = Generic
124+class HasDescription s a | s -> a where
125+ -- | A short description of the problem that led to this trigger.
126+ -- This field (or a truncated version) will be used when generating phone
127+ -- calls, SMS messages and alert emails. It will also appear on the incidents
128+ -- tables in the PagerDuty UI. The maximum length is 1024 characters.
129+ description :: Lens' s a
131+class HasDetails s a | s -> a where
132+ -- | An arbitrary JSON object containing any data you'd like included
133+ -- in the incident log.
134+ details :: Lens' s a
136+data Trigger = Trigger'
118− { _gServiceKey :: ServiceKey
137+ { _tServiceKey' :: ServiceKey
119− , _gDescription :: Maybe Text
120− , _gIncidentKey :: IncidentKey
138+ , _tIncidentKey' :: IncidentKey
121− , _gDetails :: Object
139+ , _tDescription' :: Text
140+ , _tDetails' :: Maybe Object
141+ , _tClient' :: Maybe Text
142+ , _tClientUrl' :: Maybe Text
122 } deriving (Eq, Show)
143 } deriving (Eq, Show)
124−deriveJSON ''Generic
145+deriveRecord ''Trigger
126−makeLens "_gDescription" ''Generic
147+instance HasServiceKey Trigger ServiceKey where serviceKey = tServiceKey'
127−makeLens "_gDetails" ''Generic
148+instance HasIncidentKey Trigger IncidentKey where incidentKey = tIncidentKey'
149+instance HasDescription Trigger Text where description = tDescription'
150+instance HasDetails Trigger (Maybe Object) where details = tDetails'
129−data Trigger = Trigger
152+-- | The name of the monitoring client that is triggering this event.
130− { _tServiceKey :: ServiceKey
153+client :: Lens' Trigger (Maybe Text)
131− , _tDescription :: Text
154+client = tClient'
132− , _tIncidentKey :: Maybe IncidentKey
133− , _tClient :: Maybe Text
134− , _tClientUrl :: Maybe Text
135− , _tDetails :: Object
136− } deriving (Eq, Show)
138−deriveJSON ''Trigger
156+-- | The URL of the monitoring client that is triggering this event.
157+clientUrl :: Lens' Trigger (Maybe Text)
158+clientUrl = tClientUrl'
160+data Generic = Generic'
161+ { _gServiceKey' :: ServiceKey
162+ , _gIncidentKey' :: IncidentKey
163+ , _gDescription' :: Maybe Text
164+ , _gDetails' :: Maybe Object
165+ } deriving (Eq, Show)
140−instance Event Trigger where
167+deriveRecord ''Generic
141− eventType = const "trigger"
168+
169+instance HasServiceKey Generic ServiceKey where serviceKey = gServiceKey'
170+instance HasIncidentKey Generic IncidentKey where incidentKey = gIncidentKey'
171+instance HasDescription Generic (Maybe Text) where description = gDescription'
172+instance HasDetails Generic (Maybe Object) where details = gDetails'
174+type Resolve = Generic
175+type Acknowledge = Generic
178+ = Trigger Trigger -- ^ /See:/ 'trigger'
179+ | Acknowledge Generic -- ^ /See:/ 'acknowledge'
180+ | Resolve Generic -- ^ /See:/ 'resolve'
185+instance HasServiceKey Event ServiceKey where
186+ serviceKey = lens f g
188+ f (Trigger s) = _tServiceKey' s
189+ f (Acknowledge s) = _gServiceKey' s
190+ f (Resolve s) = _gServiceKey' s
192+ g (Trigger s) x = Trigger $ s { _tServiceKey' = x }
193+ g (Acknowledge s) x = Acknowledge $ s { _gServiceKey' = x }
194+ g (Resolve s) x = Resolve $ s { _gServiceKey' = x }
196+instance HasIncidentKey Event IncidentKey where
197+ incidentKey = lens f g
199+ f (Trigger s) = _tIncidentKey' s
200+ f (Acknowledge s) = _gIncidentKey' s
201+ f (Resolve s) = _gIncidentKey' s
203+ g (Trigger s) x = Trigger $ s { _tIncidentKey' = x }
204+ g (Acknowledge s) x = Acknowledge $ s { _gIncidentKey' = x }
205+ g (Resolve s) x = Resolve $ s { _gIncidentKey' = x }
207+instance HasDetails Event (Maybe Object) where
210+ f (Trigger s) = _tDetails' s
211+ f (Acknowledge s) = _gDetails' s
212+ f (Resolve s) = _gDetails' s
214+ g (Trigger s) x = Trigger $ s { _tDetails' = x }
215+ g (Acknowledge s) x = Acknowledge $ s { _gDetails' = x }
216+ g (Resolve s) x = Resolve $ s { _gDetails' = x }
218+instance ToJSON Event where
220+ Trigger x -> event "trigger" x
221+ Acknowledge x -> event "acknowledge" x
222+ Resolve x -> event "resolve" x
226+ Object o -> Object (Map.insert "event_type" (String k) o)
143-- | Your monitoring tools should send PagerDuty a trigger event to report a new
229-- | Your monitoring tools should send PagerDuty a trigger event to report a new
144-- or ongoing problem. When PagerDuty receives a trigger event, it will either open
230-- or ongoing problem. When PagerDuty receives a trigger event, it will either open
145-- a new incident, or add a new trigger log entry to an existing incident,
231-- a new incident, or add a new trigger log entry to an existing incident,
146-- depending on the provided incident_key.
232-- depending on the provided incident_key.
147−trigger :: ServiceKey
233+trigger :: ServiceKey -- ^ 'serviceKey'
148− -> Text -- ^ 'tDescription'
234+ -> IncidentKey -- ^ 'incidentKey'
149− -> Trigger
235+ -> Text -- ^ 'description'
150−trigger k d =
237+trigger k i d =
151− Trigger
238+ Trigger Trigger'
152− { _tServiceKey = k
239+ { _tServiceKey' = k
153− , _tDescription = d
240+ , _tDescription' = d
154− , _tIncidentKey = Nothing
241+ , _tIncidentKey' = i
155− , _tClient = Nothing
242+ , _tClient' = Nothing
156− , _tClientUrl = Nothing
243+ , _tClientUrl' = Nothing
157− , _tDetails = mempty
244+ , _tDetails' = Nothing
160−-- | A short description of the problem that led to this trigger.
161−-- This field (or a truncated version) will be used when generating phone
162−-- calls, SMS messages and alert emails. It will also appear on the incidents
163−-- tables in the PagerDuty UI. The maximum length is 1024 characters.
164−makeLens "_tDescription" ''Trigger
166−-- | Identifies the incident to which this trigger event should be applied.
167−-- If there's no open (i.e. unresolved) incident with this key, a new one
168−-- will be created. If there's already an open incident with a matching key,
169−-- this event will be appended to that incident's log. The event key provides
170−-- an easy way to "de-dup" problem reports. If this field isn't provided,
171−-- PagerDuty will automatically open a new incident with a unique key.
172−makeLens "_tIncidentKey" ''Trigger
174−-- | The name of the monitoring client that is triggering this event.
175−makeLens "_tClient" ''Trigger
177−-- | The URL of the monitoring client that is triggering this event.
178−makeLens "_tClientUrl" ''Trigger
180−-- | An arbitrary JSON object containing any data you'd like included
181−-- in the incident log.
182−makeLens "_tDetails" ''Trigger
184−newtype Acknowledge = Acknowledge Generic
186−deriveJSON ''Acknowledge
187−makePrisms ''Acknowledge
189−instance Event Acknowledge where
190− eventType = const "acknowledge"
192-- | Acknowledge events cause the referenced incident to enter the acknowledged
247-- | Acknowledge events cause the referenced incident to enter the acknowledged
195-- While an incident is acknowledged, it won't generate any additional
250-- While an incident is acknowledged, it won't generate any additional
196-- notifications, even if it receives new trigger events. Your monitoring tools
251-- notifications, even if it receives new trigger events. Your monitoring tools
197−-- should send PagerDuty an acknowledge event when they know someone is presently
252+-- should send PagerDuty an acknowledge event when they know someone is
198−-- working on the problem.
253+-- presently working on the problem.
199−acknowledge :: ServiceKey -> IncidentKey -> Acknowledge
254+acknowledge :: ServiceKey -- ^ 'serviceKey'
255+ -> IncidentKey -- ^ 'incidentKey'
200acknowledge k i =
257acknowledge k i =
201− Acknowledge Generic
258+ Acknowledge Generic'
202− { _gServiceKey = k
259+ { _gServiceKey' = k
203− , _gDescription = Nothing
204− , _gIncidentKey = i
260+ , _gIncidentKey' = i
261+ , _gDescription' = Nothing
205− , _gDetails = mempty
262+ , _gDetails' = Nothing
208−-- | Text that will appear in the incident's log associated with this event.
209−aDescription :: Lens' Acknowledge (Maybe Text)
210−aDescription = _Acknowledge.gDescription
212−-- | An arbitrary JSON object containing any data you'd like included
213−-- in the incident log.
214−aDetails :: Lens' Acknowledge Object
215−aDetails = _Acknowledge.gDetails
217−newtype Resolve = Resolve Generic
222−instance Event Resolve where
223− eventType = const "acknowledge"
225-- | Resolve events cause the referenced incident to enter the resolved state.
265-- | Resolve events cause the referenced incident to enter the resolved state.
227-- Once an incident is resolved, it won't generate any additional
267-- Once an incident is resolved, it won't generate any additional
@@ -229,30 +269,30 @@ instance Event Resolve where
229-- incident won't re-open the incident. Instead, a new incident will be
269-- incident won't re-open the incident. Instead, a new incident will be
230-- created. Your monitoring tools should send PagerDuty a resolve event when the
270-- created. Your monitoring tools should send PagerDuty a resolve event when the
231-- problem that caused the initial trigger event has been fixed.
271-- problem that caused the initial trigger event has been fixed.
232−resolve :: ServiceKey -> IncidentKey -> Resolve
272+resolve :: ServiceKey -- ^ 'serviceKey'
273+ -> IncidentKey -- ^ 'incidentKey'
233resolve k i =
275resolve k i =
234− Resolve Generic
276+ Resolve Generic'
235− { _gServiceKey = k
277+ { _gServiceKey' = k
236− , _gDescription = Nothing
237− , _gIncidentKey = i
278+ , _gIncidentKey' = i
279+ , _gDescription' = Nothing
238− , _gDetails = mempty
280+ , _gDetails' = Nothing
241−-- | Text that will appear in the incident's log associated with this event.
242−rDescription :: Lens' Resolve (Maybe Text)
243−rDescription = _Resolve.gDescription
245−-- | An arbitrary JSON object containing any data youd like included
246−-- in the incident log.
247−rDetails :: Lens' Resolve Object
248−rDetails = _Resolve.gDetails
250-- | Send an event to the integration API.
283-- | Send an event to the integration API.
284+submit :: MonadIO m => Manager -> Event -> m (Either Error Response)
285+submit m = submitWith m None
288+submitWith :: MonadIO m
251−submit :: (MonadIO m, Event a) => Manager -> a -> m (Either Error Response)
292+ -> m (Either Error Response)
252−submit m x = request m payload $ def
293+submitWith m l e = request m l e $
294+ Client.defaultRequest
253− { Client.host = "events.pagerduty.com"
295+ { Client.host = "events.pagerduty.com"
254− , Client.path = "/generic/2010-04-15/create_event.json"
296+ , Client.path = "/generic/2010-04-15/create_event.json"
297+ , Client.method = "POST"
258− Map.insert "event_type" (String (eventType x)) (eventPayload x)