@@ -1,12 +1,10 @@
1−{-# LANGUAGE FlexibleInstances #-}
1+{-# LANGUAGE GADTs #-}
2−{-# LANGUAGE FunctionalDependencies #-}
2+{-# LANGUAGE DefaultSignatures #-}
3−{-# LANGUAGE LambdaCase #-}
4−{-# LANGUAGE MultiParamTypeClasses #-}
5−{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE OverloadedStrings #-}
6−{-# LANGUAGE TemplateHaskell #-}
4+{-# LANGUAGE TemplateHaskell #-}
8-- Module : Network.PagerDuty.Integration
6-- 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>
10-- License : This Source Code Form is subject to the terms of
8-- License : This Source Code Form is subject to the terms of
11-- the Mozilla Public License, v. 2.0.
9-- the Mozilla Public License, v. 2.0.
12-- A copy of the MPL can be found in the LICENSE file or
10-- A copy of the MPL can be found in the LICENSE file or
@@ -38,57 +36,52 @@
38-- /See:/ <http://developer.pagerduty.com/documentation/integration/events>
36-- /See:/ <http://developer.pagerduty.com/documentation/integration/events>
39module Network.PagerDuty.Integration
37module Network.PagerDuty.Integration
41− -- * Sending events
39+ -- * Events
45 -- ** Trigger
42 -- ** Trigger
48− , client
45+ , tDescription
49− , clientUrl
46+ , tIncidentKey
51 -- ** Acknowledge
51 -- ** Acknowledge
52 , Acknowledge
52 , Acknowledge
53 , acknowledge
53 , acknowledge
55 -- ** Resolve
57 -- ** Resolve
59− -- * Fields
61+ , rDetails
61− , HasIncidentKey (..)
62− , HasDescription (..)
65 -- * Types
63 -- * Types
66− , Event (..)
64+ , Event
67− , _Trigger
65+ , AnyEvent (..)
71 , Response
67 , Response
72 , rsStatus
68 , rsStatus
73 , rsMessage
69 , rsMessage
74 , rsIncidentKey
70 , rsIncidentKey
78− , module Network.PagerDuty.Types
81import Control.Lens
73import Control.Lens
82import Control.Monad.IO.Class
74import Control.Monad.IO.Class
83import Data.Aeson
75import Data.Aeson
76+import Data.Default.Class
84−import qualified Data.Aeson.KeyMap as Map
77+import qualified Data.HashMap.Strict as Map
85−import Data.Text (Text)
78+import Data.Monoid
79+import Data.Text (Text)
86−import Network.HTTP.Client (Manager)
80+import Network.HTTP.Client (Manager)
87−import qualified Network.HTTP.Client as Client
81+import qualified Network.HTTP.Client as Client
88import Network.PagerDuty.Internal.IO
82import Network.PagerDuty.Internal.IO
89import Network.PagerDuty.Internal.TH
83import Network.PagerDuty.Internal.TH
90import Network.PagerDuty.Internal.Types
84import Network.PagerDuty.Internal.Types
91−import Network.PagerDuty.Types hiding (description, message)
93data Response = Response
86data Response = Response
94 { _rsStatus :: Text
87 { _rsStatus :: Text
@@ -107,161 +100,128 @@ makeLens "_rsMessage" ''Response
107-- | The key of the incident that will be affected by the request.
100-- | The key of the incident that will be affected by the request.
108makeLens "_rsIncidentKey" ''Response
101makeLens "_rsIncidentKey" ''Response
110−class HasServiceKey s a | s -> a where
103+class Event a where
111− -- | The GUID of one of your "Generic API" services. This is the "service key"
104+ eventType :: a -> Text
112− -- listed on a Generic API's service detail page.
105+ eventPayload :: a -> Object
113− serviceKey :: Lens' s a
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
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'
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)
145−deriveRecord ''Trigger
107+ default eventPayload :: ToJSON a => a -> Object
108+ eventPayload x = let Object o = toJSON x in o
147−instance HasServiceKey Trigger ServiceKey where serviceKey = tServiceKey'
110+data AnyEvent where
148−instance HasIncidentKey Trigger IncidentKey where incidentKey = tIncidentKey'
111+ Event :: Event a => a -> AnyEvent
149−instance HasDescription Trigger Text where description = tDescription'
150−instance HasDetails Trigger (Maybe Object) where details = tDetails'
152−-- | The name of the monitoring client that is triggering this event.
113+instance Event AnyEvent where
153−client :: Lens' Trigger (Maybe Text)
114+ eventType (Event x) = eventType x
154−client = tClient'
115+ eventPayload (Event x) = eventPayload x
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'
117+data Generic = Generic
161− { _gServiceKey' :: ServiceKey
118+ { _gServiceKey :: ServiceKey
119+ , _gDescription :: Maybe Text
162− , _gIncidentKey' :: IncidentKey
120+ , _gIncidentKey :: IncidentKey
163− , _gDescription' :: Maybe Text
164− , _gDetails' :: Maybe Object
121+ , _gDetails :: Object
165 } deriving (Eq, Show)
122 } deriving (Eq, Show)
167−deriveRecord ''Generic
124+deriveJSON ''Generic
169−instance HasServiceKey Generic ServiceKey where serviceKey = gServiceKey'
126+makeLens "_gDescription" ''Generic
170−instance HasIncidentKey Generic IncidentKey where incidentKey = gIncidentKey'
127+makeLens "_gDetails" ''Generic
171−instance HasDescription Generic (Maybe Text) where description = gDescription'
128+
172−instance HasDetails Generic (Maybe Object) where details = gDetails'
129+data Trigger = Trigger
173−
130+ { _tServiceKey :: ServiceKey
174−type Resolve = Generic
131+ , _tDescription :: Text
175−type Acknowledge = Generic
132+ , _tIncidentKey :: Maybe IncidentKey
176−
133+ , _tClient :: Maybe Text
177−data Event
134+ , _tClientUrl :: Maybe Text
178− = Trigger Trigger -- ^ /See:/ 'trigger'
135+ , _tDetails :: Object
179− | Acknowledge Generic -- ^ /See:/ 'acknowledge'
180− | Resolve Generic -- ^ /See:/ 'resolve'
181− deriving (Eq, Show)
136+ } deriving (Eq, Show)
183−makePrisms ''Event
138+deriveJSON ''Trigger
185−instance HasServiceKey Event ServiceKey where
140+instance Event Trigger where
186− serviceKey = lens f g
141+ eventType = const "trigger"
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)
229-- | Your monitoring tools should send PagerDuty a trigger event to report a new
143-- | Your monitoring tools should send PagerDuty a trigger event to report a new
230-- or ongoing problem. When PagerDuty receives a trigger event, it will either open
144-- or ongoing problem. When PagerDuty receives a trigger event, it will either open
231-- a new incident, or add a new trigger log entry to an existing incident,
145-- a new incident, or add a new trigger log entry to an existing incident,
232-- depending on the provided incident_key.
146-- depending on the provided incident_key.
233−trigger :: ServiceKey -- ^ 'serviceKey'
147+trigger :: ServiceKey
234− -> IncidentKey -- ^ 'incidentKey'
148+ -> Text -- ^ 'tDescription'
235− -> Text -- ^ 'description'
149+ -> Trigger
237−trigger k i d =
150+trigger k d =
238− Trigger Trigger'
151+ Trigger
239− { _tServiceKey' = k
152+ { _tServiceKey = k
240− , _tDescription' = d
153+ , _tDescription = d
241− , _tIncidentKey' = i
154+ , _tIncidentKey = Nothing
242− , _tClient' = Nothing
155+ , _tClient = Nothing
243− , _tClientUrl' = Nothing
156+ , _tClientUrl = Nothing
244− , _tDetails' = Nothing
157+ , _tDetails = mempty
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"
247-- | Acknowledge events cause the referenced incident to enter the acknowledged
192-- | Acknowledge events cause the referenced incident to enter the acknowledged
250-- While an incident is acknowledged, it won't generate any additional
195-- While an incident is acknowledged, it won't generate any additional
251-- notifications, even if it receives new trigger events. Your monitoring tools
196-- notifications, even if it receives new trigger events. Your monitoring tools
252−-- should send PagerDuty an acknowledge event when they know someone is
197+-- should send PagerDuty an acknowledge event when they know someone is presently
253−-- presently working on the problem.
198+-- working on the problem.
254−acknowledge :: ServiceKey -- ^ 'serviceKey'
199+acknowledge :: ServiceKey -> IncidentKey -> Acknowledge
255− -> IncidentKey -- ^ 'incidentKey'
257acknowledge k i =
200acknowledge k i =
258− Acknowledge Generic'
201+ Acknowledge Generic
259− { _gServiceKey' = k
202+ { _gServiceKey = k
203+ , _gDescription = Nothing
260− , _gIncidentKey' = i
204+ , _gIncidentKey = i
261− , _gDescription' = Nothing
262− , _gDetails' = Nothing
205+ , _gDetails = mempty
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"
265-- | Resolve events cause the referenced incident to enter the resolved state.
225-- | Resolve events cause the referenced incident to enter the resolved state.
267-- Once an incident is resolved, it won't generate any additional
227-- Once an incident is resolved, it won't generate any additional
@@ -269,30 +229,30 @@ acknowledge k i =
269-- incident won't re-open the incident. Instead, a new incident will be
229-- incident won't re-open the incident. Instead, a new incident will be
270-- created. Your monitoring tools should send PagerDuty a resolve event when the
230-- created. Your monitoring tools should send PagerDuty a resolve event when the
271-- problem that caused the initial trigger event has been fixed.
231-- problem that caused the initial trigger event has been fixed.
272−resolve :: ServiceKey -- ^ 'serviceKey'
232+resolve :: ServiceKey -> IncidentKey -> Resolve
273− -> IncidentKey -- ^ 'incidentKey'
275resolve k i =
233resolve k i =
276− Resolve Generic'
234+ Resolve Generic
277− { _gServiceKey' = k
235+ { _gServiceKey = k
236+ , _gDescription = Nothing
278− , _gIncidentKey' = i
237+ , _gIncidentKey = i
279− , _gDescription' = Nothing
280− , _gDetails' = Nothing
238+ , _gDetails = mempty
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
283-- | Send an event to the integration API.
250-- | 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
292− -> m (Either Error Response)
251+submit :: (MonadIO m, Event a) => Manager -> a -> m (Either Error Response)
293−submitWith m l e = request m l e $
252+submit m x = request m payload $ def
294− Client.defaultRequest
295− { Client.host = "events.pagerduty.com"
253+ { Client.host = "events.pagerduty.com"
296− , Client.path = "/generic/2010-04-15/create_event.json"
254+ , Client.path = "/generic/2010-04-15/create_event.json"
297− , Client.method = "POST"
258+ Map.insert "event_type" (String (eventType x)) (eventPayload x)