@@ -1,10 +1,12 @@
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
7−-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
9+-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
810-- License : This Source Code Form is subject to the terms of
911-- the Mozilla Public License, v. 2.0.
1012-- A copy of the MPL can be found in the LICENSE file or
@@ -36,52 +38,57 @@
3638-- /See:/ <http://developer.pagerduty.com/documentation/integration/events>
3739module Network.PagerDuty.Integration
3840 (
39− -- * Events
41+ -- * Sending events
4042 submit
43+ , submitWith
4144
4245 -- ** Trigger
4346 , Trigger
4447 , trigger
45− , tDescription
46− , tIncidentKey
47− , tClient
48− , tClientUrl
49− , tDetails
48+ , client
49+ , clientUrl
5050
5151 -- ** Acknowledge
5252 , Acknowledge
5353 , acknowledge
54− , aDescription
55− , aDetails
5654
5755 -- ** Resolve
5856 , Resolve
5957 , resolve
60− , rDescription
61− , rDetails
58+
59+ -- * Fields
60+ , HasServiceKey (..)
61+ , HasIncidentKey (..)
62+ , HasDescription (..)
63+ , HasDetails (..)
6264
6365 -- * Types
64− , Event
65− , AnyEvent (..)
66+ , Event (..)
67+ , _Trigger
68+ , _Acknowledge
69+ , _Resolve
6670
6771 , Response
6872 , rsStatus
6973 , rsMessage
7074 , rsIncidentKey
75+
76+ , Generic
77+
78+ , module Network.PagerDuty.Types
7179 ) where
7280
7381import Control.Lens
7482import Control.Monad.IO.Class
7583import Data.Aeson
76−import Data.Default.Class
77−import qualified Data.HashMap.Strict as Map
78−import Data.Monoid
79−import Data.Text (Text)
80−import Network.HTTP.Client (Manager)
81−import qualified Network.HTTP.Client as Client
84+import qualified Data.Aeson.KeyMap as Map
85+import Data.Text (Text)
86+import Network.HTTP.Client (Manager)
87+import qualified Network.HTTP.Client as Client
8288import Network.PagerDuty.Internal.IO
8389import Network.PagerDuty.Internal.TH
8490import Network.PagerDuty.Internal.Types
91+import Network.PagerDuty.Types hiding (description, message)
8592
8693data Response = Response
8794 { _rsStatus :: Text
@@ -100,128 +107,161 @@ makeLens "_rsMessage" ''Response
100107-- | The key of the incident that will be affected by the request.
101108makeLens "_rsIncidentKey" ''Response
102109
103−class Event a where
104− eventType :: a -> Text
105− eventPayload :: a -> Object
106−
107− default eventPayload :: ToJSON a => a -> Object
108− eventPayload x = let Object o = toJSON x in o
109−
110−data AnyEvent where
111− Event :: Event a => a -> AnyEvent
112−
113−instance Event AnyEvent where
114− eventType (Event x) = eventType x
115− eventPayload (Event x) = eventPayload x
116−
117−data Generic = Generic
118− { _gServiceKey :: ServiceKey
119− , _gDescription :: Maybe Text
120− , _gIncidentKey :: IncidentKey
121− , _gDetails :: Object
110+class HasServiceKey s a | s -> a where
111+ -- | The GUID of one of your "Generic API" services. This is the "service key"
112+ -- listed on a Generic API's service detail page.
113+ serviceKey :: Lens' s a
114+
115+class HasIncidentKey s a | s -> a where
116+ -- | Identifies the incident to which this trigger event should be applied.
117+ -- If there's no open (i.e. unresolved) incident with this key, a new one
118+ -- will be created. If there's already an open incident with a matching key,
119+ -- this event will be appended to that incident's log. The event key provides
120+ -- an easy way to "de-dup" problem reports. If this field isn't provided,
121+ -- PagerDuty will automatically open a new incident with a unique key.
122+ incidentKey :: Lens' s a
123+
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
130+
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
135+
136+data Trigger = Trigger'
137+ { _tServiceKey' :: ServiceKey
138+ , _tIncidentKey' :: IncidentKey
139+ , _tDescription' :: Text
140+ , _tDetails' :: Maybe Object
141+ , _tClient' :: Maybe Text
142+ , _tClientUrl' :: Maybe Text
122143 } deriving (Eq, Show)
123144
124−deriveJSON ''Generic
145+deriveRecord ''Trigger
125146
126−makeLens "_gDescription" ''Generic
127−makeLens "_gDetails" ''Generic
147+instance HasServiceKey Trigger ServiceKey where serviceKey = tServiceKey'
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'
128151
129−data Trigger = Trigger
130− { _tServiceKey :: ServiceKey
131− , _tDescription :: Text
132− , _tIncidentKey :: Maybe IncidentKey
133− , _tClient :: Maybe Text
134− , _tClientUrl :: Maybe Text
135− , _tDetails :: Object
136− } deriving (Eq, Show)
152+-- | The name of the monitoring client that is triggering this event.
153+client :: Lens' Trigger (Maybe Text)
154+client = tClient'
137155
138−deriveJSON ''Trigger
156+-- | The URL of the monitoring client that is triggering this event.
157+clientUrl :: Lens' Trigger (Maybe Text)
158+clientUrl = tClientUrl'
159+
160+data Generic = Generic'
161+ { _gServiceKey' :: ServiceKey
162+ , _gIncidentKey' :: IncidentKey
163+ , _gDescription' :: Maybe Text
164+ , _gDetails' :: Maybe Object
165+ } deriving (Eq, Show)
139166
140−instance Event Trigger where
141− eventType = const "trigger"
167+deriveRecord ''Generic
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'
173+
174+type Resolve = Generic
175+type Acknowledge = Generic
176+
177+data Event
178+ = Trigger Trigger -- ^ /See:/ 'trigger'
179+ | Acknowledge Generic -- ^ /See:/ 'acknowledge'
180+ | Resolve Generic -- ^ /See:/ 'resolve'
181+ deriving (Eq, Show)
182+
183+makePrisms ''Event
184+
185+instance HasServiceKey Event ServiceKey where
186+ serviceKey = lens f g
187+ where
188+ f (Trigger s) = _tServiceKey' s
189+ f (Acknowledge s) = _gServiceKey' s
190+ f (Resolve s) = _gServiceKey' s
191+
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 }
195+
196+instance HasIncidentKey Event IncidentKey where
197+ incidentKey = lens f g
198+ where
199+ f (Trigger s) = _tIncidentKey' s
200+ f (Acknowledge s) = _gIncidentKey' s
201+ f (Resolve s) = _gIncidentKey' s
202+
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 }
206+
207+instance HasDetails Event (Maybe Object) where
208+ details = lens f g
209+ where
210+ f (Trigger s) = _tDetails' s
211+ f (Acknowledge s) = _gDetails' s
212+ f (Resolve s) = _gDetails' s
213+
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 }
217+
218+instance ToJSON Event where
219+ toJSON = \case
220+ Trigger x -> event "trigger" x
221+ Acknowledge x -> event "acknowledge" x
222+ Resolve x -> event "resolve" x
223+ where
224+ event k x =
225+ case toJSON x of
226+ Object o -> Object (Map.insert "event_type" (String k) o)
227+ v -> v
142228
143229-- | Your monitoring tools should send PagerDuty a trigger event to report a new
144230-- or ongoing problem. When PagerDuty receives a trigger event, it will either open
145231-- a new incident, or add a new trigger log entry to an existing incident,
146232-- depending on the provided incident_key.
147−trigger :: ServiceKey
148− -> Text -- ^ 'tDescription'
149− -> Trigger
150−trigger k d =
151− Trigger
152− { _tServiceKey = k
153− , _tDescription = d
154− , _tIncidentKey = Nothing
155− , _tClient = Nothing
156− , _tClientUrl = Nothing
157− , _tDetails = mempty
233+trigger :: ServiceKey -- ^ 'serviceKey'
234+ -> IncidentKey -- ^ 'incidentKey'
235+ -> Text -- ^ 'description'
236+ -> Event
237+trigger k i d =
238+ Trigger Trigger'
239+ { _tServiceKey' = k
240+ , _tDescription' = d
241+ , _tIncidentKey' = i
242+ , _tClient' = Nothing
243+ , _tClientUrl' = Nothing
244+ , _tDetails' = Nothing
158245 }
159246
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
165−
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
173−
174−-- | The name of the monitoring client that is triggering this event.
175−makeLens "_tClient" ''Trigger
176−
177−-- | The URL of the monitoring client that is triggering this event.
178−makeLens "_tClientUrl" ''Trigger
179−
180−-- | An arbitrary JSON object containing any data you'd like included
181−-- in the incident log.
182−makeLens "_tDetails" ''Trigger
183−
184−newtype Acknowledge = Acknowledge Generic
185−
186−deriveJSON ''Acknowledge
187−makePrisms ''Acknowledge
188−
189−instance Event Acknowledge where
190− eventType = const "acknowledge"
191−
192247-- | Acknowledge events cause the referenced incident to enter the acknowledged
193248-- state.
194249--
195250-- While an incident is acknowledged, it won't generate any additional
196251-- notifications, even if it receives new trigger events. Your monitoring tools
197−-- should send PagerDuty an acknowledge event when they know someone is presently
198−-- working on the problem.
199−acknowledge :: ServiceKey -> IncidentKey -> Acknowledge
252+-- should send PagerDuty an acknowledge event when they know someone is
253+-- presently working on the problem.
254+acknowledge :: ServiceKey -- ^ 'serviceKey'
255+ -> IncidentKey -- ^ 'incidentKey'
256+ -> Event
200257acknowledge k i =
201− Acknowledge Generic
202− { _gServiceKey = k
203− , _gDescription = Nothing
204− , _gIncidentKey = i
205− , _gDetails = mempty
258+ Acknowledge Generic'
259+ { _gServiceKey' = k
260+ , _gIncidentKey' = i
261+ , _gDescription' = Nothing
262+ , _gDetails' = Nothing
206263 }
207264
208−-- | Text that will appear in the incident's log associated with this event.
209−aDescription :: Lens' Acknowledge (Maybe Text)
210−aDescription = _Acknowledge.gDescription
211−
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
216−
217−newtype Resolve = Resolve Generic
218−
219−deriveJSON ''Resolve
220−makePrisms ''Resolve
221−
222−instance Event Resolve where
223− eventType = const "acknowledge"
224−
225265-- | Resolve events cause the referenced incident to enter the resolved state.
226266--
227267-- Once an incident is resolved, it won't generate any additional
@@ -229,30 +269,30 @@ instance Event Resolve where
229269-- incident won't re-open the incident. Instead, a new incident will be
230270-- created. Your monitoring tools should send PagerDuty a resolve event when the
231271-- problem that caused the initial trigger event has been fixed.
232−resolve :: ServiceKey -> IncidentKey -> Resolve
272+resolve :: ServiceKey -- ^ 'serviceKey'
273+ -> IncidentKey -- ^ 'incidentKey'
274+ -> Event
233275resolve k i =
234− Resolve Generic
235− { _gServiceKey = k
236− , _gDescription = Nothing
237− , _gIncidentKey = i
238− , _gDetails = mempty
276+ Resolve Generic'
277+ { _gServiceKey' = k
278+ , _gIncidentKey' = i
279+ , _gDescription' = Nothing
280+ , _gDetails' = Nothing
239281 }
240282
241−-- | Text that will appear in the incident's log associated with this event.
242−rDescription :: Lens' Resolve (Maybe Text)
243−rDescription = _Resolve.gDescription
244−
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
249−
250283-- | Send an event to the integration API.
251−submit :: (MonadIO m, Event a) => Manager -> a -> m (Either Error Response)
252−submit m x = request m payload $ def
253− { Client.host = "events.pagerduty.com"
254− , Client.path = "/generic/2010-04-15/create_event.json"
255− }
256− where
257− payload = Object $
258− Map.insert "event_type" (String (eventType x)) (eventPayload x)
284+submit :: MonadIO m => Manager -> Event -> m (Either Error Response)
285+submit m = submitWith m None
286+
287+-- | /See:/ 'submit'
288+submitWith :: MonadIO m
289+ => Manager
290+ -> Logger
291+ -> Event
292+ -> m (Either Error Response)
293+submitWith m l e = request m l e $
294+ Client.defaultRequest
295+ { Client.host = "events.pagerduty.com"
296+ , Client.path = "/generic/2010-04-15/create_event.json"
297+ , Client.method = "POST"
298+ }