@@ -1,12 +1,10 @@
1−{-# LANGUAGE FlexibleInstances #-}
2−{-# LANGUAGE FunctionalDependencies #-}
3−{-# LANGUAGE LambdaCase #-}
4−{-# LANGUAGE MultiParamTypeClasses #-}
5−{-# LANGUAGE OverloadedStrings #-}
6−{-# LANGUAGE TemplateHaskell #-}
1+{-# LANGUAGE GADTs #-}
2+{-# LANGUAGE DefaultSignatures #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE TemplateHaskell #-}
75
86-- Module : Network.PagerDuty.Integration
9−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
7+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
108-- License : This Source Code Form is subject to the terms of
119-- the Mozilla Public License, v. 2.0.
1210-- A copy of the MPL can be found in the LICENSE file or
@@ -38,57 +36,52 @@
3836-- /See:/ <http://developer.pagerduty.com/documentation/integration/events>
3937module Network.PagerDuty.Integration
4038 (
41− -- * Sending events
39+ -- * Events
4240 submit
43− , submitWith
4441
4542 -- ** Trigger
4643 , Trigger
4744 , trigger
48− , client
49− , clientUrl
45+ , tDescription
46+ , tIncidentKey
47+ , tClient
48+ , tClientUrl
49+ , tDetails
5050
5151 -- ** Acknowledge
5252 , Acknowledge
5353 , acknowledge
54+ , aDescription
55+ , aDetails
5456
5557 -- ** Resolve
5658 , Resolve
5759 , resolve
58−
59− -- * Fields
60− , HasServiceKey (..)
61− , HasIncidentKey (..)
62− , HasDescription (..)
63− , HasDetails (..)
60+ , rDescription
61+ , rDetails
6462
6563 -- * Types
66− , Event (..)
67− , _Trigger
68− , _Acknowledge
69− , _Resolve
64+ , Event
65+ , AnyEvent (..)
7066
7167 , Response
7268 , rsStatus
7369 , rsMessage
7470 , rsIncidentKey
75−
76− , Generic
77−
78− , module Network.PagerDuty.Types
7971 ) where
8072
8173import Control.Lens
8274import Control.Monad.IO.Class
8375import Data.Aeson
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
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
8882import Network.PagerDuty.Internal.IO
8983import Network.PagerDuty.Internal.TH
9084import Network.PagerDuty.Internal.Types
91−import Network.PagerDuty.Types hiding (description, message)
9285
9386data Response = Response
9487 { _rsStatus :: Text
@@ -107,161 +100,128 @@ makeLens "_rsMessage" ''Response
107100-- | The key of the incident that will be affected by the request.
108101makeLens "_rsIncidentKey" ''Response
109102
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
143− } deriving (Eq, Show)
103+class Event a where
104+ eventType :: a -> Text
105+ eventPayload :: a -> Object
144106
145−deriveRecord ''Trigger
107+ default eventPayload :: ToJSON a => a -> Object
108+ eventPayload x = let Object o = toJSON x in o
146109
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'
110+data AnyEvent where
111+ Event :: Event a => a -> AnyEvent
151112
152−-- | The name of the monitoring client that is triggering this event.
153−client :: Lens' Trigger (Maybe Text)
154−client = tClient'
113+instance Event AnyEvent where
114+ eventType (Event x) = eventType x
115+ eventPayload (Event x) = eventPayload x
155116
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
117+data Generic = Generic
118+ { _gServiceKey :: ServiceKey
119+ , _gDescription :: Maybe Text
120+ , _gIncidentKey :: IncidentKey
121+ , _gDetails :: Object
165122 } deriving (Eq, Show)
166123
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
124+deriveJSON ''Generic
125+
126+makeLens "_gDescription" ''Generic
127+makeLens "_gDetails" ''Generic
128+
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)
137+
138+deriveJSON ''Trigger
139+
140+instance Event Trigger where
141+ eventType = const "trigger"
228142
229143-- | Your monitoring tools should send PagerDuty a trigger event to report a new
230144-- or ongoing problem. When PagerDuty receives a trigger event, it will either open
231145-- a new incident, or add a new trigger log entry to an existing incident,
232146-- depending on the provided incident_key.
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
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
245158 }
246159
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+
247192-- | Acknowledge events cause the referenced incident to enter the acknowledged
248193-- state.
249194--
250195-- While an incident is acknowledged, it won't generate any additional
251196-- notifications, even if it receives new trigger events. Your monitoring tools
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
197+-- should send PagerDuty an acknowledge event when they know someone is presently
198+-- working on the problem.
199+acknowledge :: ServiceKey -> IncidentKey -> Acknowledge
257200acknowledge k i =
258− Acknowledge Generic'
259− { _gServiceKey' = k
260− , _gIncidentKey' = i
261− , _gDescription' = Nothing
262− , _gDetails' = Nothing
201+ Acknowledge Generic
202+ { _gServiceKey = k
203+ , _gDescription = Nothing
204+ , _gIncidentKey = i
205+ , _gDetails = mempty
263206 }
264207
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+
265225-- | Resolve events cause the referenced incident to enter the resolved state.
266226--
267227-- Once an incident is resolved, it won't generate any additional
@@ -269,30 +229,30 @@ acknowledge k i =
269229-- incident won't re-open the incident. Instead, a new incident will be
270230-- created. Your monitoring tools should send PagerDuty a resolve event when the
271231-- problem that caused the initial trigger event has been fixed.
272−resolve :: ServiceKey -- ^ 'serviceKey'
273− -> IncidentKey -- ^ 'incidentKey'
274− -> Event
232+resolve :: ServiceKey -> IncidentKey -> Resolve
275233resolve k i =
276− Resolve Generic'
277− { _gServiceKey' = k
278− , _gIncidentKey' = i
279− , _gDescription' = Nothing
280− , _gDetails' = Nothing
234+ Resolve Generic
235+ { _gServiceKey = k
236+ , _gDescription = Nothing
237+ , _gIncidentKey = i
238+ , _gDetails = mempty
281239 }
282240
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+
283250-- | Send an event to the integration API.
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− }
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)