@@ -1,7 +1,9 @@
1−{-# LANGUAGE GADTs #-}
2−{-# LANGUAGE DefaultSignatures #-}
3−{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE TemplateHaskell #-}
1+{-# LANGUAGE FlexibleInstances #-}
2+{-# LANGUAGE FunctionalDependencies #-}
3+{-# LANGUAGE LambdaCase #-}
4+{-# LANGUAGE MultiParamTypeClasses #-}
5+{-# LANGUAGE OverloadedStrings #-}
6+{-# LANGUAGE TemplateHaskell #-}
57
68-- Module : Network.PagerDuty.Integration
79-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
@@ -43,27 +45,28 @@ module Network.PagerDuty.Integration
4345 -- ** Trigger
4446 , Trigger
4547 , trigger
46− , tDescription
47− , tIncidentKey
48− , tClient
49− , tClientUrl
50− , tDetails
48+ , client
49+ , clientUrl
5150
5251 -- ** Acknowledge
5352 , Acknowledge
5453 , acknowledge
55− , aDescription
56− , aDetails
5754
5855 -- ** Resolve
5956 , Resolve
6057 , resolve
61− , rDescription
62− , rDetails
58+
59+ -- * Fields
60+ , HasServiceKey (..)
61+ , HasIncidentKey (..)
62+ , HasDescription (..)
63+ , HasDetails (..)
6364
6465 -- * Types
65− , Event
66− , AnyEvent (..)
66+ , Event (..)
67+ , _Trigger
68+ , _Acknowledge
69+ , _Resolve
6770
6871 , Response
6972 , rsStatus
@@ -75,11 +78,10 @@ import Control.Lens
7578import Control.Monad.IO.Class
7679import Data.Aeson
7780import Data.Default.Class
78−import qualified Data.HashMap.Strict as Map
79−import Data.Monoid
80−import Data.Text (Text)
81−import Network.HTTP.Client (Manager)
82−import qualified Network.HTTP.Client as Client
81+import qualified Data.HashMap.Strict as Map
82+import Data.Text (Text)
83+import Network.HTTP.Client (Manager)
84+import qualified Network.HTTP.Client as Client
8385import Network.PagerDuty.Internal.IO
8486import Network.PagerDuty.Internal.TH
8587import Network.PagerDuty.Internal.Types
@@ -101,128 +103,161 @@ makeLens "_rsMessage" ''Response
101103-- | The key of the incident that will be affected by the request.
102104makeLens "_rsIncidentKey" ''Response
103105
104−class Event a where
105− eventType :: a -> Text
106− eventPayload :: a -> Object
107−
108− default eventPayload :: ToJSON a => a -> Object
109− eventPayload x = let Object o = toJSON x in o
110−
111−data AnyEvent where
112− Event :: Event a => a -> AnyEvent
113−
114−instance Event AnyEvent where
115− eventType (Event x) = eventType x
116− eventPayload (Event x) = eventPayload x
117−
118−data Generic = Generic
119− { _gServiceKey :: ServiceKey
120− , _gDescription :: Maybe Text
121− , _gIncidentKey :: IncidentKey
122− , _gDetails :: Object
106+class HasServiceKey s a | s -> a where
107+ -- | The GUID of one of your "Generic API" services. This is the "service key"
108+ -- listed on a Generic API's service detail page.
109+ serviceKey :: Lens' s a
110+
111+class HasIncidentKey s a | s -> a where
112+ -- | Identifies the incident to which this trigger event should be applied.
113+ -- If there's no open (i.e. unresolved) incident with this key, a new one
114+ -- will be created. If there's already an open incident with a matching key,
115+ -- this event will be appended to that incident's log. The event key provides
116+ -- an easy way to "de-dup" problem reports. If this field isn't provided,
117+ -- PagerDuty will automatically open a new incident with a unique key.
118+ incidentKey :: Lens' s a
119+
120+class HasDescription s a | s -> a where
121+ -- | A short description of the problem that led to this trigger.
122+ -- This field (or a truncated version) will be used when generating phone
123+ -- calls, SMS messages and alert emails. It will also appear on the incidents
124+ -- tables in the PagerDuty UI. The maximum length is 1024 characters.
125+ description :: Lens' s a
126+
127+class HasDetails s a | s -> a where
128+ -- | An arbitrary JSON object containing any data you'd like included
129+ -- in the incident log.
130+ details :: Lens' s a
131+
132+data Trigger = Trigger'
133+ { _tServiceKey' :: ServiceKey
134+ , _tIncidentKey' :: IncidentKey
135+ , _tDescription' :: Text
136+ , _tDetails' :: Maybe Object
137+ , _tClient' :: Maybe Text
138+ , _tClientUrl' :: Maybe Text
123139 } deriving (Eq, Show)
124140
125−deriveJSON ''Generic
141+deriveRecord ''Trigger
126142
127−makeLens "_gDescription" ''Generic
128−makeLens "_gDetails" ''Generic
143+instance HasServiceKey Trigger ServiceKey where serviceKey = tServiceKey'
144+instance HasIncidentKey Trigger IncidentKey where incidentKey = tIncidentKey'
145+instance HasDescription Trigger Text where description = tDescription'
146+instance HasDetails Trigger (Maybe Object) where details = tDetails'
129147
130−data Trigger = Trigger
131− { _tServiceKey :: ServiceKey
132− , _tDescription :: Text
133− , _tIncidentKey :: Maybe IncidentKey
134− , _tClient :: Maybe Text
135− , _tClientUrl :: Maybe Text
136− , _tDetails :: Object
137− } deriving (Eq, Show)
148+-- | The name of the monitoring client that is triggering this event.
149+client :: Lens' Trigger (Maybe Text)
150+client = tClient'
138151
139−deriveJSON ''Trigger
152+-- | The URL of the monitoring client that is triggering this event.
153+clientUrl :: Lens' Trigger (Maybe Text)
154+clientUrl = tClientUrl'
155+
156+data Generic = Generic'
157+ { _gServiceKey' :: ServiceKey
158+ , _gIncidentKey' :: IncidentKey
159+ , _gDescription' :: Maybe Text
160+ , _gDetails' :: Maybe Object
161+ } deriving (Eq, Show)
140162
141−instance Event Trigger where
142− eventType = const "trigger"
163+deriveRecord ''Generic
164+
165+instance HasServiceKey Generic ServiceKey where serviceKey = gServiceKey'
166+instance HasIncidentKey Generic IncidentKey where incidentKey = gIncidentKey'
167+instance HasDescription Generic (Maybe Text) where description = gDescription'
168+instance HasDetails Generic (Maybe Object) where details = gDetails'
169+
170+type Resolve = Generic
171+type Acknowledge = Generic
172+
173+data Event
174+ = Trigger Trigger -- ^ /See:/ 'trigger'
175+ | Acknowledge Generic -- ^ /See:/ 'acknowledge'
176+ | Resolve Generic -- ^ /See:/ 'resolve'
177+ deriving (Eq, Show)
178+
179+makePrisms ''Event
180+
181+instance HasServiceKey Event ServiceKey where
182+ serviceKey = lens f g
183+ where
184+ f (Trigger s) = _tServiceKey' s
185+ f (Acknowledge s) = _gServiceKey' s
186+ f (Resolve s) = _gServiceKey' s
187+
188+ g (Trigger s) x = Trigger $ s { _tServiceKey' = x }
189+ g (Acknowledge s) x = Acknowledge $ s { _gServiceKey' = x }
190+ g (Resolve s) x = Resolve $ s { _gServiceKey' = x }
191+
192+instance HasIncidentKey Event IncidentKey where
193+ incidentKey = lens f g
194+ where
195+ f (Trigger s) = _tIncidentKey' s
196+ f (Acknowledge s) = _gIncidentKey' s
197+ f (Resolve s) = _gIncidentKey' s
198+
199+ g (Trigger s) x = Trigger $ s { _tIncidentKey' = x }
200+ g (Acknowledge s) x = Acknowledge $ s { _gIncidentKey' = x }
201+ g (Resolve s) x = Resolve $ s { _gIncidentKey' = x }
202+
203+instance HasDetails Event (Maybe Object) where
204+ details = lens f g
205+ where
206+ f (Trigger s) = _tDetails' s
207+ f (Acknowledge s) = _gDetails' s
208+ f (Resolve s) = _gDetails' s
209+
210+ g (Trigger s) x = Trigger $ s { _tDetails' = x }
211+ g (Acknowledge s) x = Acknowledge $ s { _gDetails' = x }
212+ g (Resolve s) x = Resolve $ s { _gDetails' = x }
213+
214+instance ToJSON Event where
215+ toJSON = \case
216+ Trigger x -> event "trigger" x
217+ Acknowledge x -> event "acknowledge" x
218+ Resolve x -> event "resolve" x
219+ where
220+ event k x =
221+ case toJSON x of
222+ Object o -> Object (Map.insert "event_type" (String k) o)
223+ v -> v
143224
144225-- | Your monitoring tools should send PagerDuty a trigger event to report a new
145226-- or ongoing problem. When PagerDuty receives a trigger event, it will either open
146227-- a new incident, or add a new trigger log entry to an existing incident,
147228-- depending on the provided incident_key.
148−trigger :: ServiceKey
149− -> Text -- ^ 'tDescription'
150− -> Trigger
151−trigger k d =
152− Trigger
153− { _tServiceKey = k
154− , _tDescription = d
155− , _tIncidentKey = Nothing
156− , _tClient = Nothing
157− , _tClientUrl = Nothing
158− , _tDetails = mempty
229+trigger :: ServiceKey -- ^ 'serviceKey'
230+ -> IncidentKey -- ^ 'incidentKey'
231+ -> Text -- ^ 'description'
232+ -> Event
233+trigger k i d =
234+ Trigger Trigger'
235+ { _tServiceKey' = k
236+ , _tDescription' = d
237+ , _tIncidentKey' = i
238+ , _tClient' = Nothing
239+ , _tClientUrl' = Nothing
240+ , _tDetails' = Nothing
159241 }
160242
161−-- | A short description of the problem that led to this trigger.
162−-- This field (or a truncated version) will be used when generating phone
163−-- calls, SMS messages and alert emails. It will also appear on the incidents
164−-- tables in the PagerDuty UI. The maximum length is 1024 characters.
165−makeLens "_tDescription" ''Trigger
166−
167−-- | Identifies the incident to which this trigger event should be applied.
168−-- If there's no open (i.e. unresolved) incident with this key, a new one
169−-- will be created. If there's already an open incident with a matching key,
170−-- this event will be appended to that incident's log. The event key provides
171−-- an easy way to "de-dup" problem reports. If this field isn't provided,
172−-- PagerDuty will automatically open a new incident with a unique key.
173−makeLens "_tIncidentKey" ''Trigger
174−
175−-- | The name of the monitoring client that is triggering this event.
176−makeLens "_tClient" ''Trigger
177−
178−-- | The URL of the monitoring client that is triggering this event.
179−makeLens "_tClientUrl" ''Trigger
180−
181−-- | An arbitrary JSON object containing any data you'd like included
182−-- in the incident log.
183−makeLens "_tDetails" ''Trigger
184−
185−newtype Acknowledge = Acknowledge Generic
186−
187−deriveJSON ''Acknowledge
188−makePrisms ''Acknowledge
189−
190−instance Event Acknowledge where
191− eventType = const "acknowledge"
192−
193243-- | Acknowledge events cause the referenced incident to enter the acknowledged
194244-- state.
195245--
196246-- While an incident is acknowledged, it won't generate any additional
197247-- notifications, even if it receives new trigger events. Your monitoring tools
198−-- should send PagerDuty an acknowledge event when they know someone is presently
199−-- working on the problem.
200−acknowledge :: ServiceKey -> IncidentKey -> Acknowledge
248+-- should send PagerDuty an acknowledge event when they know someone is
249+-- presently working on the problem.
250+acknowledge :: ServiceKey -- ^ 'serviceKey'
251+ -> IncidentKey -- ^ 'incidentKey'
252+ -> Event
201253acknowledge k i =
202− Acknowledge Generic
203− { _gServiceKey = k
204− , _gDescription = Nothing
205− , _gIncidentKey = i
206− , _gDetails = mempty
254+ Acknowledge Generic'
255+ { _gServiceKey' = k
256+ , _gIncidentKey' = i
257+ , _gDescription' = Nothing
258+ , _gDetails' = Nothing
207259 }
208260
209−-- | Text that will appear in the incident's log associated with this event.
210−aDescription :: Lens' Acknowledge (Maybe Text)
211−aDescription = _Acknowledge.gDescription
212−
213−-- | An arbitrary JSON object containing any data you'd like included
214−-- in the incident log.
215−aDetails :: Lens' Acknowledge Object
216−aDetails = _Acknowledge.gDetails
217−
218−newtype Resolve = Resolve Generic
219−
220−deriveJSON ''Resolve
221−makePrisms ''Resolve
222−
223−instance Event Resolve where
224− eventType = const "acknowledge"
225−
226261-- | Resolve events cause the referenced incident to enter the resolved state.
227262--
228263-- Once an incident is resolved, it won't generate any additional
@@ -230,40 +265,28 @@ instance Event Resolve where
230265-- incident won't re-open the incident. Instead, a new incident will be
231266-- created. Your monitoring tools should send PagerDuty a resolve event when the
232267-- problem that caused the initial trigger event has been fixed.
233−resolve :: ServiceKey -> IncidentKey -> Resolve
268+resolve :: ServiceKey -- ^ 'serviceKey'
269+ -> IncidentKey -- ^ 'incidentKey'
270+ -> Event
234271resolve k i =
235− Resolve Generic
236− { _gServiceKey = k
237− , _gDescription = Nothing
238− , _gIncidentKey = i
239− , _gDetails = mempty
272+ Resolve Generic'
273+ { _gServiceKey' = k
274+ , _gIncidentKey' = i
275+ , _gDescription' = Nothing
276+ , _gDetails' = Nothing
240277 }
241278
242−-- | Text that will appear in the incident's log associated with this event.
243−rDescription :: Lens' Resolve (Maybe Text)
244−rDescription = _Resolve.gDescription
245−
246−-- | An arbitrary JSON object containing any data youd like included
247−-- in the incident log.
248−rDetails :: Lens' Resolve Object
249−rDetails = _Resolve.gDetails
250−
251279-- | Send an event to the integration API.
252−submit :: (MonadIO m, Event a)
253− => Manager
254− -> a
255− -> m (Either Error Response)
280+submit :: MonadIO m => Manager -> Event -> m (Either Error Response)
256281submit m = submitWith m None
257282
258283-- | /See:/ 'submit'
259−submitWith :: (MonadIO m, Event a)
284+submitWith :: MonadIO m
260285 => Manager
261286 -> Logger
262− -> a
287+ -> Event
263288 -> m (Either Error Response)
264−submitWith m l x = request m l (Object payload) $ def
265− { Client.host = "events.pagerduty.com"
266− , Client.path = "/generic/2010-04-15/create_event.json"
267− }
268− where
269− payload = Map.insert "event_type" (String (eventType x)) (eventPayload x)
289+submitWith m l e = request m l e $
290+ def { Client.host = "events.pagerduty.com"
291+ , Client.path = "/generic/2010-04-15/create_event.json"
292+ }