git.iko.soy/typeable/pagerduty
on 0016b92 help sign in
5ad1d87
swap
0 ahead, 120 behind
.gitignore−1
since splitsnapshots
unifiedsplit
@@ -9,7 +9,6 @@
9cabal.sandbox.config
9cabal.sandbox.config
10
10
11# Dirs
11# Dirs
12−.stack-work
13cabal-dev
12cabal-dev
14bin
13bin
15dist
14dist
.travis.ymldeleted−30
@@ -1,30 +0,0 @@
1−sudo: false
2−
3−cache:
4− apt: true
5− directories:
6− - ~/.stack
7−
8−branches:
9− only:
10− - master
11− - develop
12−
13−before_install:
14− - export PATH=/opt/ghc/$GHCVER/bin:$PATH
15− - export PATH=~/.local/bin:$PATH
16− - ./script/travis-lifecycle-before_install
17−
18−install:
19− - ./script/travis-lifecycle-install
20−
21−script:
22− - ./script/travis-lifecycle-script
23−
24−matrix:
25− fast_finish: true
26− include:
27− - env: GHCVER=8.0.1
28− addons: { apt: { packages: [ghc-8.0.1], sources: [hvr-ghc] } }
29− - env: GHCVER=7.10.3
30− addons: { apt: { packages: [ghc-7.10.3], sources: [hvr-ghc] } }
Makefilenew file+17
@@ -0,0 +1,17 @@
1+FLAGS := -j --disable-documentation --disable-library-coverage
2+
3+build:
4+ cabal build $(addprefix -,$(findstring j,$(MAKEFLAGS)))
5+
6+install: cabal.sandbox.config
7+ cabal install $(FLAGS) --only-dependencies
8+
9+clean:
10+ cabal clean
11+ rm -rf cabal.sandbox.config .cabal-sandbox
12+
13+doc:
14+ cabal haddock
15+
16+cabal.sandbox.config:
17+ cabal sandbox init
README.md−14
@@ -1,14 +0,0 @@
1−# PagerDuty
2−
3−[![Build Status](https://travis-ci.org/brendanhay/amazonka.svg?branch=develop)](https://travis-ci.org/brendanhay/pagerduty)
4−
5−* [Contribute](#contribute)
6−* [Licence](#licence)
7−
8−## Contribute
9−
10−For any problems, comments, or feedback please create an issue [here on GitHub](https://github.com/brendanhay/pagerduty/issues).
11−
12−## Licence
13−
14−PagerDuty is released under the [Mozilla Public License Version 2.0](http://www.mozilla.org/MPL/).
pagerduty.cabal+29−52
@@ -1,32 +1,20 @@
1name: pagerduty
1name: pagerduty
2−version: 0.0.8
2+version: 0.1.0
3−synopsis: Client library for PagerDuty Integration and REST APIs.
3+synopsis: Pager Duty API Client
4homepage: http://github.com/brendanhay/pagerduty
4homepage: http://github.com/brendanhay/pagerduty
5license: OtherLicense
5license: OtherLicense
6license-file: LICENSE
6license-file: LICENSE
7−author: Brendan Hay
7+author: Brendan Hay, Kim Altintop
8−maintainer: Brendan Hay <brendan.g.hay@gmail.com>
8+maintainer: Brendan Hay <brendan.g.hay@gmail.com>, Kim Altintop <kim.altintop@gmail.com>
9−copyright: Copyright (c) 2013-2015 Brendan Hay, 2014 Kim Altintop
9+copyright: Copyright (c) 2013-2014 Brendan Hay, 2014 Kim Altintop
10−category: Network, PagerDuty, Monitoring
10+category: Network, Monitoring
11build-type: Simple
11build-type: Simple
12cabal-version: >= 1.10
12cabal-version: >= 1.10
13
13
14description:
14description:
15− PagerDuty is an alerting system for IT professionals. PagerDuty connects
15+ Simple API client that wraps the PagerDuty REST APIs documented here:
16− with a variety of systems (including monitoring tools and ticketing
17− systems) and dispatches alerts via automated phone call, SMS and email.
18−
19− This library implements the full PagerDuty Integration and REST APIs which
20− are documented here:
21− .
22− * Integration API - <http://developer.pagerduty.com/documentation/integration>
23− .
24− * REST API - <http://developer.pagerduty.com/documentation/rest>
25 .
16 .
26− /Warning:/ This is an experimental preview release which is still under
17+ * Integration API - <http://developer.pagerduty.com/documentation/integration/events>
27− heavy development and not intended for public consumption, caveat emptor!
28− .
29− /Note:/ An alternative source for Haddock documentation can be found <http://brendanhay.nz/pagerduty here>.
30
18
31extra-source-files:
19extra-source-files:
32 README.md
20 README.md
@@ -47,51 +35,40 @@ library
47 , Network.PagerDuty.REST
35 , Network.PagerDuty.REST
48 , Network.PagerDuty.REST.Alerts
36 , Network.PagerDuty.REST.Alerts
49 , Network.PagerDuty.REST.EscalationPolicies
37 , Network.PagerDuty.REST.EscalationPolicies
50− , Network.PagerDuty.REST.EscalationPolicies.EscalationRules
51 , Network.PagerDuty.REST.Incidents
38 , Network.PagerDuty.REST.Incidents
52− , Network.PagerDuty.REST.Incidents.Notes
53 , Network.PagerDuty.REST.LogEntries
39 , Network.PagerDuty.REST.LogEntries
54 , Network.PagerDuty.REST.MaintenanceWindows
40 , Network.PagerDuty.REST.MaintenanceWindows
55 , Network.PagerDuty.REST.Reports
41 , Network.PagerDuty.REST.Reports
56 , Network.PagerDuty.REST.Schedules
42 , Network.PagerDuty.REST.Schedules
57− , Network.PagerDuty.REST.Schedules.Overrides
58 , Network.PagerDuty.REST.Services
43 , Network.PagerDuty.REST.Services
59− , Network.PagerDuty.REST.Services.EmailFilters
60 , Network.PagerDuty.REST.Users
44 , Network.PagerDuty.REST.Users
61− , Network.PagerDuty.REST.Users.ContactMethods
62− , Network.PagerDuty.REST.Users.NotificationRules
63 , Network.PagerDuty.REST.Webhooks
45 , Network.PagerDuty.REST.Webhooks
64
46
65 other-modules:
47 other-modules:
66− Network.PagerDuty.Internal.IO
48+ Network.PagerDuty.IO
67− , Network.PagerDuty.Internal.Options
49+ , Network.PagerDuty.TH
68− , Network.PagerDuty.Internal.Query
69− , Network.PagerDuty.Internal.TH
70− , Network.PagerDuty.Internal.Types
71 , Network.PagerDuty.Types
50 , Network.PagerDuty.Types
72
51
73 build-depends:
52 build-depends:
74− aeson >= 2.0
53+ aeson >= 0.8 && < 1.0
75− , base >= 4.7 && < 5
54+ , base >= 4.5 && < 5.0
76− , bifunctors >= 4.1
55+-- , base64-bytestring >= 1.0 && < 1.1
77− , bytestring >= 0.9
56+ , bytestring >= 0.9 && < 1.0
78 , bytestring-conversion >= 0.2.1
57 , bytestring-conversion >= 0.2.1
79− , conduit > 1.1
58+ , conduit >= 0.5.5
80− , data-default-class >= 0.0.1
59+ , mmorph >= 1.0
60+
81 , exceptions >= 0.6
61 , exceptions >= 0.6
82− , generics-sop >= 0.5.0.0
62+ , data-default >= 0.5
83− , http-client >= 0.5 && < 1
63+ , http-client >= 0.3.6 && < 0.5
84− , http-types >= 0.8
64+ , http-types >= 0.8 && < 1.0
85− , lens >= 4.4
65+ , lens >= 4.0 && < 5.0
86− , lens-aeson >= 1
66+ , lens-aeson >= 1.0
87− , mmorph >= 1
88− , monad-control >= 1
89− , mtl >= 2.1.3.1
67+ , mtl >= 2.2.1 && < 3.0
90− , template-haskell >= 2.2
91− , text >= 1.1
68+ , text >= 1.1 && < 2.0
92− , time >= 1.2
69+ , time >= 1.4 && < 2.0
93− , time-locale-compat >= 0.1.0.1
94− , transformers >= 0.2
95− , transformers-compat >= 0.3
70+ , transformers >= 0.3 && < 0.5
96− , transformers-base >= 0.4.2
97 , unordered-containers >= 0.2.3
71 , unordered-containers >= 0.2.3
72+
73+ , transformers-base
74+ , monad-control
script/travis-lifecycle-before_installdeleted−11
@@ -1,11 +0,0 @@
1−#!/usr/bin/env bash
2−
3−set -e
4−
5−mkdir -p ~/.local/bin
6−
7−curl -L https://www.stackage.org/stack/linux-x86_64 | \
8− tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
9−
10−ghc --version
11−stack --version
script/travis-lifecycle-installdeleted−13
@@ -1,13 +0,0 @@
1−#!/usr/bin/env bash
2−
3−set -e
4−
5−GHCVER=${GHCVER?"GHCVER needs to be set."}
6−
7−path=$(cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd)
8−
9−$path/travis-timeout \
10− stack --no-terminal --skip-ghc-check --stack-yaml stack-$GHCVER.yaml setup
11−
12−$path/travis-timeout \
13− stack --no-terminal --skip-ghc-check --stack-yaml stack-$GHCVER.yaml test pagerduty --only-snapshot
script/travis-lifecycle-scriptdeleted−9
@@ -1,9 +0,0 @@
1−#!/usr/bin/env bash
2−
3−set -e
4−
5−GHCVER=${GHCVER?"GHCVER needs to be set."}
6−
7−path=$(cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd)
8−
9−stack --no-terminal --skip-ghc-check --stack-yaml stack-$GHCVER.yaml test pagerduty
script/travis-timeoutdeleted−15
@@ -1,15 +0,0 @@
1−#!/usr/bin/env bash
2−
3−$* &
4−pidA=$!
5−minutes=0
6−
7−while true; do sleep 60; ((minutes++)); echo -e "\033[0;32m$minutes minute(s) elapsed running '$*'\033[0m."; done &
8−pidB=$!
9−wait $pidA
10−resA=$?
11−
12−echo -e "\033[0;32m'$*' exited with status ${resA}.\033[0m"
13−kill -9 $pidB
14−
15−exit $resA
src/Control/Monad/Trans/PagerDuty.hs+72−55
@@ -2,12 +2,15 @@
2{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+{-# LANGUAGE KindSignatures #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE RecordWildCards #-}
8+{-# LANGUAGE TemplateHaskell #-}
6{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE UndecidableInstances #-}
10{-# LANGUAGE UndecidableInstances #-}
8
11
9-- Module : Control.Monad.Trans.PagerDuty
12-- Module : Control.Monad.Trans.PagerDuty
10−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
13+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
11-- License : This Source Code Form is subject to the terms of
14-- License : This Source Code Form is subject to the terms of
12-- the Mozilla Public License, v. 2.0.
15-- the Mozilla Public License, v. 2.0.
13-- A copy of the MPL can be found in the LICENSE file or
16-- A copy of the MPL can be found in the LICENSE file or
@@ -19,50 +22,57 @@
19module Control.Monad.Trans.PagerDuty
22module Control.Monad.Trans.PagerDuty
20 (
23 (
21 -- * Transformer
24 -- * Transformer
22− PagerDuty
25+ PD
23− , PagerDutyT
26+ , PDT
24
27
25− -- * Running
28+ -- * Run
26− , runPagerDutyT
29+ , runPDT
27
30
31+ -- * Environment
32+ , Env
33+ , envDomain
34+ , envAuth
35+ , envManager
36+-- , envLogging
37+
28− -- * Integration events
38+ -- * Integration API
29 , submit
39 , submit
30− , submitCatch
31
40
32− -- * REST requests
41+ -- * REST API
33 , send
42 , send
34− , sendCatch
35 , paginate
43 , paginate
36− , paginateCatch
37−
38− -- ** Lifting errors
39− , hoistError
40−
41− , module Network.PagerDuty.Types
42 ) where
44 ) where
43
45
44import Control.Applicative
46import Control.Applicative
45−import Control.Monad
47+import Control.Lens
46import Control.Monad.Base
48import Control.Monad.Base
47import Control.Monad.Catch
49import Control.Monad.Catch
48−import Control.Monad.Except (MonadError (..))
50+import Control.Monad.Except
49import Control.Monad.Morph
51import Control.Monad.Morph
50import Control.Monad.Reader
52import Control.Monad.Reader
51import Control.Monad.Trans.Control
53import Control.Monad.Trans.Control
52−import Control.Monad.Trans.Except
53import Data.Aeson
54import Data.Aeson
54import Data.Conduit
55import Data.Conduit
56+import Network.HTTP.Client (Manager)
55−import Network.PagerDuty.Integration (Event, Response)
57+import Network.PagerDuty.Integration (Event, Response)
56−import qualified Network.PagerDuty.Integration as Int
58+import qualified Network.PagerDuty.Integration as Int
57−import Network.PagerDuty.Internal.Types
58−import qualified Network.PagerDuty.REST as REST
59+import qualified Network.PagerDuty.REST as REST
59import Network.PagerDuty.Types
60import Network.PagerDuty.Types
60
61
62+data Env (s :: Security) = Env
63+ { _envDomain :: SubDomain
64+ , _envAuth :: Auth s
65+ , _envManager :: Manager
66+-- , _envLogging ::
67+ }
68+
69+makeLenses ''Env
70+
61−-- | A convenient alias for 'PagerDutyT' 'IO'.
71+-- | A convenient alias for 'PDT' 'IO'.
62−type PagerDuty s = PagerDutyT s IO
72+type PD s = PDT s IO
63
73
64−newtype PagerDutyT s m a = PagerDutyT
74+newtype PDT s m a = PDT
65− { unPagerDutyT :: ReaderT (Env s) (ExceptT Error m) a
75+ { unPDT :: ReaderT (Env s) (ExceptT Error m) a
66 } deriving
76 } deriving
67 ( Functor
77 ( Functor
68 , Applicative
78 , Applicative
@@ -74,48 +84,50 @@ newtype PagerDutyT s m a = PagerDutyT
74 , MonadError Error
84 , MonadError Error
75 )
85 )
76
86
77−instance MonadTrans (PagerDutyT s) where
87+instance MonadTrans (PDT s) where
78− lift = PagerDutyT . lift . lift
88+ lift = PDT . lift . lift
79 {-# INLINE lift #-}
89 {-# INLINE lift #-}
80
90
81−instance MonadBase b m => MonadBase b (PagerDutyT s m) where
91+instance MonadBase b m => MonadBase b (PDT s m) where
82 liftBase = liftBaseDefault
92 liftBase = liftBaseDefault
83 {-# INLINE liftBase #-}
93 {-# INLINE liftBase #-}
84
94
85−instance MonadTransControl (PagerDutyT s) where
95+instance MonadTransControl (PDT s) where
96+ newtype StT (PDT s) a = StTAWS
86− type StT (PagerDutyT s) a = StT (ExceptT Error) (StT (ReaderT (Env s)) a)
97+ { unStTAWS :: StT (ExceptT Error) (StT (ReaderT (Env s)) a)
98+ }
87
99
88− liftWith f = PagerDutyT $
100+ liftWith f = PDT $
89 liftWith $ \g ->
101 liftWith $ \g ->
90− liftWith $ \h ->
102+ liftWith $ \h ->
91− f (h . g . unPagerDutyT)
103+ f (liftM StTAWS . h . g . unPDT)
92 {-# INLINE liftWith #-}
104 {-# INLINE liftWith #-}
93
105
94− restoreT = PagerDutyT . restoreT . restoreT
106+ restoreT = PDT . restoreT . restoreT . liftM unStTAWS
95 {-# INLINE restoreT #-}
107 {-# INLINE restoreT #-}
96
108
97−instance MonadBaseControl b m => MonadBaseControl b (PagerDutyT s m) where
109+instance MonadBaseControl b m => MonadBaseControl b (PDT s m) where
98− type StM (PagerDutyT s m) a = ComposeSt (PagerDutyT s) m a
110+ newtype StM (PDT s m) a = StMPDT { unStMPDT :: ComposeSt (PDT s) m a }
99
111
100− liftBaseWith = defaultLiftBaseWith
112+ liftBaseWith = defaultLiftBaseWith StMPDT
101 {-# INLINE liftBaseWith #-}
113 {-# INLINE liftBaseWith #-}
102
114
103− restoreM = defaultRestoreM
115+ restoreM = defaultRestoreM unStMPDT
104 {-# INLINE restoreM #-}
116 {-# INLINE restoreM #-}
105
117
106−instance MFunctor (PagerDutyT s) where
118+instance MFunctor (PDT s) where
107− hoist nat m = PagerDutyT (ReaderT (ExceptT . nat . runPagerDutyT m))
119+ hoist nat m = PDT (ReaderT (ExceptT . nat . runPDT m))
108 {-# INLINE hoist #-}
120 {-# INLINE hoist #-}
109
121
110−instance MMonad (PagerDutyT s) where
122+instance MMonad (PDT s) where
111− embed f m = ask >>= f . runPagerDutyT m >>= either throwError return
123+ embed f m = ask >>= f . runPDT m >>= either throwError return
112 {-# INLINE embed #-}
124 {-# INLINE embed #-}
113
125
114−runPagerDutyT :: PagerDutyT s m a -> Env s -> m (Either Error a)
126+runPDT :: PDT s m a -> Env s -> m (Either Error a)
115−runPagerDutyT (PagerDutyT k) = runExceptT . runReaderT k
127+runPDT (PDT k) = runExceptT . runReaderT k
116
128
117−hoistError :: (MonadError Error m) => Either Error a -> m a
129+hoistEither :: (MonadError Error m) => Either Error a -> m a
118−hoistError = either throwError return
130+hoistEither = either throwError return
119
131
120scoped :: MonadReader (Env s) m => (Env s -> m a) -> m a
132scoped :: MonadReader (Env s) m => (Env s -> m a) -> m a
121scoped f = ask >>= f
133scoped f = ask >>= f
@@ -123,17 +135,20 @@ scoped f = ask >>= f
123submit :: ( MonadIO m
135submit :: ( MonadIO m
124 , MonadReader (Env s) m
136 , MonadReader (Env s) m
125 , MonadError Error m
137 , MonadError Error m
138+ , Event a
126 )
139 )
127− => Event
140+ => a
128 -> m Response
141 -> m Response
129−submit = submitCatch >=> hoistError
142+submit = submitCatch >=> hoistEither
130
143
131submitCatch :: ( MonadIO m
144submitCatch :: ( MonadIO m
132 , MonadReader (Env s) m
145 , MonadReader (Env s) m
146+ , Event a
133 )
147 )
134− => Event
148+ => a
135 -> m (Either Error Response)
149 -> m (Either Error Response)
136−submitCatch x = scoped $ \e -> Int.submitWith (_envManager e) (_envLogger e) x
150+submitCatch x = scoped $ \e ->
151+ Int.submit (_envManager e) x
137
152
138send :: ( MonadIO m
153send :: ( MonadIO m
139 , MonadReader (Env s) m
154 , MonadReader (Env s) m
@@ -142,7 +157,7 @@ send :: ( MonadIO m
142 )
157 )
143 => Request a s b
158 => Request a s b
144 -> m b
159 -> m b
145−send = sendCatch >=> hoistError
160+send = sendCatch >=> hoistEither
146
161
147sendCatch :: ( MonadIO m
162sendCatch :: ( MonadIO m
148 , MonadReader (Env s) m
163 , MonadReader (Env s) m
@@ -150,7 +165,8 @@ sendCatch :: ( MonadIO m
150 )
165 )
151 => Request a s b
166 => Request a s b
152 -> m (Either Error b)
167 -> m (Either Error b)
153−sendCatch x = scoped (`REST.sendWith` x)
168+sendCatch x = scoped $ \Env{..} ->
169+ REST.send _envAuth _envDomain _envManager x
154
170
155paginate :: ( MonadIO m
171paginate :: ( MonadIO m
156 , MonadReader (Env s) m
172 , MonadReader (Env s) m
@@ -160,7 +176,7 @@ paginate :: ( MonadIO m
160 )
176 )
161 => Request a s b
177 => Request a s b
162 -> Source m b
178 -> Source m b
163−paginate x = paginateCatch x $= awaitForever (hoistError >=> yield)
179+paginate x = paginateCatch x $= awaitForever (hoistEither >=> yield)
164
180
165paginateCatch :: ( MonadIO m
181paginateCatch :: ( MonadIO m
166 , MonadReader (Env s) m
182 , MonadReader (Env s) m
@@ -169,4 +185,5 @@ paginateCatch :: ( MonadIO m
169 )
185 )
170 => Request a s b
186 => Request a s b
171 -> Source m (Either Error b)
187 -> Source m (Either Error b)
172−paginateCatch x = scoped (`REST.paginateWith` x)
188+paginateCatch x = scoped $ \Env{..} ->
189+ REST.paginate _envAuth _envDomain _envManager x
src/Network/PagerDuty/API/Integration.hsnew file+77
@@ -0,0 +1,77 @@
1+{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+
5+-- Module : Network.PagerDuty.Integration
6+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
7+-- License : This Source Code Form is subject to the terms of
8+-- the Mozilla Public License, v. 2.0.
9+-- A copy of the MPL can be found in the LICENSE file or
10+-- you can obtain it at http://mozilla.org/MPL/2.0/.
11+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
12+-- Stability : experimental
13+-- Portability : non-portable (GHC extensions)
14+
15+-- | The "Integration API"
16+--
17+-- <http://developer.pagerduty.com/documentation/integration/events>
18+--
19+module Network.PagerDuty.API.Integration
20+ ( Event (..)
21+ , submitEvent
22+
23+ -- * Re-exported
24+ , ServiceKey
25+ , IncidentKey
26+ ) where
27+
28+import Control.Applicative
29+import Data.Aeson
30+import Data.Maybe (catMaybes)
31+import Data.Text (Text)
32+import GHC.Generics
33+import Network.PagerDuty.IO
34+import Network.PagerDuty.Types
35+
36+submitEvent :: Event -> PagerDuty a (Either Error IncidentKey)
37+submitEvent = fmap (fmap incident_key) . request defaultRequest
38+ { method = methodPost
39+ , host = "events.pagerduty.com"
40+ , path = "/generic/2010-04-15/create_event.json"
41+ }
42+
43+data Event
44+ = Trigger !ServiceKey !(Maybe IncidentKey) !Text !(Maybe Object)
45+ | Acknowledge !ServiceKey !IncidentKey !(Maybe Text) !(Maybe Object)
46+ | Resolve !ServiceKey !IncidentKey !(Maybe Text) !(Maybe Object)
47+ deriving (Eq, Show)
48+
49+instance ToJSON Event where
50+ toJSON (Trigger svc minc desc mdets) =
51+ jsonEvent "trigger" svc minc (Just desc) mdets
52+ toJSON (Acknowledge svc inc mdesc mdets) =
53+ jsonEvent "acknowledge" svc (Just inc) mdesc mdets
54+ toJSON (Resolve svc inc mdesc mdets) =
55+ jsonEvent "resolve" svc (Just inc) mdesc mdets
56+
57+jsonEvent :: Text
58+ -> ServiceKey
59+ -> Maybe IncidentKey
60+ -> Maybe Text
61+ -> Maybe Object
62+ -> Value
63+jsonEvent typ skey ikey desc dets = object $ catMaybes
64+ [ Just $ "event_type" .= typ
65+ , Just $ "service_key" .= skey
66+ , ("incident_key" .=) <$> ikey
67+ , ("description" .=) <$> desc
68+ , ("details" .=) <$> dets
69+ ]
70+
71+data EventResponse = ER
72+ { status :: !Text
73+ , incident_key :: !IncidentKey
74+ , message :: !Text
75+ } deriving (Show, Generic)
76+
77+instance FromJSON EventResponse
src/Network/PagerDuty/API/LogEntries.hsnew file+28
@@ -0,0 +1,28 @@
1+{-# LANGUAGE DeriveGeneric #-}
2+
3+-- Module : Network.PagerDuty.API.LogEntries
4+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
5+-- License : This Source Code Form is subject to the terms of
6+-- the Mozilla Public License, v. 2.0.
7+-- A copy of the MPL can be found in the LICENSE file or
8+-- you can obtain it at http://mozilla.org/MPL/2.0/.
9+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
10+-- Stability : experimental
11+-- Portability : non-portable (GHC extensions)
12+
13+module Network.PagerDuty.API.LogEntries where
14+
15+import Data.Aeson
16+import GHC.Generics
17+import Network.PagerDuty.Types
18+
19+data LogEntries = LogEntries
20+ { lesTotal :: !Int
21+ , leslogEntries :: [LogEntry]
22+ } deriving (Eq, Show, Generic)
23+
24+instance FromJSON LogEntries
25+instance ToJSON LogEntries
26+
27+logEntries :: PagerDuty Authenticated (Either Error LogEntries)
28+logEntries = undefined
src/Network/PagerDuty/API/MaintenanceWindows.hsnew file+232
@@ -0,0 +1,232 @@
1+{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+
4+-- Module : Network.PagerDuty.API.MaintenanceWindows
5+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
6+-- License : This Source Code Form is subject to the terms of
7+-- the Mozilla Public License, v. 2.0.
8+-- A copy of the MPL can be found in the LICENSE file or
9+-- you can obtain it at http://mozilla.org/MPL/2.0/.
10+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
11+-- Stability : experimental
12+-- Portability : non-portable (GHC extensions)
13+
14+module Network.PagerDuty.API.MaintenanceWindows
15+ ( CreateMaintenanceWindow (..)
16+ , MaintenanceWindowCounts (..)
17+ , MaintenanceWindowCreatorDetails (..)
18+ , MaintenanceWindowCreatorId
19+ , MaintenanceWindowDetails (..)
20+ , MaintenanceWindowFilter (..)
21+ , MaintenanceWindowId
22+ , ServiceInfo (..)
23+ , UpdateMaintenanceWindow (..)
24+
25+ , createMaintenanceWindow
26+ , createMaintenanceWindow'
27+ , updateMaintenanceWindow
28+ , listMaintenanceWindows
29+ , getMaintenanceWindow
30+ , deleteMaintenaceWindow
31+ ) where
32+
33+import Control.Applicative
34+import Data.Aeson
35+import Data.ByteString (ByteString)
36+import Data.Maybe
37+import Data.Monoid
38+import Data.Text (Text)
39+import qualified Data.Text as T
40+import Data.Text.Encoding
41+import Data.Time (UTCTime)
42+import GHC.Generics
43+import Network.PagerDuty.Internal
44+import Network.PagerDuty.IO
45+import Network.PagerDuty.Types
46+
47+type A a = Authenticated a
48+
49+bASE_PATH :: ByteString
50+bASE_PATH = "/api/v1/maintenance_windows/"
51+
52+createMaintenanceWindow :: CreateMaintenanceWindow
53+ -> RequesterId
54+ -> PagerDuty (A Token) (Either Error MaintenanceWindowDetails)
55+createMaintenanceWindow mw rid =
56+ fmap (fmap dr_maintenance_window)
57+ . request defaultRequest
58+ { method = methodPost
59+ , path = bASE_PATH
60+ }
61+ $ CreateMaintenanceWindowRequest
62+ { cmwr_maintenance_window = mw
63+ , cmwr_requester_id = Just rid
64+ }
65+
66+createMaintenanceWindow' :: CreateMaintenanceWindow
67+ -> PagerDuty (A BasicAuth) (Either Error MaintenanceWindowDetails)
68+createMaintenanceWindow' mw =
69+ fmap (fmap dr_maintenance_window)
70+ . request defaultRequest
71+ { method = methodPost
72+ , path = bASE_PATH
73+ }
74+ $ CreateMaintenanceWindowRequest
75+ { cmwr_maintenance_window = mw
76+ , cmwr_requester_id = Nothing
77+ }
78+
79+updateMaintenanceWindow :: MaintenanceWindowId
80+ -> UpdateMaintenanceWindow
81+ -> PagerDuty (A a) (Either Error MaintenanceWindowDetails)
82+updateMaintenanceWindow (Id mwid) =
83+ fmap (fmap dr_maintenance_window)
84+ . request defaultRequest
85+ { method = methodPut
86+ , path = bASE_PATH <> encodeUtf8 mwid
87+ }
88+
89+listMaintenanceWindows :: Maybe Text
90+ -> [ServiceId]
91+ -> Maybe MaintenanceWindowFilter
92+ -> PagerDuty (A a) (Either Error (MaintenanceWindowCounts, [MaintenanceWindowDetails]))
93+listMaintenanceWindows qry sids filt =
94+ fmap (fmap (liftA2 (,) lr_counts lr_maintenance_windows))
95+ . request defaultRequest
96+ { method = methodGet
97+ , path = bASE_PATH
98+ , queryString = renderSimpleQuery True mkQuery
99+ }
100+ $ T.empty
101+ where
102+ mkQuery :: [(ByteString, ByteString)]
103+ mkQuery = (catMaybes [ fmap ((,) "query" . encodeUtf8) qry
104+ , fmap ((,) "filter" . filterToBS) filt
105+ ])
106+ ++ map (\ (Id sid) -> ("service_ids[]", encodeUtf8 sid)) sids
107+
108+getMaintenanceWindow :: MaintenanceWindowId
109+ -> PagerDuty (A a) (Either Error MaintenanceWindowDetails)
110+getMaintenanceWindow (Id mwid) =
111+ fmap (fmap dr_maintenance_window)
112+ . request defaultRequest
113+ { method = methodGet
114+ , path = bASE_PATH <> encodeUtf8 mwid
115+ }
116+ $ T.empty
117+
118+deleteMaintenaceWindow :: MaintenanceWindowId
119+ -> PagerDuty (A a) (Either Error Empty)
120+deleteMaintenaceWindow (Id mwid) = request defaultRequest
121+ { method = methodDelete
122+ , path = bASE_PATH <> encodeUtf8 mwid
123+ } $ T.empty
124+
125+data MaintenanceWindow
126+data MaintenanceWindowCreator
127+
128+type MaintenanceWindowId = Id MaintenanceWindow
129+type MaintenanceWindowCreatorId = Id MaintenanceWindowCreator
130+
131+data CreateMaintenanceWindow = CreateMaintenanceWindow
132+ { cmw_start_time :: !UTCTime
133+ , cmw_end_time :: !UTCTime
134+ , cmw_description :: Maybe Text
135+ , cmw_service_ids :: [ServiceId]
136+ } deriving (Show, Generic)
137+
138+instance ToJSON CreateMaintenanceWindow where
139+ toJSON = gToJson "cmw_"
140+
141+data UpdateMaintenanceWindow = UpdateMaintenanceWindow
142+ { umw_start_time :: Maybe UTCTime
143+ , umw_end_time :: Maybe UTCTime
144+ , umw_description :: Maybe Text
145+ , umw_service_ids :: [ServiceId]
146+ } deriving (Show, Generic)
147+
148+instance ToJSON UpdateMaintenanceWindow where
149+ toJSON = gToJson "umw_"
150+
151+data CreateMaintenanceWindowRequest = CreateMaintenanceWindowRequest
152+ { cmwr_maintenance_window :: !CreateMaintenanceWindow
153+ , cmwr_requester_id :: Maybe RequesterId
154+ } deriving (Show, Generic)
155+
156+instance ToJSON CreateMaintenanceWindowRequest where
157+ toJSON = gToJson "cmwr_"
158+
159+data MaintenanceWindowDetails = MaintenanceWindowDetails
160+ { mwd_id :: !MaintenanceWindowId
161+ , mwd_sequence_number :: !Int
162+ , mwd_start_time :: !UTCTime
163+ , mwd_end_time :: !UTCTime
164+ , mwd_description :: Maybe Text
165+ , mwd_created_by :: !MaintenanceWindowCreatorDetails
166+ , mwd_services :: [ServiceInfo]
167+ } deriving (Show, Generic)
168+
169+instance FromJSON MaintenanceWindowDetails where
170+ parseJSON = gFromJson "mwd_"
171+
172+-- possibly used elsewhere (UserDetails or somesuch)
173+data MaintenanceWindowCreatorDetails = MaintenanceWindowCreatorDetails
174+ { mwcd_id :: !MaintenanceWindowCreatorId
175+ , mwcd_name :: !Text
176+ , mwcd_email :: !Text
177+ , mwcd_time_zone :: !Text
178+ , mwcd_color :: !Text -- wtf?
179+ , mwcd_role :: !Text
180+ , mwcd_avatar_url :: !Text
181+ , mwcd_user_url :: !Text
182+ , mwcd_invitation_sent :: !Bool
183+ } deriving (Show, Generic)
184+
185+instance FromJSON MaintenanceWindowCreatorDetails where
186+ parseJSON = gFromJson "mwcd_"
187+
188+data ServiceInfo = ServiceInfo
189+ { si_name :: !Text
190+ , si_url :: !Text
191+ , si_id :: !ServiceId
192+ } deriving (Show, Generic)
193+
194+instance FromJSON ServiceInfo where
195+ parseJSON = gFromJson "si_"
196+
197+data ListResponse = ListResponse
198+ { lr_maintenance_windows :: [MaintenanceWindowDetails]
199+ , lr_query :: Maybe Text
200+ , lr_counts :: !MaintenanceWindowCounts
201+ } deriving (Show, Generic)
202+
203+instance FromJSON ListResponse where
204+ parseJSON = gFromJson "lr_"
205+
206+data MaintenanceWindowCounts = MaintenanceWindowCounts
207+ { mwc_ongoing :: !Int
208+ , mwc_future :: !Int
209+ , mwc_past :: !Int
210+ , mwc_all :: !Int
211+ } deriving (Show, Generic)
212+
213+instance FromJSON MaintenanceWindowCounts where
214+ parseJSON = gFromJson "mwc_"
215+
216+newtype DetailsResponse = DetailsResponse
217+ { dr_maintenance_window :: MaintenanceWindowDetails
218+ } deriving (Show, Generic)
219+
220+instance FromJSON DetailsResponse where
221+ parseJSON = gFromJson "dr_"
222+
223+data MaintenanceWindowFilter
224+ = Past
225+ | Future
226+ | Ongoing
227+ deriving Show
228+
229+filterToBS :: MaintenanceWindowFilter -> ByteString
230+filterToBS Past = "past"
231+filterToBS Future = "future"
232+filterToBS Ongoing = "ongoing"
src/Network/PagerDuty/API/Services.hsnew file+292
@@ -0,0 +1,292 @@
1+{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+
5+-- Module : Network.PagerDuty.API.Services
6+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
7+-- License : This Source Code Form is subject to the terms of
8+-- the Mozilla Public License, v. 2.0.
9+-- A copy of the MPL can be found in the LICENSE file or
10+-- you can obtain it at http://mozilla.org/MPL/2.0/.
11+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
12+-- Stability : experimental
13+-- Portability : non-portable (GHC extensions)
14+
15+module Network.PagerDuty.API.Services
16+ ( ServiceDetails (..)
17+ , CreateService (..)
18+ , UpdateService (..)
19+ , ServiceStatus (..)
20+ , ServiceType (..)
21+ , EmailFilterMode (..)
22+ , IncidentCounts (..)
23+ , EmailIncidentCreation (..)
24+
25+ , createService
26+ , updateService
27+ , listServices
28+ , getService
29+ , deleteService
30+ , disableService
31+ , disableService'
32+ , enableService
33+ , enableService'
34+ , regenerateServiceKey
35+ ) where
36+
37+import Control.Applicative
38+import Control.Monad
39+import Data.Aeson
40+import Data.ByteString (ByteString)
41+import Data.Monoid
42+import Data.Text (Text)
43+import qualified Data.Text as T
44+import Data.Text.Encoding
45+import Data.Time
46+import GHC.Generics
47+import Network.PagerDuty.Internal
48+import Network.PagerDuty.IO
49+import Network.PagerDuty.Types
50+
51+type A a = Authenticated a
52+
53+bASE_PATH :: ByteString
54+bASE_PATH = "/api/v1/services/"
55+
56+createService :: CreateService -> PagerDuty (A a) (Either Error ServiceDetails)
57+createService = fmap (fmap service) . request defaultRequest
58+ { method = methodPost
59+ , path = bASE_PATH
60+ }
61+ . CreateServiceRequest
62+
63+updateService :: ServiceId
64+ -> UpdateService
65+ -> PagerDuty (A a) (Either Error ServiceDetails)
66+updateService (Id sid) = fmap (fmap service) . request defaultRequest
67+ { method = methodPut
68+ , path = bASE_PATH <> encodeUtf8 sid
69+ }
70+ . UpdateServiceRequest
71+
72+listServices :: PagerDuty (A a) (Either Error [ServiceDetails])
73+listServices = fmap (fmap services) . request defaultRequest
74+ { method = methodGet
75+ , path = bASE_PATH
76+ , queryString = "?include[]=escalation_policy&include[]=email_filters"
77+ } $ T.empty
78+
79+getService :: ServiceId -> PagerDuty (A a) (Either Error ServiceDetails)
80+getService (Id sid) = fmap (fmap service) . request defaultRequest
81+ { method = methodGet
82+ , path = bASE_PATH <> encodeUtf8 sid
83+ , queryString = "?include[]=escalation_policy&include[]=email_filters"
84+ } $ T.empty
85+
86+deleteService :: ServiceId -> PagerDuty (A a) (Either Error Empty)
87+deleteService (Id sid) = request defaultRequest
88+ { method = methodDelete
89+ , path = bASE_PATH <> encodeUtf8 sid
90+ } $ T.empty
91+
92+disableService :: ServiceId
93+ -> RequesterId
94+ -> PagerDuty (A Token) (Either Error Empty)
95+disableService (Id sid) (Id rid) = request defaultRequest
96+ { method = methodPut
97+ , path = bASE_PATH <> encodeUtf8 sid <> "/disable"
98+ , queryString = "?requester_id=" <> encodeUtf8 rid
99+ } $ T.empty
100+
101+disableService' :: ServiceId -> PagerDuty (A BasicAuth) (Either Error Empty)
102+disableService' (Id sid) = request defaultRequest
103+ { method = methodPut
104+ , path = bASE_PATH <> encodeUtf8 sid <> "/disable"
105+ } $ T.empty
106+
107+enableService :: ServiceId
108+ -> RequesterId
109+ -> PagerDuty (A Token) (Either Error Empty)
110+enableService (Id sid) (Id rid) = request defaultRequest
111+ { method = methodPut
112+ , path = bASE_PATH <> encodeUtf8 sid <> "/enable"
113+ , queryString = "?requester_id=" <> encodeUtf8 rid
114+ } $ T.empty
115+
116+enableService' :: ServiceId -> PagerDuty (A BasicAuth) (Either Error Empty)
117+enableService' (Id sid) = request defaultRequest
118+ { method = methodPut
119+ , path = bASE_PATH <> encodeUtf8 sid <> "/enable"
120+ } $ T.empty
121+
122+regenerateServiceKey :: ServiceId -> PagerDuty (A a) (Either Error ServiceKey)
123+regenerateServiceKey (Id sid) = fmap (fmap (sd_service_key . service)) . request defaultRequest
124+ { method = methodPost
125+ , path = bASE_PATH <> encodeUtf8 sid <> "/regenerate_key"
126+ } $ T.empty
127+
128+newtype CreateServiceRequest = CreateServiceRequest
129+ { csr_service :: CreateService
130+ } deriving (Show, Generic)
131+
132+instance ToJSON CreateServiceRequest where
133+ toJSON = gToJson "csr_"
134+
135+newtype UpdateServiceRequest = UpdateServiceRequest
136+ { usr_service :: UpdateService
137+ } deriving (Show, Generic)
138+
139+instance ToJSON UpdateServiceRequest where
140+ toJSON = gToJson "usr_"
141+
142+newtype DetailsListResponse = DLR { services :: [ServiceDetails] }
143+ deriving (Show, Generic)
144+
145+instance FromJSON DetailsListResponse
146+
147+newtype DetailsResponse = DR { service :: ServiceDetails }
148+ deriving (Show, Generic)
149+
150+instance FromJSON DetailsResponse
151+
152+data CreateService = CreateService
153+ { cs_name :: !Text
154+ , cs_escalation_policy_id :: !Text
155+ , cs_type :: !ServiceType
156+ , cs_description :: Maybe Text
157+ , cs_acknowledgement_timeout :: Maybe Int
158+ , cs_auto_resolve_timeout :: Maybe Int
159+ , cs_severity_filter :: Maybe Text
160+ } deriving (Show, Generic)
161+
162+instance ToJSON CreateService where toJSON = gToJson "cs_"
163+
164+data UpdateService = UpdateService
165+ { us_name :: Maybe Text
166+ , us_escalation_policy_id :: Maybe Text
167+ , us_type :: Maybe ServiceType
168+ , us_description :: Maybe Text
169+ , us_acknowledgement_timeout :: Maybe Int
170+ , us_auto_resolve_timeout :: Maybe Int
171+ , us_severity_filter :: Maybe Text
172+ } deriving (Show, Generic)
173+
174+instance ToJSON UpdateService where toJSON = gToJson "us_"
175+
176+data ServiceDetails = ServiceDetails
177+ { sd_id :: !ServiceId
178+ , sd_name :: !Text
179+ , sd_description :: !Text
180+ , sd_service_url :: !Text
181+ , sd_service_key :: !ServiceKey
182+ , sd_auto_resolve_timeout :: !Int
183+ , sd_acknowledgement_timeout :: !Int
184+ , sd_created_at :: !ZonedTime
185+ , sd_deleted_at :: Maybe ZonedTime
186+ , sd_status :: !ServiceStatus
187+ , sd_last_incident_timestamp :: Maybe ZonedTime
188+ , sd_email_incident_creation :: Maybe EmailIncidentCreation
189+ , sd_incident_counts :: !IncidentCounts
190+ , sd_email_filter_mode :: !EmailFilterMode
191+ , sd_type :: !ServiceType
192+ , sd_escalation_policy :: Maybe Object -- todo
193+ , sd_email_filters :: Maybe Object -- todo
194+ , sd_severity_filter :: Maybe Text -- todo?
195+ } deriving (Show, Generic)
196+
197+instance FromJSON ServiceDetails where
198+ parseJSON = gFromJson "sd_"
199+
200+data ServiceStatus
201+ = Active
202+ | Warning
203+ | Critical
204+ | Maintenance
205+ | Disabled
206+ deriving (Eq, Show)
207+
208+instance FromJSON ServiceStatus where
209+ parseJSON (String s) = case s of
210+ "active" -> pure Active
211+ "warning" -> pure Warning
212+ "critical" -> pure Critical
213+ "maintenance" -> pure Maintenance
214+ "disabled" -> pure Disabled
215+ _ -> mzero
216+
217+ parseJSON _ = mzero
218+
219+data IncidentCounts = IncidentCounts
220+ { triggered :: !Int
221+ , acknowledged :: !Int
222+ , resolved :: !Int
223+ , total :: !Int
224+ } deriving (Show, Generic)
225+
226+instance FromJSON IncidentCounts
227+
228+data EmailIncidentCreation
229+ = OnNewEmail
230+ | OnNewEmailSubject
231+ | OnlyIfNoOpenIncidents
232+ deriving (Eq, Show)
233+
234+instance FromJSON EmailIncidentCreation where
235+ parseJSON (String s) = case s of
236+ "on_new_email" -> pure OnNewEmail
237+ "on_new_email_subject" -> pure OnNewEmailSubject
238+ "only_if_no_open_incidents" -> pure OnlyIfNoOpenIncidents
239+ _ -> mzero
240+
241+ parseJSON _ = mzero
242+
243+data EmailFilterMode
244+ = AllEmail
245+ | OrRulesEmail
246+ | AndRulesEmail
247+ deriving (Eq, Show)
248+
249+instance FromJSON EmailFilterMode where
250+ parseJSON (String s) = case s of
251+ "all-email" -> pure AllEmail
252+ "or-rules-email" -> pure OrRulesEmail
253+ "and-rules-email" -> pure AndRulesEmail
254+ _ -> mzero
255+
256+ parseJSON _ = mzero
257+
258+data ServiceType
259+ = CloudKick
260+ | GenericEmail
261+ | GenericEventsApi
262+ | Keynote
263+ | Nagios
264+ | Pingdom
265+ | ServerDensity
266+ | SqlMonitor
267+ deriving (Eq, Show)
268+
269+instance FromJSON ServiceType where
270+ parseJSON (String s) = case s of
271+ "cloudkick" -> pure CloudKick
272+ "generic_email" -> pure GenericEmail
273+ "generic_events_api" -> pure GenericEventsApi
274+ "keynote" -> pure Keynote
275+ "nagios" -> pure Nagios
276+ "pingdom" -> pure Pingdom
277+ "server_density" -> pure ServerDensity
278+ "sql_monitor" -> pure SqlMonitor
279+ _ -> mzero
280+
281+ parseJSON _ = mzero
282+
283+instance ToJSON ServiceType where
284+ toJSON st = String $ case st of
285+ CloudKick -> "cloudkick"
286+ GenericEmail -> "generic_email"
287+ GenericEventsApi -> "generic_events_api"
288+ Keynote -> "keynote"
289+ Nagios -> "nagios"
290+ Pingdom -> "pingdom"
291+ ServerDensity -> "server_density"
292+ SqlMonitor -> "sql_monitor"
src/Network/PagerDuty/IO.hsnew file+66
@@ -0,0 +1,66 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+-- Module : Network.PagerDuty.IO
4+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
5+-- License : This Source Code Form is subject to the terms of
6+-- the Mozilla Public License, v. 2.0.
7+-- A copy of the MPL can be found in the LICENSE file or
8+-- you can obtain it at http://mozilla.org/MPL/2.0/.
9+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
10+-- Stability : experimental
11+-- Portability : non-portable (GHC extensions)
12+
13+module Network.PagerDuty.IO where
14+
15+import Control.Monad
16+import Control.Monad.IO.Class
17+import Data.Aeson hiding (Error)
18+import qualified Data.ByteString.Lazy as LBS
19+import Network.HTTP.Client (Manager, httpLbs)
20+import qualified Network.HTTP.Client as Client
21+import Network.HTTP.Types
22+import Network.PagerDuty.Types
23+
24+request :: (MonadIO m, ToJSON a, FromJSON b)
25+ => Manager
26+ -> a
27+ -> Client.Request
28+ -> m (Either Error b)
29+request m x rq = liftIO (httpLbs raw m) >>= response
30+ where
31+ raw = rq
32+ { Client.secure = True
33+ , Client.port = 443
34+ , Client.requestHeaders = headers
35+ , Client.requestBody = Client.RequestBodyLBS (encode x)
36+ }
37+
38+ headers =
39+ [ ("Content-Type", "application/json")
40+ , ("Accept", "application/json")
41+ ]
42+
43+response :: (Monad m, FromJSON b)
44+ => Client.Response LBS.ByteString
45+ -> m (Either Error b)
46+response rs = case statusCode (Client.responseStatus rs) of
47+ 200 -> success
48+ 201 -> success
49+ 400 -> failure
50+ 500 -> failure
51+ n -> return . Left $ unhandled n
52+ where
53+ success = maybe (Left unknown) Right `liftM` parse
54+ failure = maybe (Left unknown) Left `liftM` parse
55+
56+ unhandled n = Internal
57+ $ "PagerDuty returned unhandled status code: " ++ show n
58+
59+ unknown = Internal
60+ $ "Unable to parse response into a PagerDuty API compatible type: "
61+ ++ show body
62+
63+ parse :: (Monad m, FromJSON a) => m (Maybe a)
64+ parse = return (decode body)
65+
66+ body = Client.responseBody rs
src/Network/PagerDuty/Integration.hs+151−191
@@ -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 #-}
7
5
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
@@ -35,60 +33,55 @@
35-- The same event-based API can also be used to integrate a PagerDuty
33-- The same event-based API can also be used to integrate a PagerDuty
36-- service with ticketing systems and various other software tools.
34-- service with ticketing systems and various other software tools.
37--
35--
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
40 (
38 (
41− -- * Sending events
39+ -- * Events
42 submit
40 submit
43− , submitWith
44
41
45 -- ** Trigger
42 -- ** Trigger
46 , Trigger
43 , Trigger
47 , trigger
44 , trigger
48− , client
45+ , tDescription
49− , clientUrl
46+ , tIncidentKey
47+ , tClient
48+ , tClientUrl
49+ , tDetails
50
50
51 -- ** Acknowledge
51 -- ** Acknowledge
52 , Acknowledge
52 , Acknowledge
53 , acknowledge
53 , acknowledge
54+ , aDescription
55+ , aDetails
54
56
55 -- ** Resolve
57 -- ** Resolve
56 , Resolve
58 , Resolve
57 , resolve
59 , resolve
58−
60+ , rDescription
59− -- * Fields
61+ , rDetails
60− , HasServiceKey (..)
61− , HasIncidentKey (..)
62− , HasDescription (..)
63− , HasDetails (..)
64
62
65 -- * Types
63 -- * Types
66− , Event (..)
64+ , Event
67− , _Trigger
65+ , AnyEvent (..)
68− , _Acknowledge
69− , _Resolve
70
66
71 , Response
67 , Response
72 , rsStatus
68 , rsStatus
73 , rsMessage
69 , rsMessage
74 , rsIncidentKey
70 , rsIncidentKey
75−
76− , Generic
77−
78− , module Network.PagerDuty.Types
79 ) where
71 ) where
80
72
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
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
88−import Network.PagerDuty.Internal.IO
82+import Network.PagerDuty.IO
89−import Network.PagerDuty.Internal.TH
83+import Network.PagerDuty.TH
90−import Network.PagerDuty.Internal.Types
84+import Network.PagerDuty.Types
91−import Network.PagerDuty.Types hiding (description, message)
92
85
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
109
102
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
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)
144
106
145−deriveRecord ''Trigger
107+ default eventPayload :: ToJSON a => a -> Object
108+ eventPayload x = let Object o = toJSON x in o
146
109
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'
151
112
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
155
116
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'
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)
166
123
167−deriveRecord ''Generic
124+deriveJSON ''Generic
168−
125+
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)
182−
137+
183−makePrisms ''Event
138+deriveJSON ''Trigger
184−
139+
185−instance HasServiceKey Event ServiceKey where
140+instance Event Trigger where
186− serviceKey = lens f g
141+ eventType = const "trigger"
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
228
142
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
236− -> Event
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
245 }
158 }
246
159
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+
247-- | Acknowledge events cause the referenced incident to enter the acknowledged
192-- | Acknowledge events cause the referenced incident to enter the acknowledged
248-- state.
193-- state.
249--
194--
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'
256− -> Event
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
263 }
206 }
264
207
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+
265-- | Resolve events cause the referenced incident to enter the resolved state.
225-- | Resolve events cause the referenced incident to enter the resolved state.
266--
226--
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'
274− -> Event
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
281 }
239 }
282
240
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+
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
286−
287−-- | /See:/ 'submit'
288−submitWith :: MonadIO m
289− => Manager
290− -> Logger
291− -> Event
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"
298− }
255+ }
256+ where
257+ payload = Object $
258+ Map.insert "event_type" (String (eventType x)) (eventPayload x)
src/Network/PagerDuty/Internal/IO.hsdeleted−76
@@ -1,76 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−{-# LANGUAGE ScopedTypeVariables #-}
3−
4−-- Module : Network.PagerDuty.Internal.IO
5−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
6−-- License : This Source Code Form is subject to the terms of
7−-- the Mozilla Public License, v. 2.0.
8−-- A copy of the MPL can be found in the LICENSE file or
9−-- you can obtain it at http://mozilla.org/MPL/2.0/.
10−-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
11−-- Stability : experimental
12−-- Portability : non-portable (GHC extensions)
13−
14−module Network.PagerDuty.Internal.IO where
15−
16−import Control.Monad
17−import Control.Monad.IO.Class
18−import Data.Aeson hiding (Error)
19−import qualified Data.ByteString.Lazy as LBS
20−import Data.Monoid
21−import qualified Data.Text as Text
22−import Network.HTTP.Client (Manager, httpLbs)
23−import qualified Network.HTTP.Client as Client
24−import Network.HTTP.Types
25−import Network.PagerDuty.Internal.Types
26−
27−request :: (MonadIO m, ToJSON a, FromJSON b)
28− => Manager
29− -> Logger
30− -> a
31− -> Client.Request
32− -> m (Either Error b)
33−request m l x rq = msg >> liftIO (httpLbs raw m) >>= response l
34− where
35− msg = debug l ("[Raw Request]\n" <> Text.pack (show raw))
36−
37− raw = rq
38− { Client.secure = True
39− , Client.port = 443
40− , Client.requestHeaders = headers
41− , Client.requestBody = Client.RequestBodyLBS (encode x)
42− }
43−
44− headers =
45− [ ("Content-Type", "application/json")
46− , ("Accept", "application/json")
47− ]
48−
49−response :: forall m b. (MonadIO m, FromJSON b)
50− => Logger
51− -> Client.Response LBS.ByteString
52− -> m (Either Error b)
53−response l rs = case statusCode (Client.responseStatus rs) of
54− 200 -> success
55− 201 -> success
56− 400 -> failure
57− 500 -> failure
58− n -> return . Left $ unhandled n
59− where
60− success = maybe (Left unknown) Right `liftM` parse
61− failure = maybe (Left unknown) Left `liftM` parse
62−
63− unhandled n = Internal $
64− "PagerDuty returned unhandled status code: "
65− <> Text.pack (show n)
66−
67− unknown = Internal $
68− "Unable to parse response into a PagerDuty API compatible type: "
69− <> Text.pack (show body)
70−
71− parse :: FromJSON a => m (Maybe a)
72− parse = msg >> return (decode body)
73−
74− msg = debug l ("[Raw Response]\n" <> Text.pack (show rs))
75−
76− body = Client.responseBody rs
src/Network/PagerDuty/Internal/Query.hsdeleted−111
@@ -1,111 +0,0 @@
1−{-# LANGUAGE ConstraintKinds #-}
2−{-# LANGUAGE DefaultSignatures #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE GADTs #-}
5−{-# LANGUAGE OverloadedStrings #-}
6−{-# LANGUAGE ScopedTypeVariables #-}
7−{-# LANGUAGE TupleSections #-}
8−
9−-- Module : Network.PagerDuty.Internal.Query
10−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
11−-- License : This Source Code Form is subject to the terms of
12−-- the Mozilla Public License, v. 2.0.
13−-- A copy of the MPL can be found in the LICENSE file or
14−-- you can obtain it at http://mozilla.org/MPL/2.0/.
15−-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
16−-- Stability : experimental
17−-- Portability : non-portable (GHC extensions)
18−
19−module Network.PagerDuty.Internal.Query
20− ( QueryValues (..)
21− , gquery
22− , gqueryWith
23− ) where
24−
25−import Data.Aeson.Types
26−import Data.Bifunctor
27−import Data.ByteString (ByteString)
28−import qualified Data.ByteString.Char8 as BS
29−import Data.ByteString.Conversion
30−import Data.Function (on)
31−import Data.List (groupBy)
32−import Data.Monoid ((<>))
33−import Data.Text (Text)
34−import qualified Data.Text.Encoding as Text
35−import Generics.SOP
36−import Network.HTTP.Types
37−import Network.PagerDuty.Internal.Options
38−
39−class QueryValues a where
40− queryValues :: a -> [ByteString]
41−
42− default queryValues :: ToByteString a => a -> [ByteString]
43− queryValues = (:[]) . toByteString'
44−
45−instance QueryValues a => QueryValues (Maybe a) where
46− queryValues (Just x) = queryValues x
47− queryValues Nothing = []
48−
49−instance QueryValues Text where
50− queryValues x = [Text.encodeUtf8 x]
51−
52−gquery :: forall a. (Generic a, HasDatatypeInfo a, All2 QueryValues (Code a))
53− => a
54− -> Query
55−gquery = gqueryWith underscored
56−
57−gqueryWith :: forall a. (Generic a, HasDatatypeInfo a, All2 QueryValues (Code a))
58− => Options
59− -> a
60− -> Query
61−gqueryWith o a = case datatypeInfo (Proxy :: Proxy a) of
62− ADT _ _ cs _ -> go cs (from a)
63− Newtype _ _ c -> go (c :* Nil) (from a)
64− where
65− go :: (All2 QueryValues xss, SListI xss)
66− => NP ConstructorInfo xss
67− -> SOP I xss
68− -> Query
69− go cs (SOP sop) =
70− group . hcollapse $ hcliftA2' p (gctor o) cs sop
71−
72− group :: [(ByteString, ByteString)] -> Query
73− group = concatMap f . groupBy ((==) `on` fst)
74− where
75− f [] = []
76− f [(k, v)] = [(k, Just v)]
77− f xs@((k,_):_) = let n = k <> "[]" in map (bimap (const n) Just) xs
78−
79−gctor :: All QueryValues xs
80− => Options
81− -> ConstructorInfo xs
82− -> NP I xs
83− -> K [(ByteString, ByteString)] xs
84−gctor o (Constructor n) args =
85− K . concat . hcollapse $ hcliftA p (K . map (k,) . queryValues . unI) args
86− where
87− k = BS.pack (constructorTagModifier o n)
88−
89−gctor o (Record _ ns) args =
90− K . concat . hcollapse $ hcliftA2 p (gfield o) ns args
91−
92−gctor o (Infix n _ _) (x :* y :* Nil) =
93− K $ map (k,) (queryValues (unI x) ++ queryValues (unI y))
94− where
95− k = BS.pack (constructorTagModifier o n)
96−
97−gctor _ Infix{} _ =
98− error "Network.PagerDuty.Generics.inaccessible"
99−
100−gfield :: QueryValues a
101− => Options
102− -> FieldInfo a
103− -> I a
104− -> K [(ByteString, ByteString)] a
105−gfield o (FieldInfo f) (I a) =
106− K $ map (k,) (queryValues a)
107− where
108− k = BS.pack (fieldLabelModifier o f)
109−
110−p :: Proxy QueryValues
111−p = Proxy
src/Network/PagerDuty/Internal/TH.hsdeleted−96
@@ -1,96 +0,0 @@
1−{-# LANGUAGE TemplateHaskell #-}
2−
3−-- Module : Network.PagerDuty.Internal.TH
4−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
5−-- License : This Source Code Form is subject to the terms of
6−-- the Mozilla Public License, v. 2.0.
7−-- A copy of the MPL can be found in the LICENSE file or
8−-- you can obtain it at http://mozilla.org/MPL/2.0/.
9−-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
10−-- Stability : experimental
11−-- Portability : non-portable (GHC extensions)
12−
13−module Network.PagerDuty.Internal.TH
14− (
15− -- * Requests
16− jsonRequest
17− , queryRequest
18−
19− -- * Compound expressions
20− , deriveNullary
21− , deriveNullaryWith
22− , deriveRecord
23−
24− -- * JSON
25− , deriveJSON
26− , deriveJSONWith
27−
28− -- * Lenses
29− , makeLens
30− , makeFields
31−
32− -- * Re-exported generics
33− , deriveGeneric
34−
35− -- * Re-exported options
36− , dropped
37− , hyphenated
38− , underscored
39− ) where
40−
41−import Control.Applicative
42−import Control.Lens
43−import qualified Data.Aeson.TH as Aeson
44−import Data.Aeson.Types
45−import Data.ByteString (ByteString)
46−import qualified Data.Text.Encoding as Text
47−import Generics.SOP.TH
48−import Language.Haskell.TH
49−import Network.HTTP.Types.QueryLike
50−import Network.PagerDuty.Internal.Options
51−import Network.PagerDuty.Internal.Query
52−
53−jsonRequest :: Name -> Q [Dec]
54−jsonRequest n = concat <$> sequence
55− [ makeLenses n
56− , deriveJSON n
57− , [d|instance QueryLike $(conT n) where toQuery = const []|]
58− ]
59−
60−queryRequest :: Name -> Q [Dec]
61−queryRequest n = concat <$> sequence
62− [ deriveGeneric n
63− , makeLenses n
64− , [d|instance ToJSON $(conT n) where toJSON = const emptyObject|]
65− , [d|instance QueryLike $(conT n) where toQuery = gquery|]
66− ]
67−
68−deriveNullary :: Name -> Q [Dec]
69−deriveNullary = deriveNullaryWith underscored
70−
71−deriveNullaryWith :: Options -> Name -> Q [Dec]
72−deriveNullaryWith o n = concat <$> sequence
73− [ deriveJSONWith o n
74− , [d|instance QueryValues $(conT n) where queryValues = value . toJSON|]
75− ]
76−
77−deriveRecord :: Name -> Q [Dec]
78−deriveRecord n = concat <$> sequence
79− [ deriveJSON n
80− , makeLenses n
81− ]
82−
83−deriveJSON :: Name -> Q [Dec]
84−deriveJSON = deriveJSONWith underscored
85−
86−deriveJSONWith :: Options -> Name -> Q [Dec]
87−deriveJSONWith = Aeson.deriveJSON
88−
89−makeLens :: String -> Name -> Q [Dec]
90−makeLens k = makeLensesWith
91− $ lensRulesFor [(k, drop 1 k)]
92− & simpleLenses .~ True
93−
94−value :: Value -> [ByteString]
95−value (String t) = [Text.encodeUtf8 t]
96−value _ = []
src/Network/PagerDuty/Internal/Types.hsdeleted−497
@@ -1,497 +0,0 @@
1−{-# LANGUAGE BangPatterns #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE FunctionalDependencies #-}
5−{-# LANGUAGE GADTs #-}
6−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7−{-# LANGUAGE KindSignatures #-}
8−{-# LANGUAGE MultiParamTypeClasses #-}
9−{-# LANGUAGE OverloadedStrings #-}
10−{-# LANGUAGE PatternSynonyms #-}
11−{-# LANGUAGE RankNTypes #-}
12−{-# LANGUAGE StandaloneDeriving #-}
13−{-# LANGUAGE TemplateHaskell #-}
14−{-# LANGUAGE TupleSections #-}
15−{-# LANGUAGE ViewPatterns #-}
16−
17−-- Module : Network.PagerDuty.Internal.Types
18−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
19−-- License : This Source Code Form is subject to the terms of
20−-- the Mozilla Public License, v. 2.0.
21−-- A copy of the MPL can be found in the LICENSE file or
22−-- you can obtain it at http://mozilla.org/MPL/2.0/.
23−-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
24−-- Stability : experimental
25−-- Portability : non-portable (GHC extensions)
26−
27−module Network.PagerDuty.Internal.Types where
28−
29−import Control.Applicative
30−import Control.Lens hiding ((.=), Empty)
31−import Control.Monad.IO.Class
32−import Data.Aeson hiding (Error, Key)
33−import qualified Data.Aeson.KeyMap as Map
34−import Data.Aeson.Types (Parser)
35−import Data.ByteString (ByteString)
36−import qualified Data.ByteString.Char8 as BS
37−import Data.ByteString.Conversion hiding (List)
38−import Data.Default.Class
39−import Data.Function (on)
40−import Data.List (deleteBy, intersperse)
41−import Data.Monoid
42−import Data.String
43−import Data.Text (Text)
44−import qualified Data.Text as Text
45−import qualified Data.Text.Encoding as Text
46−import Data.Time (UTCTime, TimeZone, formatTime, utc, timeZoneName)
47−import GHC.TypeLits
48−import Network.HTTP.Client (Manager)
49−import Network.HTTP.Types
50−import Network.HTTP.Types.QueryLike
51−import Network.PagerDuty.Internal.Query
52−import Network.PagerDuty.Internal.TH
53−import Data.Time.Locale.Compat
54−
55−newtype CSV a = CSV [a]
56− deriving (Eq, Show, Semigroup, Monoid)
57−
58−makePrisms ''CSV
59−
60−instance ToByteString a => QueryValues (CSV a)
61−
62−instance ToByteString a => ToByteString (CSV a) where
63− builder (CSV xs) = mconcat . intersperse "," $ map builder xs
64−
65−instance FromJSON a => FromJSON (CSV a) where
66− parseJSON = withText "comma_separated_value" $
67− fmap CSV . traverse (parseJSON . String) . Text.split (== ',')
68−
69−instance ToByteString a => ToJSON (CSV a) where
70− toJSON = String . Text.decodeUtf8 . toByteString'
71−
72−newtype List a = L [a]
73− deriving (Eq, Show, Semigroup, Monoid)
74−
75−deriveJSON ''List
76−makePrisms ''List
77−
78−instance QueryValues a => QueryValues (List a) where
79− queryValues (L xs) = concatMap queryValues xs
80−
81−newtype Bool' = B Bool
82− deriving (Eq, Show)
83−
84−deriveJSON ''Bool'
85−makePrisms ''Bool'
86−
87−instance ToByteString Bool' where
88− builder (B True) = "true"
89− builder (B False) = "false"
90−
91−instance QueryValues Bool'
92−
93−pattern T = B True
94−pattern F = B False
95−
96−newtype Date = D UTCTime
97− deriving (Eq, Ord, Show)
98−
99−makePrisms ''Date
100−
101−instance FromJSON Date where
102− parseJSON = fmap D . parseJSON
103−
104−instance ToJSON Date where
105− toJSON (D d) = toJSON d
106−
107−instance ToByteString Date where
108− builder (D d) = builder
109− (formatTime defaultTimeLocale ("%Y-%m-%dT%XZ") d)
110−
111−instance QueryValues Date
112−
113−newtype TZ = TZ TimeZone
114− deriving (Eq, Show)
115−
116−makePrisms ''TZ
117−
118−instance FromJSON TZ where
119− parseJSON = undefined
120−
121−instance ToJSON TZ where
122− toJSON = toJSON . Text.decodeUtf8 . toByteString'
123−
124−instance ToByteString TZ where
125− builder (TZ tz) = builder (timeZoneName tz)
126−
127−instance QueryValues TZ
128−
129−instance Default TZ where
130− def = TZ utc
131−
132−data Security = Basic | Token
133− deriving (Eq, Show)
134−
135−data Auth (a :: Security) where
136− AuthBasic :: ByteString -> ByteString -> Auth 'Basic
137− AuthToken :: ByteString -> Auth 'Token
138−
139−deriving instance Eq (Auth a)
140−deriving instance Show (Auth a)
141−
142−newtype SubDomain = SubDomain { subDomain :: ByteString }
143− deriving (Eq, Show, IsString, ToByteString)
144−
145−mkSubDomain :: ByteString -> SubDomain
146−mkSubDomain = SubDomain
147−
148−domain :: SubDomain -> ByteString
149−domain (SubDomain s)
150− | base `BS.isSuffixOf` s = s
151− | otherwise = s <> base
152− where
153− base = ".pagerduty.com"
154−
155−-- | The log level and associated logger function.
156−data Logger
157− = None
158− | Debug (Text -> IO ())
159−
160−-- | Log a message using the debug logger, or if none is specified noop.
161−debug :: MonadIO m => Logger -> Text -> m ()
162−debug None = const (return ())
163−debug (Debug f) = liftIO . f
164−
165−-- | The environment containing the parameters required to
166−-- make PagerDuty requests.
167−data Env (s :: Security) = Env
168− { _envDomain :: SubDomain
169− , _envAuth' :: Auth s
170− , _envManager :: Manager
171− , _envLogger :: Logger
172− }
173−
174−makeLenses ''Env
175−
176−envAuth :: forall s s'. Lens (Env s) (Env s') (Auth s) (Auth s')
177−envAuth = lens _envAuth' (\s x -> s { _envAuth' = x })
178−
179−prod :: SubDomain -> Auth s -> Manager -> Env s
180−prod d a m = Env d a m None
181−
182−newtype Code = Code Integer
183− deriving (Eq, Show, Num)
184−
185−deriveJSON ''Code
186−
187−description :: Code -> Text
188−description (Code c) =
189− case c of
190− 2000 -> "Internal Error"
191− 2001 -> "Invalid Input Provided"
192− 2002 -> "Arguments Caused Error"
193− 2003 -> "Missing Arguments"
194− 2004 -> "Invalid 'since' or 'until' Parameter Values"
195− 2005 -> "Invalid Query Date Range"
196− 2006 -> "Authentication Failed"
197− 2007 -> "Account Not Found"
198− 2008 -> "Account Locked"
199− 2009 -> "Only HTTPS Allowed For This Call"
200− 2010 -> "Access Denied"
201− 2011 -> "The action requires a 'requester_id' to be specified"
202− 2012 -> "Your account is expired and cannot use the API"
203− _ -> "Unrecognised error code"
204−
205−class HasMessage s a | s -> a where
206− -- | A short human-readable message describing the error.
207− message :: Lens' s a
208−
209−class HasErrors s a | s -> a where
210− -- | A list of human-readable reasons for the error. These values,
211− -- and even their format, are subject to change.
212− errors :: Lens' s a
213−
214−data IntegrationError = IntegrationError
215− { _ieStatus :: Text
216− , _ieMessage :: Text
217− , _ieErrors :: [Text]
218− } deriving (Eq, Show)
219−
220−deriveRecord ''IntegrationError
221−
222−instance HasMessage IntegrationError Text where message = ieMessage
223−instance HasErrors IntegrationError [Text] where errors = ieErrors
224−
225−status :: Lens' IntegrationError Text
226−status = ieStatus
227−
228−data RESTError = RESTError
229− { _reCode :: Code
230− , _reMessage :: Text
231− , _reErrors :: [Text]
232− } deriving (Eq, Show)
233−
234−deriveRecord ''RESTError
235−
236−instance HasMessage RESTError Text where message = reMessage
237−instance HasErrors RESTError [Text] where errors = reErrors
238−
239−-- | In the case of an error, the PagerDuty error code can give further details
240−-- on the nature of the error.
241−--
242−-- /See:/ 'description'
243−code :: Lens' RESTError Code
244−code = reCode
245−
246−data Error
247− = Internal Text
248− | Integration IntegrationError
249− | REST RESTError
250− deriving (Eq, Show)
251−
252−instance FromJSON Error where
253− parseJSON o = (REST <$> parseJSON o)
254− <|> (Integration <$> parseJSON o)
255−
256−makePrisms ''Error
257−
258−instance HasMessage Error Text where
259− message = lens f g
260− where
261− f (Internal x) = x
262− f (Integration s) = _ieMessage s
263− f (REST s) = _reMessage s
264−
265− g (Internal _) x = Internal x
266− g (Integration s) x = Integration $ s { _ieMessage = x }
267− g (REST s) x = REST $ s { _reMessage = x }
268−
269−data Pager = Pager
270− { _pgOffset :: !Int
271− -- ^ The offset used in the execution of the query.
272− , _pgLimit :: !Int
273− -- ^ The limit used in the execution of the query.
274− , _pgTotal :: !Int
275− -- ^ The total number of records available.
276− , _pgQuery :: Maybe Text
277− -- ^ An optional query= value to be added to the query string.
278− } deriving (Eq, Show)
279−
280−makeLenses ''Pager
281−
282−data Page a = Page
283− { _pgItem :: a
284− , _pgPager :: Maybe Pager
285− }
286−
287−instance FromJSON a => FromJSON (Page a) where
288− parseJSON = withObject "paginated" $ \o -> Page
289− <$> parseJSON (Object o)
290− <*> optional (parse o)
291− where
292− parse o = Pager
293− -- The offset of the first record returned.
294− -- Default is 0.
295− <$> o .: "offset" .!= 0
296− -- The number of records returned.
297− -- Default (and max limit) is 100 for most APIs.
298− <*> o .: "limit" .!= 100
299− <*> o .: "total"
300− <*> o .:? "query"
301−
302−instance ToJSON Pager where
303− toJSON p = object
304− [ "offset" .= _pgOffset p
305− , "limit" .= _pgLimit p
306− ]
307−
308−-- | A path segment.
309−data Path where
310− Path :: Path
311− Seg :: ToByteString a => a -> Path
312−
313−instance Semigroup Path where
314− x <> Path = x
315− Path <> y = y
316− Seg x <> Seg y = Seg (builder x <> "/" <> builder y)
317−
318−instance Monoid Path where
319− mempty = Path
320−
321−instance IsString Path where
322− fromString = Seg
323−
324−instance ToByteString Path where
325− builder Path = mempty
326− builder (Seg x) = builder x
327−
328−(%) :: ToByteString a => Path -> a -> Path
329−a % b = a <> Seg b
330−
331−renderPath :: Path -> ByteString
332−renderPath = toByteString' . mappend v1
333− where
334− v1 :: Path
335− v1 = "/api/v1"
336−
337−data Request a (s :: Security) b where
338− Request :: (QueryLike a, ToJSON a)
339− => { _rqMeth :: !StdMethod
340− , _rqPath :: Path
341− , _rqQuery :: Query
342− , _rqBody :: a
343− , _rqPager :: Maybe Pager
344− , _rqUnwrap :: Value -> Parser Value
345− }
346− -> Request a s b
347−
348−instance ToJSON (Request a s b) where
349− -- Manually unwrapped to ensure GADT constraint holds.
350− toJSON (Request _ _ _ b p _) = Object $
351− let Object x = toJSON b
352− in case toJSON p of
353− (Object y) -> x <> y
354− _ -> x
355−
356−type Unwrap = Getting (First Value) Value Value
357−
358−-- | Create a defaulted request from the payload type.
359−mk :: (QueryLike a, ToJSON a) => a -> Request a s b
360−mk x = Request GET mempty mempty x Nothing pure
361−
362−empty :: Request Empty s r
363−empty = mk Empty
364−
365−-- | Lens into the body of a request.
366−upd :: (QueryLike a, ToJSON a) => Lens' (Request a s b) a
367−upd = lens _rqBody (\(Request m p q _ g u) x -> Request m p q x g u)
368−
369−-- | Drop the security constraint.
370−auth :: Request a s b -> Request a t b
371−auth (Request x m p q g u) = Request x m p q g u
372−
373−meth :: Lens' (Request a s b) StdMethod
374−meth = lens _rqMeth (\r x -> r { _rqMeth = x })
375−
376−path :: Lens' (Request a s b) Path
377−path = lens _rqPath (\r x -> r { _rqPath = x })
378−
379−query :: QueryValueLike v
380− => Lens (Request a s b) (Request a s b) Query [(ByteString, v)]
381−query = lens _rqQuery (\r x -> r { _rqQuery = toQuery x })
382−
383−pager :: Lens' (Request a s b) (Maybe Pager)
384−pager = lens _rqPager (\r x -> r { _rqPager = x })
385−
386−unwrap :: Setter (Request a s b) (Request a s b) (Value -> Parser Value) Unwrap
387−unwrap f r = f (_rqUnwrap r) <&> \k -> r { _rqUnwrap = g k }
388− where
389− g k x = maybe (fail "Failed to extract nested keys.") return (x ^? k)
390−
391−-- | Exists primarily to obtain a constraint for the 'paginate' function.
392−class Paginate a where
393− next :: Request a s b -> Maybe Pager -> Maybe (Request a s b)
394− next rq = maybe Nothing go
395− where
396− go x | x ^. pgTotal == 0 = Nothing
397− | otherwise = Just $
398− rq & pager ?~ (x & pgOffset +~ x ^. pgTotal)
399− & query %~ (add . clear)
400− where
401− add :: Query -> Query
402− add = maybe id ((:) . (k,) . Just . Text.encodeUtf8) (x ^. pgQuery)
403−
404− clear :: Query -> Query
405− clear = deleteBy ((==) `on` fst) (k, Nothing)
406−
407− k :: ByteString
408− k = "query"
409−
410−newtype Key (a :: Symbol) = Key Text
411− deriving (Eq, Show, IsString)
412−
413−mkKey :: Text -> Key a
414−mkKey = Key
415−
416−instance FromJSON (Key a) where
417− parseJSON = withText "key" (return . Key)
418−
419−instance ToJSON (Key a) where
420− toJSON (Key k) = toJSON k
421−
422−instance ToByteString (Key a) where
423− builder (Key k) = builder k
424−
425−instance QueryValues (Key a)
426−
427−instance QueryValueLike (Key a) where
428− toQueryValue = Just . toByteString'
429−
430−type ServiceKey = Key "service"
431−type IncidentKey = Key "incident"
432−
433−newtype Id (a :: Symbol) = Id Text
434− deriving (Eq, Show, IsString)
435−
436−mkId :: Text -> Id a
437−mkId = Id
438−
439−instance FromJSON (Id a) where
440− parseJSON = withText "id" (return . Id)
441−
442−instance ToJSON (Id a) where
443− toJSON (Id i) = toJSON i
444−
445−instance ToByteString (Id a) where
446− builder (Id i) = builder i
447−
448−instance QueryValues (Id a)
449−
450−instance QueryValueLike (Id a) where
451− toQueryValue = Just . toByteString'
452−
453−type AlertId = Id "alert"
454−type ContactId = Id "contact"
455−type EmailFilterId = Id "email-filter"
456−type EscalationPolicyId = Id "escalation-policy"
457−type EscalationRuleId = Id "escalation-rule"
458−type IncidentId = Id "incident"
459−type LogEntryId = Id "log-entry"
460−type NoteId = Id "note"
461−type NotificationRuleId = Id "notification-rule"
462−type OverrideId = Id "schedule-override"
463−type RequesterId = Id "requester"
464−type ScheduleId = Id "schedule"
465−type ServiceId = Id "service"
466−type UserId = Id "user"
467−type VendorId = Id "vendor"
468−type WebhookId = Id "webhook"
469−type WindowId = Id "maintenance-window"
470−
471−data Empty = Empty
472−
473−instance ToJSON Empty where
474− toJSON = const (object [])
475−
476−instance FromJSON Empty where
477− parseJSON = withObject "empty" f
478− where
479− f !o | Map.null o = pure Empty
480− | otherwise = fail "Unexpected non-empty JSON object."
481−
482−instance QueryLike Empty where
483− toQuery = const []
484−
485−newtype Address = Address Text
486− deriving (Eq, Show, IsString)
487−
488−mkAddress :: Text -> Address
489−mkAddress = Address
490−
491−deriveJSON ''Address
492−makePrisms ''Address
493−
494−instance ToByteString Address where
495− builder (Address a) = builder a
496−
497−instance QueryValues Address
src/Network/PagerDuty/REST.hs+24−44
@@ -2,7 +2,7 @@
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3
3
4-- Module : Network.PagerDuty.REST
4-- Module : Network.PagerDuty.REST
5−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
5+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
6-- License : This Source Code Form is subject to the terms of
6-- License : This Source Code Form is subject to the terms of
7-- the Mozilla Public License, v. 2.0.
7-- the Mozilla Public License, v. 2.0.
8-- A copy of the MPL can be found in the LICENSE file or
8-- A copy of the MPL can be found in the LICENSE file or
@@ -15,11 +15,7 @@ module Network.PagerDuty.REST
15 (
15 (
16 -- * Sending requests
16 -- * Sending requests
17 send
17 send
18− , sendWith
19 , paginate
18 , paginate
20− , paginateWith
21−
22− , module Network.PagerDuty.Types
23 ) where
19 ) where
24
20
25import Control.Applicative
21import Control.Applicative
@@ -27,69 +23,53 @@ import Control.Lens
27import Control.Monad
23import Control.Monad
28import Control.Monad.IO.Class
24import Control.Monad.IO.Class
29import Control.Monad.Trans
25import Control.Monad.Trans
30−import Data.Aeson (FromJSON)
26+import Data.Aeson (FromJSON)
31import Data.Conduit
27import Data.Conduit
28+import Data.Default
32import Data.Monoid
29import Data.Monoid
33−import Network.HTTP.Client (Manager)
30+import Network.HTTP.Client (Manager)
34−import qualified Network.HTTP.Client as Client
31+import qualified Network.HTTP.Client as Client
35import Network.HTTP.Types
32import Network.HTTP.Types
36−import Network.PagerDuty.Internal.IO
33+import Network.PagerDuty.IO
37−import Network.PagerDuty.Internal.Types
38import Network.PagerDuty.Types
34import Network.PagerDuty.Types
39
35
40−-- FIXME: verify correct actions are all paginated
41−-- FIXME: Ensure RequesterId parameter is always most significant param
42−-- FIXME: add smart constructors for all types, for testing purposes
43−
44−-- | /See:/ 'sendWith'
45send :: (MonadIO m, FromJSON b)
36send :: (MonadIO m, FromJSON b)
46− => SubDomain
37+ => Auth s
47− -> Auth s
38+ -> SubDomain
48 -> Manager
39 -> Manager
49 -> Request a s b
40 -> Request a s b
50 -> m (Either Error b)
41 -> m (Either Error b)
51−send d a m = sendWith (prod d a m)
52−
53−sendWith :: (MonadIO m, FromJSON b)
54− => Env s
55− -> Request a s b
56− -> m (Either Error b)
57−sendWith e = liftM (fmap _pgItem) . http e
42+send a s m = liftM (fmap fst) . http a s m
58
43
59−-- | /See:/ 'paginateWith'
60paginate :: (MonadIO m, Paginate a, FromJSON b)
44paginate :: (MonadIO m, Paginate a, FromJSON b)
61− => SubDomain
45+ => Auth s
62− -> Auth s
46+ -> SubDomain
63 -> Manager
47 -> Manager
64 -> Request a s b
48 -> Request a s b
65 -> Source m (Either Error b)
49 -> Source m (Either Error b)
66−paginate d a m = paginateWith (prod d a m)
50+paginate a d m = go
67−
68−paginateWith :: (MonadIO m, Paginate a, FromJSON b)
69− => Env s
70− -> Request a s b
71− -> Source m (Either Error b)
72−paginateWith e = go
73 where
51 where
74 go rq = do
52 go rq = do
75− rs <- lift (http e rq)
53+ rs <- lift (http a d m rq)
76− yield (_pgItem <$> rs)
54+ yield (fst <$> rs)
77 either (const (return ()))
55 either (const (return ()))
78− (maybe (return ()) go . next rq . _pgPager)
56+ (maybe (return ()) go . next rq . snd)
79 rs
57 rs
80
58
81http :: (MonadIO m, FromJSON b)
59http :: (MonadIO m, FromJSON b)
82− => Env s
60+ => Auth s
61+ -> SubDomain
62+ -> Manager
83 -> Request a s b
63 -> Request a s b
84− -> m (Either Error (Page b))
64+ -> m (Either Error (b, Maybe Pager))
85−http e rq = request (e ^. envManager) (e ^. envLogger) rq $ raw
65+http a (SubDomain h) m rq = request m rq $ raw
86− { Client.host = domain (e ^. envDomain)
66+ { Client.host = h
87 , Client.path = renderPath (rq ^. path)
67 , Client.path = renderPath (rq ^. path)
88 , Client.queryString = renderQuery False (rq ^. query)
68 , Client.queryString = renderQuery False (rq ^. query)
89 }
69 }
90 where
70 where
91− raw = case e ^. envAuth of
71+ raw = case a of
92− AuthBasic u p -> Client.applyBasicAuth u p Client.defaultRequest
72+ AuthBasic u p -> Client.applyBasicAuth u p def
93− AuthToken t -> Client.defaultRequest
73+ AuthToken t -> def
94 { Client.requestHeaders = [("Authorization", "Token token=" <> t)]
74 { Client.requestHeaders = [("Authorization", "Token token=" <> t)]
95 }
75 }
src/Network/PagerDuty/REST/Alerts.hs+35−37
@@ -1,10 +1,9 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE TemplateHaskell #-}
3{-# LANGUAGE TemplateHaskell #-}
4−{-# LANGUAGE TypeFamilies #-}
5
4
6-- Module : Network.PagerDuty.REST.Alerts
5-- Module : Network.PagerDuty.REST.Alerts
7−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
6+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
8-- License : This Source Code Form is subject to the terms of
7-- License : This Source Code Form is subject to the terms of
9-- the Mozilla Public License, v. 2.0.
8-- the Mozilla Public License, v. 2.0.
10-- A copy of the MPL can be found in the LICENSE file or
9-- A copy of the MPL can be found in the LICENSE file or
@@ -21,12 +20,11 @@
21-- This API allows you to access read-only data regarding what alerts have been
20-- This API allows you to access read-only data regarding what alerts have been
22-- sent to your users.
21-- sent to your users.
23--
22--
24−-- /See:/ <http://developer.pagerduty.com/documentation/rest/alerts>
23+-- See: <http://developer.pagerduty.com/documentation/rest/alerts>
25module Network.PagerDuty.REST.Alerts
24module Network.PagerDuty.REST.Alerts
26 (
25 (
27 -- * List Alerts
26 -- * List Alerts
28− ListAlerts
29− , listAlerts
27+ listAlerts
30 , laSince
28 , laSince
31 , laUntil
29 , laUntil
32 , laFilter
30 , laFilter
@@ -43,12 +41,10 @@ module Network.PagerDuty.REST.Alerts
43 , alertAddress
41 , alertAddress
44 ) where
42 ) where
45
43
46−import Control.Lens hiding (Empty)
44+import Control.Lens
47−import Data.Aeson.Lens
45+import Data.Aeson.Lens
48−import Data.Time
49−import Network.PagerDuty.Internal.TH
46+import Network.PagerDuty.TH
50−import Network.PagerDuty.Internal.Types
47+import Network.PagerDuty.Types
51−import Network.PagerDuty.REST.Users (User)
52
48
53alerts :: Path
49alerts :: Path
54alerts = "alerts"
50alerts = "alerts"
@@ -60,7 +56,7 @@ data AlertType
60 | Push
56 | Push
61 deriving (Eq, Show)
57 deriving (Eq, Show)
62
58
63−deriveNullary ''AlertType
59+deriveJSON ''AlertType
64
60
65data Alert = Alert
61data Alert = Alert
66 { _alertId :: AlertId
62 { _alertId :: AlertId
@@ -70,46 +66,27 @@ data Alert = Alert
70 , _alertAddress :: Address
66 , _alertAddress :: Address
71 } deriving (Eq, Show)
67 } deriving (Eq, Show)
72
68
73−deriveRecord ''Alert
69+deriveJSON ''Alert
70+makeLenses ''Alert
74
71
75data ListAlerts = ListAlerts
72data ListAlerts = ListAlerts
76 { _laSince' :: Date
73 { _laSince' :: Date
77 , _laUntil' :: Date
74 , _laUntil' :: Date
78 , _laFilter' :: Maybe AlertType
75 , _laFilter' :: Maybe AlertType
79− , _laTimeZone' :: Maybe TZ
76+ , _laTimeZone' :: Maybe TimeZone
80 } deriving (Eq, Show)
77 } deriving (Eq, Show)
81
78
82instance Paginate ListAlerts
79instance Paginate ListAlerts
83
80
84−queryRequest ''ListAlerts
81+deriveJSON ''ListAlerts
85−
82+makeLenses ''ListAlerts
86−-- | The start of the date range over which you want to search.
87−laSince :: Lens' (Request ListAlerts s b) UTCTime
88−laSince = upd.laSince'._D
89−
90−-- | The end of the date range over which you want to search.
91−-- This should be in the same format as 'since'.
92−--
93−-- The size of the date range must be less than 3 months.
94−laUntil :: Lens' (Request ListAlerts s b) UTCTime
95−laUntil = upd.laUntil'._D
96−
97−-- | Returns only the alerts of the said 'AlertType' type.
98−laFilter :: Lens' (Request ListAlerts s b) (Maybe AlertType)
99−laFilter = upd.laFilter'
100−
101−-- | Time zone in which dates in the result will be rendered.
102−--
103−-- /Default:/ account time zone.
104−laTimeZone :: Lens' (Request ListAlerts s b) (Maybe TimeZone)
105−laTimeZone = upd.laTimeZone'.mapping _TZ
106
83
107-- | List existing alerts for a given time range, optionally filtered by type
84-- | List existing alerts for a given time range, optionally filtered by type
108-- (SMS, Email, Phone, or Push).
85-- (SMS, Email, Phone, or Push).
109--
86--
110-- @GET \/alerts@
87-- @GET \/alerts@
111--
88--
112−-- /See:/ <http://developer.pagerduty.com/documentation/rest/alerts/list>
89+-- See: <http://developer.pagerduty.com/documentation/rest/alerts/list>
113listAlerts :: Date -- ^ 'laSince'
90listAlerts :: Date -- ^ 'laSince'
114 -> Date -- ^ 'laUntil'
91 -> Date -- ^ 'laUntil'
115 -> Request ListAlerts s [Alert]
92 -> Request ListAlerts s [Alert]
@@ -121,3 +98,24 @@ listAlerts s u =
121 , _laTimeZone' = Nothing
98 , _laTimeZone' = Nothing
122 } & path .~ alerts
99 } & path .~ alerts
123 & unwrap .~ key "alerts"
100 & unwrap .~ key "alerts"
101+
102+-- | The start of the date range over which you want to search.
103+laSince :: Lens' (Request ListAlerts s r) Date
104+laSince = upd.laSince'
105+
106+-- | The end of the date range over which you want to search.
107+-- This should be in the same format as 'since'.
108+--
109+-- The size of the date range must be less than 3 months.
110+laUntil :: Lens' (Request ListAlerts s r) Date
111+laUntil = upd.laUntil'
112+
113+-- | Returns only the alerts of the said 'AlertType' type.
114+laFilter :: Lens' (Request ListAlerts s r) (Maybe AlertType)
115+laFilter = upd.laFilter'
116+
117+-- | Time zone in which dates in the result will be rendered.
118+--
119+-- Defaults to account time zone.
120+laTimeZone :: Lens' (Request ListAlerts s r) (Maybe TimeZone)
121+laTimeZone = upd.laTimeZone'
src/Network/PagerDuty/REST/EscalationPolicies.hs+189−106
@@ -1,13 +1,9 @@
1−{-# LANGUAGE DataKinds #-}
1+{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE ExtendedDefaultRules #-}
3−{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE TemplateHaskell #-}
3+{-# LANGUAGE TemplateHaskell #-}
5−{-# LANGUAGE TypeFamilies #-}
6−
7−{-# OPTIONS_GHC -fno-warn-type-defaults #-}
8
4
9-- Module : Network.PagerDuty.REST.EscalationPolicies
5-- Module : Network.PagerDuty.REST.EscalationPolicies
10−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
6+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
11-- License : This Source Code Form is subject to the terms of
7-- License : This Source Code Form is subject to the terms of
12-- the Mozilla Public License, v. 2.0.
8-- the Mozilla Public License, v. 2.0.
13-- A copy of the MPL can be found in the LICENSE file or
9-- A copy of the MPL can be found in the LICENSE file or
@@ -18,19 +14,14 @@
18
14
19-- | This API lets you access and manipulate escalation policies and rules.
15-- | This API lets you access and manipulate escalation policies and rules.
20--
16--
21−-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies>
17+-- See: <http://developer.pagerduty.com/documentation/rest/escalation_policies>
22module Network.PagerDuty.REST.EscalationPolicies
18module Network.PagerDuty.REST.EscalationPolicies
23 (
19 (
24 -- * List Policies
20 -- * List Policies
25− ListPolicies
26− , listPolicies
21+ listPolicies
27 , lpQuery
22 , lpQuery
28
23
29− -- * List On Call Policies
30− , listOnCallPolicies
31−
32 -- * Create Policy
24 -- * Create Policy
33− , CreatePolicy
34 , createPolicy
25 , createPolicy
35 , cpName
26 , cpName
36 , cpRepeatEnabled
27 , cpRepeatEnabled
@@ -41,7 +32,6 @@ module Network.PagerDuty.REST.EscalationPolicies
41 , getPolicy
32 , getPolicy
42
33
43 -- * Update Policy
34 -- * Update Policy
44− , UpdatePolicy
45 , updatePolicy
35 , updatePolicy
46 , upName
36 , upName
47 , upRepeatEnabled
37 , upRepeatEnabled
@@ -52,54 +42,155 @@ module Network.PagerDuty.REST.EscalationPolicies
52 , deletePolicy
42 , deletePolicy
53
43
54 -- * Types
44 -- * Types
45+ , Target (..)
46+ , _TSchedule
47+ , _TUser
48+
49+ , ScheduleTarget
50+ , stgtId
51+ , stgtName
52+
53+ , UserTarget
54+ , utgtId
55+ , utgtName
56+ , utgtEmail
57+ , utgtTimeZone
58+ , utgtColor
59+
60+ , Rule
61+ , ruleId
62+ , ruleEscalationDelayInMinutes
63+ , ruleTargets
64+
55 , Policy
65 , Policy
56− , pId
66+ , policyId
57− , pName
67+ , policyName
58− , pNumLoops
68+ , policyNumLoops
59− , pRules
69+ , policyRules
60− , pServices
70+ , policyServices
61 ) where
71 ) where
62
72
63−import Control.Lens hiding (Empty)
73+import Control.Applicative ((<$>))
74+import Control.Lens
75+import Data.Aeson
64import Data.Aeson.Lens
76import Data.Aeson.Lens
77+import qualified Data.HashMap.Strict as Map
65−import Data.Text (Text)
78+import Data.Text (Text)
79+import qualified Data.Text as Text
66import Network.HTTP.Types
80import Network.HTTP.Types
67−import Network.PagerDuty.Internal.TH
81+import Network.PagerDuty.REST.Services (Service)
82+import Network.PagerDuty.TH
68−import Network.PagerDuty.Internal.Types
83+import Network.PagerDuty.Types
69−import Network.PagerDuty.REST.Services (Service)
70−
71−import Network.PagerDuty.REST.EscalationPolicies.EscalationRules
72−
73−default (Path)
74
84
75policies :: Path
85policies :: Path
76policies = "escalation_policies"
86policies = "escalation_policies"
77
87
88+data ScheduleTarget = ScheduleTarget
89+ { _stgtId :: ScheduleId
90+ , _stgtName :: Text
91+ } deriving (Eq, Show)
92+
93+deriveJSON ''ScheduleTarget
94+
95+-- | The id of the target.
96+makeLens "_stgtId" ''ScheduleTarget
97+
98+-- | The name of the target.
99+makeLens "_stgtName" ''ScheduleTarget
100+
101+data UserTarget = UserTarget
102+ { _utgtId :: UserId
103+ , _utgtName :: Text
104+ , _utgtEmail :: Email
105+ , _utgtTimeZone :: TimeZone
106+ , _utgtColor :: Text
107+ } deriving (Eq, Show)
108+
109+deriveJSON ''UserTarget
110+
111+-- | The id of the user.
112+makeLens "_utgtId" ''UserTarget
113+
114+-- | The name of the user.
115+makeLens "_utgtName" ''UserTarget
116+
117+-- | The user's email address.
118+makeLens "_utgtEmail" ''UserTarget
119+
120+-- | The user's personal time zone.
121+makeLens "_utgtTimeZone" ''UserTarget
122+
123+-- | The color used to represent the user in schedules.
124+makeLens "_utgtColor" ''UserTarget
125+
126+data Target
127+ = TSchedule ScheduleTarget
128+ | TUser UserTarget
129+ deriving (Eq, Show)
130+
131+-- type: A representation of the type of the target.
132+-- Will be either schedule or user.
133+instance FromJSON Target where
134+ parseJSON = withObject "target" $ \o -> do
135+ t <- o .: "type"
136+ case t of
137+ "schedule" -> f o TSchedule
138+ "user" -> f o TUser
139+ _ -> fail $ "Unrecognised target type: " ++ Text.unpack t
140+ where
141+ f o g = g <$> parseJSON (Object o)
142+
143+instance ToJSON Target where
144+ toJSON t = Object (Map.insert "type" (String k) o)
145+ where
146+ (k, Object o) = case t of
147+ TSchedule s -> ("schedule", toJSON s)
148+ TUser u -> ("user", toJSON u)
149+
150+makePrisms ''Target
151+
152+data Rule = Rule
153+ { _ruleId :: RuleId
154+ , _ruleEscalationDelayInMinutes :: !Int
155+ , _ruleTargets :: [Target]
156+ } deriving (Eq, Show)
157+
158+deriveJSON ''Rule
159+
160+-- | The ID of the escalation rule.
161+makeLens "_ruleId" ''Rule
162+
163+-- | The amount of time before an incident escalates away from this rule.
164+makeLens "_ruleEscalationDelayInMinutes" ''Rule
165+
166+-- | A list of targets which an incident will be assigned to upon reaching this rule.
167+makeLens "_ruleTargets" ''Rule
168+
78data Policy = Policy
169data Policy = Policy
79− { _pId :: EscalationPolicyId
170+ { _policyId :: PolicyId
80− , _pName :: Text
171+ , _policyName :: Text
81− , _pNumLoops :: !Int
172+ , _policyNumLoops :: !Int
82− , _pRules :: [Rule]
173+ , _policyRules :: [Rule]
83− , _pServices :: [Service]
174+ , _policyServices :: [Service]
84 } deriving (Eq, Show)
175 } deriving (Eq, Show)
85
176
86deriveJSON ''Policy
177deriveJSON ''Policy
87
178
88-- | The ID of the escalation policy.
179-- | The ID of the escalation policy.
89−makeLens "_pId" ''Policy
180+makeLens "_policyId" ''Policy
90
181
91-- | The name of the escalation policy.
182-- | The name of the escalation policy.
92−makeLens "_pName" ''Policy
183+makeLens "_policyName" ''Policy
93
184
94-- | The number of times the escalation policy will repeat after
185-- | The number of times the escalation policy will repeat after
95-- reaching the end of its escalation.
186-- reaching the end of its escalation.
96−makeLens "_pNumLoops" ''Policy
187+makeLens "_policyNumLoops" ''Policy
97
188
98-- | A list of the policy's escalation rules in order of escalation.
189-- | A list of the policy's escalation rules in order of escalation.
99−makeLens "_pRules" ''Policy
190+makeLens "_policyRules" ''Policy
100
191
101-- | A list of services using this escalation policy.
192-- | A list of services using this escalation policy.
102−makeLens "_pServices" ''Policy
193+makeLens "_policyServices" ''Policy
103
194
104newtype ListPolicies = ListPolicies
195newtype ListPolicies = ListPolicies
105 { _lpQuery' :: Maybe Text
196 { _lpQuery' :: Maybe Text
@@ -107,18 +198,14 @@ newtype ListPolicies = ListPolicies
107
198
108instance Paginate ListPolicies
199instance Paginate ListPolicies
109
200
110−queryRequest ''ListPolicies
201+deriveJSON ''ListPolicies
111−
202+makeLenses ''ListPolicies
112−-- | Filters the result, showing only the escalation policies
113−-- whose names match the query.
114−lpQuery :: Lens' (Request ListPolicies s b) (Maybe Text)
115−lpQuery = upd.lpQuery'
116
203
117-- | List all the existing escalation policies.
204-- | List all the existing escalation policies.
118--
205--
119-- @GET \/escalation_policies@
206-- @GET \/escalation_policies@
120--
207--
121−-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/list>
208+-- See: <http://developer.pagerduty.com/documentation/rest/escalation_policies/list>
122listPolicies :: Request ListPolicies s [Policy]
209listPolicies :: Request ListPolicies s [Policy]
123listPolicies =
210listPolicies =
124 mk ListPolicies
211 mk ListPolicies
@@ -126,104 +213,83 @@ listPolicies =
126 } & path .~ policies
213 } & path .~ policies
127 & unwrap .~ key "escalation_policies"
214 & unwrap .~ key "escalation_policies"
128
215
129−-- | List all the existing escalation policies with currently on-call users.
216+-- | Filters the result, showing only the escalation policies
130−--
217+-- whose names match the query.
131−-- If the start and end of an on-call object are null, then the user is always
132−-- on-call for an escalation policy level.
133−--
134−-- @GET \/escalation_policies\/on_call@
135−--
136−-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/on_call>
137−listOnCallPolicies :: Request ListPolicies s [Policy]
218+lpQuery :: Lens' (Request ListPolicies s r) (Maybe Text)
138−listOnCallPolicies = listPolicies & path .~ policies % "on_call"
219+lpQuery = upd.lpQuery'
139
220
140data CreatePolicy = CreatePolicy
221data CreatePolicy = CreatePolicy
141 { _cpName' :: Text
222 { _cpName' :: Text
142− , _cpRepeatEnabled' :: Bool'
223+ , _cpRepeatEnabled' :: Maybe Bool
143 , _cpNumLoops' :: Maybe Int
224 , _cpNumLoops' :: Maybe Int
144 , _cpEscalationRules' :: [Rule] -- ^ Should be List1
225 , _cpEscalationRules' :: [Rule] -- ^ Should be List1
145 } deriving (Eq, Show)
226 } deriving (Eq, Show)
146
227
147−jsonRequest ''CreatePolicy
228+deriveJSON ''CreatePolicy
148−
229+makeLenses ''CreatePolicy
149−-- | The name of the escalation policy.
150−cpName :: Lens' (Request CreatePolicy s b) Text
151−cpName = upd.cpName'
152−
153−-- | Whether or not to allow this policy to repeat its escalation
154−-- rules after the last rule is finished.
155−--
156−-- /Default:/ false.
157−cpRepeatEnabled :: Lens' (Request CreatePolicy s b) Bool
158−cpRepeatEnabled = upd.cpRepeatEnabled'._B
159−
160−-- | The number of times to loop over the set of rules in this escalation policy.
161−cpNumLoops :: Lens' (Request CreatePolicy s b) (Maybe Int)
162−cpNumLoops = upd.cpNumLoops'
163−
164−-- | The escalation rules for this policy.
165−cpEscalationRules :: Lens' (Request CreatePolicy s b) [Rule]
166−cpEscalationRules = upd.cpEscalationRules'
167
230
168-- | Creates an existing escalation policy and rules.
231-- | Creates an existing escalation policy and rules.
169--
232--
170-- @POST \/escalation_policies@
233-- @POST \/escalation_policies@
171--
234--
172−-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/create>
235+-- See: <http://developer.pagerduty.com/documentation/rest/escalation_policies/create>
173−createPolicy :: EscalationPolicyId
236+createPolicy :: PolicyId
174 -> Text -- ^ 'creName'
237 -> Text -- ^ 'creName'
175 -> [Rule] -- ^ 'creEscalationRules'
238 -> [Rule] -- ^ 'creEscalationRules'
176 -> Request CreatePolicy s Policy
239 -> Request CreatePolicy s Policy
177createPolicy i n rs =
240createPolicy i n rs =
178 mk CreatePolicy
241 mk CreatePolicy
179 { _cpName' = n
242 { _cpName' = n
180− , _cpRepeatEnabled' = F
243+ , _cpRepeatEnabled' = Nothing
181 , _cpNumLoops' = Nothing
244 , _cpNumLoops' = Nothing
182 , _cpEscalationRules' = rs
245 , _cpEscalationRules' = rs
183 } & meth .~ PUT
246 } & meth .~ PUT
184 & path .~ policies % i
247 & path .~ policies % i
185 & unwrap .~ key "escalation_policy"
248 & unwrap .~ key "escalation_policy"
186
249
250+-- | The name of the escalation policy.
251+cpName :: Lens' (Request CreatePolicy s r) Text
252+cpName = upd.cpName'
253+
254+-- | Whether or not to allow this policy to repeat its escalation
255+-- rules after the last rule is finished.
256+--
257+-- Defaults to false.
258+cpRepeatEnabled :: Lens' (Request CreatePolicy s r) (Maybe Bool)
259+cpRepeatEnabled = upd.cpRepeatEnabled'
260+
261+-- | The number of times to loop over the set of rules in this escalation policy.
262+cpNumLoops :: Lens' (Request CreatePolicy s r) (Maybe Int)
263+cpNumLoops = upd.cpNumLoops'
264+
265+-- | The escalation rules for this policy.
266+cpEscalationRules :: Lens' (Request CreatePolicy s r) [Rule]
267+cpEscalationRules = upd.cpEscalationRules'
268+
187-- | Get information about an existing escalation policy and its rules.
269-- | Get information about an existing escalation policy and its rules.
188--
270--
189-- @GET \/escalation_policies\/\:id@
271-- @GET \/escalation_policies\/\:id@
190--
272--
191−-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/show>
273+-- See: <http://developer.pagerduty.com/documentation/rest/escalation_policies/show>
192−getPolicy :: EscalationPolicyId -> Request Empty s Policy
274+getPolicy :: PolicyId -> Request Empty s Policy
193getPolicy i = empty & path .~ policies % i & unwrap .~ key "escalation_policy"
275getPolicy i = empty & path .~ policies % i & unwrap .~ key "escalation_policy"
194
276
195data UpdatePolicy = UpdatePolicy
277data UpdatePolicy = UpdatePolicy
196 { _upName' :: Maybe Text
278 { _upName' :: Maybe Text
197− , _upRepeatEnabled' :: Maybe Bool'
279+ , _upRepeatEnabled' :: Maybe Bool
198 , _upNumLoops' :: Maybe Int
280 , _upNumLoops' :: Maybe Int
199 , _upEscalationRules' :: [Rule]
281 , _upEscalationRules' :: [Rule]
200 } deriving (Eq, Show)
282 } deriving (Eq, Show)
201
283
202−jsonRequest ''UpdatePolicy
284+deriveJSON ''UpdatePolicy
203−
285+makeLenses ''UpdatePolicy
204−-- | The name of the escalation policy.
205−upName :: Lens' (Request UpdatePolicy s b) (Maybe Text)
206−upName = upd.upName'
207−
208−-- | Whether or not to allow this policy to repeat its escalation
209−-- rules after the last rule is finished.
210−upRepeatEnabled :: Lens' (Request UpdatePolicy s b) (Maybe Bool)
211−upRepeatEnabled = upd.upRepeatEnabled'.mapping _B
212−
213−-- | The number of times to loop over the set of rules in this escalation policy.
214−upNumLoops :: Lens' (Request UpdatePolicy s b) (Maybe Int)
215−upNumLoops = upd.upNumLoops'
216−
217−-- | The escalation rules for this policy.
218−upEscalationRules :: Lens' (Request UpdatePolicy s b) [Rule]
219−upEscalationRules = upd.upEscalationRules'
220
286
221-- | Updates an existing escalation policy and rules.
287-- | Updates an existing escalation policy and rules.
222--
288--
223-- @PUT \/escalation_policies\/\:id@
289-- @PUT \/escalation_policies\/\:id@
224--
290--
225−-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/update>
291+-- See: <http://developer.pagerduty.com/documentation/rest/escalation_policies/update>
226−updatePolicy :: EscalationPolicyId -> Request UpdatePolicy s Policy
292+updatePolicy :: PolicyId -> Request UpdatePolicy s Policy
227updatePolicy i =
293updatePolicy i =
228 mk UpdatePolicy
294 mk UpdatePolicy
229 { _upName' = Nothing
295 { _upName' = Nothing
@@ -234,11 +300,28 @@ updatePolicy i =
234 & path .~ policies % i
300 & path .~ policies % i
235 & unwrap .~ key "escalation_policy"
301 & unwrap .~ key "escalation_policy"
236
302
303+-- | The name of the escalation policy.
304+upName :: Lens' (Request UpdatePolicy s r) (Maybe Text)
305+upName = upd.upName'
306+
307+-- | Whether or not to allow this policy to repeat its escalation
308+-- rules after the last rule is finished.
309+upRepeatEnabled :: Lens' (Request UpdatePolicy s r) (Maybe Bool)
310+upRepeatEnabled = upd.upRepeatEnabled'
311+
312+-- | The number of times to loop over the set of rules in this escalation policy.
313+upNumLoops :: Lens' (Request UpdatePolicy s r) (Maybe Int)
314+upNumLoops = upd.upNumLoops'
315+
316+-- | The escalation rules for this policy.
317+upEscalationRules :: Lens' (Request UpdatePolicy s r) [Rule]
318+upEscalationRules = upd.upEscalationRules'
319+
237-- | Deletes an existing escalation policy and rules. The escalation policy
320-- | Deletes an existing escalation policy and rules. The escalation policy
238-- must not be in use by any services.
321-- must not be in use by any services.
239--
322--
240-- @DELETE \/escalation_policies\/\:id@
323-- @DELETE \/escalation_policies\/\:id@
241--
324--
242−-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/delete>
325+-- See: <http://developer.pagerduty.com/documentation/rest/escalation_policies/delete>
243−deletePolicy :: EscalationPolicyId -> Request Empty s Empty
326+deletePolicy :: PolicyId -> Request Empty s Empty
244deletePolicy i = empty & meth .~ DELETE & path .~ policies % i
327deletePolicy i = empty & meth .~ DELETE & path .~ policies % i
src/Network/PagerDuty/REST/EscalationPolicies/EscalationRules.hsdeleted−277
@@ -1,277 +0,0 @@
1−{-# LANGUAGE ExtendedDefaultRules #-}
2−{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE TemplateHaskell #-}
5−
6−{-# OPTIONS_GHC -fno-warn-type-defaults #-}
7−
8−-- Module : Network.PagerDuty.REST.EscalationPolicies.EscalationRules
9−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
10−-- License : This Source Code Form is subject to the terms of
11−-- the Mozilla Public License, v. 2.0.
12−-- A copy of the MPL can be found in the LICENSE file or
13−-- you can obtain it at http://mozilla.org/MPL/2.0/.
14−-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
15−-- Stability : experimental
16−-- Portability : non-portable (GHC extensions)
17−
18−-- | This API lets you access and manipulate escalation rules of an existing
19−-- escalation policy.
20−--
21−-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/escalation_rules>
22−module Network.PagerDuty.REST.EscalationPolicies.EscalationRules
23− (
24− -- * List Rules
25− listRules
26−
27− -- * Create Rule
28− , CreateRule
29− , createRule
30− , crEscalationDelayInMinutes
31− , crTargets
32−
33− -- * Get Rule
34− , getRule
35−
36− -- * Update Rules
37− , UpdateRules
38− , updateRules
39− , urEscalationRules
40−
41− -- * Update Rule
42− , UpdateRule
43− , updateRule
44− , urEscalationDelayInMinutes
45− , urTargets
46−
47− -- * Delete Rule
48− , deleteRule
49−
50− -- * Types
51− , HasUserInfo (..)
52−
53− , Target (..)
54− , _TSchedule
55− , _TUser
56−
57− , ScheduleTarget
58− , stId
59− , stName
60−
61− , Rule
62− , rId
63− , rEscalationDelayInMinutes
64− , rTargets
65− ) where
66−
67−import Control.Applicative ((<$>))
68−import Control.Lens hiding ((.=))
69−import Data.Aeson
70−import qualified Data.Aeson.KeyMap as Map
71−import Data.Text (Text)
72−import Network.HTTP.Types
73−import Network.PagerDuty.Internal.TH
74−import Network.PagerDuty.Internal.Types
75−import Network.PagerDuty.REST.Users
76−
77−default (Path)
78−
79−-- FIXME: The lenses here need to operate over (Request x s b) using upd
80−
81−rules :: EscalationPolicyId -> Path
82−rules p = "escalation_policies" % p % "escalation_rules"
83−
84−data TargetType
85− = TargetSchedule
86− | TargetUser
87−
88−deriveJSONWith (dropped 6 underscored) ''TargetType
89−
90−data TargetId
91− = ScheduleId ScheduleId
92− | UserId UserId
93− deriving (Eq, Show)
94−
95−instance FromJSON TargetId where
96− parseJSON = withObject "target" $ \o -> do
97− t <- o .: "type"
98− case t of
99− TargetSchedule -> ScheduleId <$> o .: "id"
100− TargetUser -> UserId <$> o .: "id"
101−
102−instance ToJSON TargetId where
103− toJSON (ScheduleId s) = object ["type" .= TargetSchedule, "id" .= s]
104− toJSON (UserId u) = object ["type" .= TargetUser, "id" .= u]
105−
106−data ScheduleTarget = ScheduleTarget
107− { _stId :: ScheduleId
108− , _stName :: Text
109− } deriving (Eq, Show)
110−
111−deriveJSON ''ScheduleTarget
112−
113−-- | The id of the target.
114−makeLens "_stId" ''ScheduleTarget
115−
116−-- | The name of the target.
117−makeLens "_stName" ''ScheduleTarget
118−
119−data Target
120− = TSchedule ScheduleTarget
121− | TUser UserInfo
122− deriving (Eq, Show)
123−
124−makePrisms ''Target
125−
126−instance FromJSON Target where
127− parseJSON = withObject "target" $ \o -> do
128− t <- o .: "type"
129− case t of
130− TargetSchedule -> TSchedule <$> parseJSON (Object o)
131− TargetUser -> TUser <$> parseJSON (Object o)
132−
133−instance ToJSON Target where
134− toJSON t = Object (Map.insert "type" (String k) o)
135− where
136− (k, Object o) = case t of
137− TSchedule s -> ("schedule", toJSON s)
138− TUser u -> ("user", toJSON u)
139−
140−data Rule = Rule
141− { _rId :: EscalationRuleId
142− , _rEscalationDelayInMinutes :: !Int
143− , _rTargets :: [Target]
144− } deriving (Eq, Show)
145−
146−deriveJSON ''Rule
147−
148−-- | The ID of the escalation rule.
149−makeLens "_rId" ''Rule
150−
151−-- | The amount of time before an incident escalates away from this rule.
152−makeLens "_rEscalationDelayInMinutes" ''Rule
153−
154−-- | A list of targets which an incident will be assigned to upon reaching this rule.
155−makeLens "_rTargets" ''Rule
156−
157−-- | List all the escalation rules for an existing escalation policy.
158−--
159−-- @GET \/escalation_policies\/\:escalation_policy_id\/escalation_rules@
160−--
161−-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/escalation_rules/list>
162−listRules :: EscalationPolicyId -> Request Empty s [Rule]
163−listRules p = empty & path .~ rules p
164−
165−-- | Show the escalation rule for an existing escalation policy.
166−--
167−-- @GET \/escalation_policies\/:escalation_policy_id\/escalation_rules\/\:id@
168−--
169−-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/escalation_rules/show>
170−getRule :: EscalationPolicyId -> EscalationRuleId -> Request Empty s Rule
171−getRule p r = empty & path .~ rules p % r
172−
173−data CreateRule = CreateRule
174− { _crEscalationDelayInMinutes :: !Int
175− , _crTargets :: [TargetId] -- ^ list1?
176− } deriving (Eq, Show)
177−
178−deriveJSON ''CreateRule
179−
180−instance QueryLike CreateRule where
181− toQuery = const []
182−
183−-- | The escalation timeout in minutes. Must be at least 5 if the rule has
184−-- multiple targets, and at least 1 if not. If an incident is not acknowledged
185−-- within this timeout then it will escalate onto the next escalation rule.
186−makeLens "_crEscalationDelayInMinutes" ''CreateRule
187−
188−-- | The list of the targets an incident should be assigned to upon reaching
189−-- this rule.
190−makeLens "_crTargets" ''CreateRule
191−
192−-- | Creates a new escalation rule for an escalation policy and appends it to
193−-- the end of the existing escalation rules.
194−--
195−-- @POST \/escalation_policies\/\:escalation_policy_id\/escalation_rules@
196−--
197−-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/escalation_rules/create>
198−createRule :: EscalationPolicyId
199− -> Int -- ^ 'crEscalationDelayInMinutes'
200− -> [TargetId] -- ^ 'crTargets'
201− -> Request CreateRule s Rule
202−createRule p n ts =
203− mk CreateRule
204− { _crEscalationDelayInMinutes = n
205− , _crTargets = ts
206− } & meth .~ POST
207− & path .~ rules p
208−
209−newtype UpdateRules = UpdateRules
210− { _urEscalationRules :: [TargetId] -- ^ list1
211− } deriving (Eq, Show)
212−
213−deriveJSON ''UpdateRules
214−
215−instance QueryLike UpdateRules where
216− toQuery = const []
217−
218−-- | An ordered array of escalation rules.
219−makeLens "_urEscalationRules" ''UpdateRules
220−
221−-- | Updates the entire collection of escalation rules for an existing escalation
222−-- policy. The ordering is determined by the positions of each rule in the
223−-- list. To create a new rule, add it to the list without an id. To remove a
224−-- rule, do not include it in the list.
225−--
226−-- @PUT \/escalation_policies\/\:escalation_policy_id\/escalation_rules@
227−--
228−-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/escalation_rules/multi_update>
229−updateRules :: EscalationPolicyId
230− -> [TargetId] -- ^ 'urEscalationRules'
231− -> Request UpdateRules s [Rule]
232−updateRules p rs =
233− mk UpdateRules
234− { _urEscalationRules = rs
235− } & meth .~ PUT
236− & path .~ rules p
237−
238−data UpdateRule = UpdateRule
239− { _urEscalationDelayInMinutes :: Maybe Int
240− , _urTargets :: [TargetId]
241− } deriving (Eq, Show)
242−
243−deriveJSON ''UpdateRule
244−
245−instance QueryLike UpdateRule where
246− toQuery = const []
247−
248−-- | The escalation timeout in minutes. Must be at least 5 if the rule has
249−-- multiple targets, and at least 1 if not. If an incident is not acknowledged
250−-- within this timeout then it will escalate onto the next escalation rule.
251−makeLens "_urEscalationDelayInMinutes" ''UpdateRule
252−
253−-- | The list of the targets an incident should be assigned to upon reaching
254−-- this rule.
255−makeLens "_urTargets" ''UpdateRule
256−
257−-- | Updates an escalation rule.
258−--
259−-- @PUT \/escalation_policies\/\:escalation_policy_id\/escalation_rules\/\:id@
260−--
261−-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/escalation_rules/update>
262−updateRule :: EscalationPolicyId -> EscalationRuleId -> Request UpdateRule s Rule
263−updateRule p r =
264− mk UpdateRule
265− { _urEscalationDelayInMinutes = Nothing
266− , _urTargets = []
267− } & meth .~ PUT
268− & path .~ rules p % r
269−
270−-- | Deletes an existing escalation rule that belongs to an escalation
271−-- policy. There must be a matching rule.
272−--
273−-- @DELETE \/escalation_policies\/\:escalation_policy_id\/escalation_rules\/\:id@
274−--
275−-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/escalation_rules/delete>
276−deleteRule :: EscalationPolicyId -> EscalationRuleId -> Request Empty s Empty
277−deleteRule p r = empty & meth .~ DELETE & path .~ rules p % r
src/Network/PagerDuty/REST/Incidents.hs+18−567
@@ -1,16 +1,8 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE ExtendedDefaultRules #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5−{-# LANGUAGE LambdaCase #-}
6−{-# LANGUAGE OverloadedStrings #-}
1+{-# LANGUAGE OverloadedStrings #-}
7−{-# LANGUAGE TemplateHaskell #-}
2+{-# LANGUAGE TemplateHaskell #-}
8−{-# LANGUAGE TypeFamilies #-}
9−
10−{-# OPTIONS_GHC -fno-warn-type-defaults #-}
11
3
12-- Module : Network.PagerDuty.REST.Incidents
4-- Module : Network.PagerDuty.REST.Incidents
13−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
5+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
14-- License : This Source Code Form is subject to the terms of
6-- License : This Source Code Form is subject to the terms of
15-- the Mozilla Public License, v. 2.0.
7-- the Mozilla Public License, v. 2.0.
16-- A copy of the MPL can be found in the LICENSE file or
8-- A copy of the MPL can be found in the LICENSE file or
@@ -41,352 +33,18 @@
41--
33--
42-- Incidents and Incident Counts from the last 30 days are returned by
34-- Incidents and Incident Counts from the last 30 days are returned by
43-- default. To change this default date range, see the documentation for the
35-- default. To change this default date range, see the documentation for the
44−-- since, until or dateRange parameters.
36+-- since, until or date_range parameters.
45--
37--
46-- Note: that to create an incident you need to trigger it through the
38-- Note: that to create an incident you need to trigger it through the
47-- "Network.PagerDuty.Integration" API.
39-- "Network.PagerDuty.Integration" API.
48−--
49−-- /See:/ <http://developer.pagerduty.com/documentation/rest/incidents>
50module Network.PagerDuty.REST.Incidents
40module Network.PagerDuty.REST.Incidents
51 (
41 (
52− -- * List Incidents
53− ListIncidents
54− , listIncidents
55− , lsSince
56− , lsUntil
57− , lsDateRange
58− , lsStatus
59− , lsIncidentKey
60− , lsService
61− , lsAssignedToUser
62− , lsTimeZone
63− , lsSortBy
64−
65− -- * Count Incidents
66− , CountIncidents
67− , countIncidents
68− , cSince
69− , cUntil
70− , cDateRange
71− , cStatus
72− , cIncidentKey
73− , cService
74− , cAssignedToUser
75−
76− -- * Get Incident
77− , getIncident
78−
79− -- * Update Incidents
80− , UpdateIncidents
81− , updateIncidents
82− , updateIncidentsBasic
83− , uiIncidents
84−
85− -- * Resolve Incident
86− , resolveIncident
87− , resolveIncidentBasic
88−
89− -- * Acknowledge Incident
90− , acknowledgeIncident
91− , acknowledgeIncidentBasic
92−
93− -- * Reassign Incident
94− , ReassignIncident
95− , reassignIncident
96− , riEscalationPolicy
97− , riEscalationLevel
98− , riAssignedToUser
99−
100− -- * Types
101− , Sort (..)
102− , _Desc
103− , _Asc
104−
105− , Field (..)
106−
107− , IncidentStatus (..)
108− , UpdateStatus (..)
109−
110− , UpdateIncident
111− , iiId
112− , iiStatus
113− , iiEscalationLevel
114− , iiEscalationPolicy
115− , iiAssignedToUser
116−
117− , UpdatedIncidents
118− , uiId
119− , uiStatus
120− , uiIncidentNumber
121− , uiUrl
122− , uiError
123
42
124− , Assignee
125− , aAt
126− , aObject
127−
128− , HasIncident (..)
129− , Incident
130 ) where
43 ) where
131
44
132−import Control.Applicative hiding (empty)
133−import Control.Lens hiding (Empty)
134−import Data.Aeson
135−import Data.ByteString.Conversion (ToByteString (..),
136− toByteString')
137−import Data.Default.Class
138−import Data.Maybe
139−import Data.Monoid hiding (All)
140−import Data.Text (Text)
141−import qualified Data.Text.Encoding as Text
142−import Data.Time
143−import Network.HTTP.Types
144−import Network.PagerDuty.Internal.Query
145−import Network.PagerDuty.Internal.TH
146−import Network.PagerDuty.Internal.Types
147−
148−default (Path)
149−
150incidents :: Path
45incidents :: Path
151incidents = "incidents"
46incidents = "incidents"
152
47
153−data Sort a
154− = Desc a
155− | Asc a
156− deriving (Eq, Show)
157−
158−makePrisms ''Sort
159−
160−data Field
161− = IncidentNumber
162− -- ^ The number of your incident.
163− | CreatedOn
164− -- ^ The date/time the incident was triggered.
165− | ResolvedOn
166− -- ^ The date/time the incident was resolved.
167− deriving (Eq, Show)
168−
169−instance QueryValues (Sort Field) where
170− queryValues s = case s of
171− Desc f -> ["desc:" <> field f]
172− Asc f -> ["asc:" <> field f]
173− where
174− field IncidentNumber = "incidentNumber"
175− field CreatedOn = "createdOn"
176− field ResolvedOn = "resolvedOn"
177−
178−data Range = All
179− deriving (Eq, Show)
180−
181−instance QueryValues Range where
182− queryValues All = ["all"]
183−
184−data IncidentStatus
185− = ITriggered
186− | IAcknowledged
187− | IResolved
188− | IOther Text
189− deriving (Eq, Show)
190−
191−instance ToByteString IncidentStatus where
192− builder = \case
193− ITriggered -> "triggered"
194− IAcknowledged -> "acknowledged"
195− IResolved -> "resolved"
196− IOther t -> builder t
197−
198−instance FromJSON IncidentStatus where
199− parseJSON = withText "status" $ pure . \case
200− "triggered" -> ITriggered
201− "acknowledged" -> IAcknowledged
202− "resolved" -> IResolved
203− t -> IOther t
204−
205−instance ToJSON IncidentStatus where
206− toJSON = String . Text.decodeUtf8 . toByteString'
207−
208−data Assignee = Assignee
209− { _aAt :: Date
210− , _aObject :: Object
211− } deriving (Eq, Show)
212−
213−deriveRecord ''Assignee
214−
215−data Incident = Incident
216− { _iIncidentNumber' :: !Int
217− , _iStatus' :: !IncidentStatus
218− , _iCreatedOn' :: Date
219− , _iHtmlUrl' :: Text
220− , _iIncidentKey' :: Maybe IncidentKey
221− , _iService' :: Object
222− , _iEscalationPolicy' :: Maybe Object
223− , _iAssignedTo' :: [Assignee]
224− , _iAcknowledgers' :: [Assignee]
225− , _iLastStatusChangeBy' :: Maybe Assignee
226− , _iLastStatusChangeOn' :: Maybe Date
227− , _iTriggerSummaryData' :: Object
228− , _iTriggerDetailsHtmlUrl' :: Text
229− } deriving (Eq, Show)
230−
231−deriveRecord ''Incident
232−
233−class HasIncident a where
234− incident :: Lens' a Incident
235−
236− -- | The number of the incident. This is unique across your account.
237− iIncidentNumber :: Lens' a Int
238−
239− -- | The current status of the incident. Valid statuses are:
240− iStatus :: Lens' a IncidentStatus
241−
242− -- | The date/time the incident was triggered.
243− iCreatedOn :: Lens' a UTCTime
244−
245− -- | The PagerDuty website URL where the incident can be viewed and further
246− -- actions taken. This is not the resource URL.
247− iHtmlUrl :: Lens' a Text
248−
249− -- | The incident's de-duplication key. See the PagerDuty Integration API
250− -- docs for further details.
251− iIncidentKey :: Lens' a (Maybe IncidentKey)
252−
253− -- | The PagerDuty service that the incident belongs to. The service will
254− -- contain fields of its own.
255− iService :: Lens' a Object
256−
257− -- | The escalation policy that the incident belongs to. The policy will
258− -- contain fields of its own.
259− iEscalationPolicy :: Lens' a (Maybe Object)
260−
261− -- | The list of assignments of the incident. An assignment is an object
262− -- containing the assigned user as well as the date/time the incident was
263− -- assigned to that user. The user will contain fields of its own.
264− -- This list is empty if the status of the incident is resolved.
265− iAssignedTo :: Lens' a [Assignee]
266−
267− -- | The list of acknowledgements of the incident. An acknowledgement is an
268− -- object containing the acknowleding object (either a user or the
269− -- integration API) as well as the date/time the incident was acknowledged.
270− -- This field is only present if the status of the incident is acknowledged.
271− -- This field is sorted in ascending order by acknowledgement time.
272− iAcknowledgers :: Lens' a [Assignee]
273−
274− -- | The user who is responsible for the incident's last status change. If
275− -- the incident is in the acknowledged or resolved status, this will be the user
276− -- that took the first acknowledged or resolved action. If the incident was
277− -- automatically resolved (say through the Event Integration API), or if the
278− -- incident is in the triggered state, this will be null. User fields are the
279− -- same as in the assignedToUser field above.
280− iLastStatusChangeBy :: Lens' a (Maybe Assignee)
281−
282− -- | The date/time the incident's status last changed.
283− iLastStatusChangeOn :: Lens' a (Maybe UTCTime)
284−
285− -- | Some condensed information regarding the initial event that triggered
286− -- this incident. This data will be a set of key/value pairs that vary depending
287− -- on what sort of event triggered the incident (email, Event API request,
288− -- etc). For instance, if an email triggered the incident, then the
289− -- triggerSummaryData will likely contain a subject. There are no guarantees
290− -- o nthe full presence of this data for every incident.
291− iTriggerSummaryData :: Lens' a Object
292−
293− -- | The PagerDuty website URL where the full details regarding the initial
294− -- event that triggered this incident can be found. (This is not the resource
295− -- URL.)
296− iTriggerDetailsHtmlUrl :: Lens' a Text
297−
298− iIncidentNumber = incident.iIncidentNumber'
299− iStatus = incident.iStatus'
300− iCreatedOn = incident.iCreatedOn'._D
301− iHtmlUrl = incident.iHtmlUrl'
302− iIncidentKey = incident.iIncidentKey'
303− iService = incident.iService'
304− iEscalationPolicy = incident.iEscalationPolicy'
305− iAssignedTo = incident.iAssignedTo'
306− iAcknowledgers = incident.iAcknowledgers'
307− iLastStatusChangeBy = incident.iLastStatusChangeBy'
308− iLastStatusChangeOn = incident.iLastStatusChangeOn'.mapping _D
309− iTriggerSummaryData = incident.iTriggerSummaryData'
310− iTriggerDetailsHtmlUrl = incident.iTriggerDetailsHtmlUrl'
311−
312−instance HasIncident Incident where
313− incident = id
314−
315−data ListIncidents = ListIncidents
316− { _lsSince' :: Maybe Date
317− , _lsUntil' :: Maybe Date
318− , _lsDateRange' :: Maybe Range
319− , _lsStatus' :: Maybe (CSV IncidentStatus)
320− , _lsIncidentKey' :: Maybe IncidentKey
321− , _lsService' :: Maybe (CSV ServiceId)
322− , _lsAssignedToUser' :: Maybe (CSV UserId)
323− , _lsTimeZone' :: !TZ
324− , _lsSortBy' :: Maybe (Sort Field)
325− } deriving (Eq, Show)
326−
327−queryRequest ''ListIncidents
328−
329−instance Paginate ListIncidents
330−
331−-- | The start of the date range over which you want to search.
332−lsSince :: Lens' (Request ListIncidents s b) (Maybe UTCTime)
333−lsSince = upd.lsSince'.mapping _D
334−
335−-- | The end of the date range over which you want to search.
336−--
337−-- /Note: If you leave off either since or until, a 30 day default range is
338−-- applied to your open ended range. Not including the since parameter will set
339−-- the date range to until - 30 days. Likewise, if you leave off until,
340−-- it is set to since + 30 days.
341−--
342−-- Defaults to the last 30 days if you leave off both. The size of the date
343−-- range must be less than 180 days.
344−lsUntil :: Lens' (Request ListIncidents s b) (Maybe UTCTime)
345−lsUntil = upd.lsUntil'.mapping _D
346−
347−-- | When set, the since and until parameters and defaults are
348−-- ignored. Use this to get all incidents since the account was created.
349−lsDateRange :: Lens' (Request ListIncidents s b) Bool
350−lsDateRange = upd.lens get_ (flip set_)
351− where
352− get_ = (Just All ==) . view lsDateRange'
353− set_ x = lsDateRange' .~ listToMaybe [All | x]
354−
355−-- | Returns only the incidents currently in the passed status(es).
356−lsStatus :: Lens' (Request ListIncidents s b) (Maybe [IncidentStatus])
357−lsStatus = upd.lsStatus'.mapping _CSV
358−
359−-- | Returns only the incidents with the passed de-duplication key.
360−--
361−-- /See:/ "Network.PagerDuty.Integration"
362−lsIncidentKey :: Lens' (Request ListIncidents s b) (Maybe IncidentKey)
363−lsIncidentKey = upd.lsIncidentKey'
364−
365−-- | Returns only the incidents associated with the passed service(s). This
366−-- expects one or more service IDs.
367−lsService :: Lens' (Request ListIncidents s b) (Maybe [ServiceId])
368−lsService = upd.lsService'.mapping _CSV
369−
370−-- | Returns only the incidents currently assigned to the passed user(s). This
371−-- expects one or more user IDs.
372−--
373−-- /Note:/ When using the assignedToUser filter, you will only receive
374−-- incidents with statuses of triggered or acknowledged. This is because resolved
375−-- incidents are not assigned to any user.
376−lsAssignedToUser :: Lens' (Request ListIncidents s b) (Maybe [UserId])
377−lsAssignedToUser = upd.lsAssignedToUser'.mapping _CSV
378−
379−-- | Time zone in which dates in the result will be rendered.
380−--
381−-- /Default:/ 'UTC'.
382−lsTimeZone :: Lens' (Request ListIncidents s b) TimeZone
383−lsTimeZone = upd.lsTimeZone'._TZ
384−
385−-- | Used to specify both the field you wish to sort the results on, as well as
386−-- the direction (ascending/descending) of the results.
387−lsSortBy :: Lens' (Request ListIncidents s b) (Maybe (Sort Field))
388−lsSortBy = upd.lsSortBy'
389−
390-- | The PagerDuty incidents query API can be used to query current and
48-- | The PagerDuty incidents query API can be used to query current and
391-- historical PagerDuty incidents over a date range, letting you build custom
49-- historical PagerDuty incidents over a date range, letting you build custom
392-- dashboards or incident reports. The API allows for searching for incidents
50-- dashboards or incident reports. The API allows for searching for incidents
@@ -395,95 +53,16 @@ lsSortBy = upd.lsSortBy'
395--
53--
396-- @GET \/incidents@
54-- @GET \/incidents@
397--
55--
398−-- /See:/ <http://developer.pagerduty.com/documentation/rest/incidents/list>
56+-- See: <http://developer.pagerduty.com/documentation/rest/incidents/list>
399−listIncidents :: Request ListIncidents s [Incident]
57+listIncidents = undefined
400−listIncidents =
401− mk ListIncidents
402− { _lsSince' = Nothing
403− , _lsUntil' = Nothing
404− , _lsDateRange' = Nothing
405− , _lsStatus' = Nothing
406− , _lsIncidentKey' = Nothing
407− , _lsService' = Nothing
408− , _lsAssignedToUser' = Nothing
409− , _lsTimeZone' = def
410− , _lsSortBy' = Nothing
411− } & path .~ incidents
412
58
413-- | Get detailed information about an incident. Accepts either an incident id,
59-- | Get detailed information about an incident. Accepts either an incident id,
414-- or an incident number.
60-- or an incident number.
415--
61--
416-- @GET \/incidents\/\:id@
62-- @GET \/incidents\/\:id@
417--
63--
418−-- /See:/ <http://developer.pagerduty.com/documentation/rest/incidents/show>
64+-- See: <http://developer.pagerduty.com/documentation/rest/incidents/show>
419−getIncident :: IncidentId -> Request Empty s Incident
65+getIncident = undefined
420−getIncident i = empty & path .~ incidents % i
421−
422−data CountIncidents = CountIncidents
423− { _cSince' :: Maybe Date
424− , _cUntil' :: Maybe Date
425− , _cDateRange' :: Maybe Range
426− , _cStatus' :: Maybe (CSV IncidentStatus)
427− , _cIncidentKey' :: Maybe IncidentKey
428− , _cService' :: Maybe (CSV ServiceId)
429− , _cAssignedToUser' :: Maybe (CSV UserId)
430− } deriving (Eq, Show)
431−
432−queryRequest ''CountIncidents
433−
434−-- | The start of the date range over which you want to search.
435−cSince :: Lens' (Request CountIncidents s b) (Maybe UTCTime)
436−cSince = upd.cSince'.mapping _D
437−
438−-- | The end of the date range over which you want to search.
439−--
440−-- /Note:/ If you leave off either since or until, a 30 day default range is
441−-- applied to your open ended range. Not including the since parameter will set
442−-- the date range to until @-30@ days. Likewise, if you leave off until,
443−-- it is set to since @+30@ days.
444−--
445−-- /Default:/ The last 30 days if you leave off both. The size of the date
446−-- range must be less than 180 days.
447−cUntil :: Lens' (Request CountIncidents s b) (Maybe UTCTime)
448−cUntil = upd.cUntil'.mapping _D
449−
450−-- | When set, the since and until parameters and defaults are
451−-- ignored. Use this to get all counts since the account was created.
452−cDateRange :: Lens' (Request CountIncidents s b) Bool
453−cDateRange = upd.lens get_ (flip set_)
454− where
455− get_ = (Just All ==) . view cDateRange'
456− set_ x = cDateRange' .~ listToMaybe [All | x]
457−
458−-- | Only counts the incidents currently in the passed status(es).
459−cStatus :: Lens' (Request CountIncidents s b) (Maybe [IncidentStatus])
460−cStatus = upd.cStatus'.mapping _CSV
461−
462−-- | Returns only the incidents with the passed de-duplication key.
463−--
464−-- /See:/ "Network.PagerDuty.Integration"
465−cIncidentKey :: Lens' (Request CountIncidents s b) (Maybe IncidentKey)
466−cIncidentKey = upd.cIncidentKey'
467−
468−-- | Only counts the incidents associated with the passed service(s).
469−-- This is expecting one or more service IDs.
470−cService :: Lens' (Request CountIncidents s b) (Maybe [ServiceId]) -- list1
471−cService = upd.cService'.mapping _CSV
472−
473−-- | Only counts the incidents currently assigned to the passed user(s).
474−-- This is expecting one or more user IDs.
475−--
476−-- /Note:/ When using the assigned_to_user filter, you will only count
477−-- incidents with statuses of triggered or acknowledged. This is because resolved
478−-- incidents are not assigned to any user.
479−cAssignedToUser :: Lens' (Request CountIncidents s b) (Maybe [UserId]) -- list1
480−cAssignedToUser = upd.cAssignedToUser'.mapping _CSV
481−
482−newtype Count = Count Int
483− deriving (Eq, Ord, Show, Bounded, Enum, Num, Integral, Real)
484−
485−instance FromJSON Count where
486− parseJSON = withObject "count" $ \o -> Count <$> o .: "total"
487
66
488-- | Use this query if you are simply looking for the count of incidents that
67-- | Use this query if you are simply looking for the count of incidents that
489-- match a given query. This should be used if you don't need access to the
68-- match a given query. This should be used if you don't need access to the
@@ -491,161 +70,33 @@ instance FromJSON Count where
491--
70--
492-- @GET \/incidents\/count@
71-- @GET \/incidents\/count@
493--
72--
494−-- /See:/ <http://developer.pagerduty.com/documentation/rest/incidents/count>
73+-- See: <http://developer.pagerduty.com/documentation/rest/incidents/count>
495−countIncidents :: Request CountIncidents s Count
74+countIncidents = undefined
496−countIncidents =
497− mk CountIncidents
498− { _cSince' = Nothing
499− , _cUntil' = Nothing
500− , _cDateRange' = Nothing
501− , _cStatus' = Nothing
502− , _cIncidentKey' = Nothing
503− , _cService' = Nothing
504− , _cAssignedToUser' = Nothing
505− } & path .~ incidents % "count"
506−
507−
508−data UpdateStatus
509− = UAcknowledged
510− | UResolved
511− deriving (Eq, Show)
512−
513−deriveNullary ''UpdateStatus
514−
515−data UpdateIncident = UpdateIncident
516− { _iiId :: IncidentId
517− , _iiStatus :: Maybe UpdateStatus
518− , _iiEscalationLevel :: Maybe Int
519− , _iiEscalationPolicy :: Maybe EscalationPolicyId
520− , _iiAssignedToUser :: Maybe (CSV UserId)
521− } deriving (Eq, Show)
522−
523−deriveJSON ''UpdateIncident
524−
525−-- | The id of the incident to update.
526−makeLens "_iiId" ''UpdateIncident
527−
528−-- | The new status of the incident.
529−makeLens "_iiStatus" ''UpdateIncident
530−
531−-- | Escalate incident to this level in the escalation policy.
532−makeLens "_iiEscalationLevel" ''UpdateIncident
533−
534−-- | Delegate this incident to the specified escalation policy id.
535−-- This restarts the incident's escalation following the new policy.
536−makeLens "_iiEscalationPolicy" ''UpdateIncident
537−
538−-- | List of user IDs to assign this incident to.
539−makeLens "_iiAssignedToUser" ''UpdateIncident
540−
541−data UpdatedIncidents = UpdatedIncidents
542− { _uiId :: IncidentId
543− , _uiStatus :: IncidentStatus
544− , _uiIncidentNumber :: !Int
545− , _uiUrl :: Text
546− , _uiError :: Maybe Object
547− } deriving (Eq, Show)
548−
549−deriveRecord ''UpdatedIncidents
550−
551−data UpdateIncidents = UpdateIncidents
552− { _uiIncidents' :: [UpdateIncident]
553− } deriving (Eq, Show)
554−
555−jsonRequest ''UpdateIncidents
556−
557−uiIncidents :: Lens' (Request UpdateIncidents s b) [UpdateIncident]
558−uiIncidents = upd.uiIncidents'
559
75
560-- | Acknowledge, resolve, escalate or reassign one or more incidents.
76-- | Acknowledge, resolve, escalate or reassign one or more incidents.
561--
77--
562-- @PUT \/incidents@
78-- @PUT \/incidents@
563--
79--
564−-- /See:/ <http://developer.pagerduty.com/documentation/rest/incidents/update>
80+-- See: <http://developer.pagerduty.com/documentation/rest/incidents/update>
565−updateIncidents :: RequesterId -> Request UpdateIncidents s [UpdatedIncidents]
81+updateIncidents = undefined
566−updateIncidents r = auth updateIncidentsBasic & query .~ [("requester_id", r)]
567−
568−-- | A version of 'updateIncidents' which uses HTTP Basic authentication and
569−-- doesn't require a 'RequesterId'.
570−updateIncidentsBasic :: Request UpdateIncidents 'Basic [UpdatedIncidents]
571−updateIncidentsBasic =
572− mk UpdateIncidents
573− { _uiIncidents' = []
574− } & meth .~ PUT
575− & path .~ incidents
576
82
577-- | Resolve an incident.
83-- | Resolve an incident.
578--
84--
579-- @PUT \/incidents\/\:id\/resolve@
85-- @PUT \/incidents\/\:id\/resolve@
580--
86--
581−-- /See:/ <http://developer.pagerduty.com/documentation/rest/incidents/resolve>
87+-- See: <http://developer.pagerduty.com/documentation/rest/incidents/resolve>
582−resolveIncident :: IncidentId
88+resolveIncident = undefined
583− -> RequesterId
584− -> Request Empty s Empty
585−resolveIncident i r =
586− auth (resolveIncidentBasic i) & query .~ [("requester_id", r)]
587−
588−-- | A version of 'resolveIncident' which uses HTTP Basic authentication and
589−-- doesn't require a 'RequesterId'.
590−resolveIncidentBasic :: IncidentId -> Request Empty s Empty
591−resolveIncidentBasic i = empty & meth .~ PUT & path .~ incidents % i % "resolve"
592
89
593-- | Acknowledge an incident.
90-- | Acknowledge an incident.
594--
91--
595-- @PUT \/incidents\/\:id\/acknowledge@
92-- @PUT \/incidents\/\:id\/acknowledge@
596--
93--
597−-- /See:/ <http://developer.pagerduty.com/documentation/rest/incidents/acknowledge>
94+-- See: <http://developer.pagerduty.com/documentation/rest/incidents/acknowledge>
598−acknowledgeIncident :: IncidentId
95+acknowledgeIncident = undefined
599− -> RequesterId
600− -> Request Empty s Empty
601−acknowledgeIncident i r =
602− auth (acknowledgeIncidentBasic i) & query .~ [("requester_id", r)]
603−
604−-- | A version of 'acknowledgeIncident' which uses HTTP Basic authentication and
605−-- doesn't require a 'RequesterId'.
606−acknowledgeIncidentBasic :: IncidentId -> Request Empty s Empty
607−acknowledgeIncidentBasic i =
608− empty & meth .~ PUT & path .~ incidents % i % "acknowledge"
609−
610−data ReassignIncident = ReassignIncident
611− { _riEscalationPolicy' :: Maybe EscalationPolicyId
612− , _riEscalationLevel' :: Maybe Int
613− , _riAssignedToUser' :: Maybe (CSV UserId)
614− } deriving (Eq, Show)
615−
616−jsonRequest ''ReassignIncident
617−
618−-- | The ID of an escalation policy. Delegate the incident to this escalation
619−-- policy.
620−riEscalationPolicy :: Lens' (Request ReassignIncident s b) (Maybe EscalationPolicyId)
621−riEscalationPolicy = upd.riEscalationPolicy'
622−
623−-- | Escalate incident to this level in the escalation policy.
624−riEscalationLevel :: Lens' (Request ReassignIncident s b) (Maybe Int)
625−riEscalationLevel = upd.riEscalationLevel'
626−
627−-- | Comma separated list of user IDs to assign this incident to.
628−riAssignedToUser :: Lens' (Request ReassignIncident s b) (Maybe [UserId])
629−riAssignedToUser = upd.riAssignedToUser'.mapping _CSV
630
96
631-- | Reassign an incident.
97-- | Reassign an incident.
632--
98--
633-- @PUT \/incidents\/\:id\/reassign@
99-- @PUT \/incidents\/\:id\/reassign@
634--
100--
635−-- /See:/ <http://developer.pagerduty.com/documentation/rest/incidents/reassign>
101+-- See: <http://developer.pagerduty.com/documentation/rest/incidents/reassign>
636−reassignIncident :: IncidentId
102+reassignIncident = undefined
637− -> RequesterId
638− -> Request ReassignIncident s Empty
639−reassignIncident i r =
640− auth (reassignIncidentBasic i) & query .~ [("requester_id", r)]
641−
642−-- | A version of 'reassignIncident' which uses HTTP Basic authentication and
643−-- doesn't require a 'RequesterId'.
644−reassignIncidentBasic :: IncidentId -> Request ReassignIncident s Empty
645−reassignIncidentBasic i =
646− mk ReassignIncident
647− { _riEscalationPolicy' = Nothing
648− , _riEscalationLevel' = Nothing
649− , _riAssignedToUser' = Nothing
650− } & meth .~ PUT
651− & path .~ incidents % i % "reassign"
src/Network/PagerDuty/REST/Incidents/Notes.hsdeleted−108
@@ -1,108 +0,0 @@
1−{-# LANGUAGE ExtendedDefaultRules #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE TemplateHaskell #-}
4−
5−{-# OPTIONS_GHC -fno-warn-type-defaults #-}
6−
7−-- Module : Network.PagerDuty.REST.Incidents.Notes
8−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
9−-- License : This Source Code Form is subject to the terms of
10−-- the Mozilla Public License, v. 2.0.
11−-- A copy of the MPL can be found in the LICENSE file or
12−-- you can obtain it at http://mozilla.org/MPL/2.0/.
13−-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
14−-- Stability : experimental
15−-- Portability : non-portable (GHC extensions)
16−
17−-- | The Incident Notes API allows you to add notes to a specified incident.
18−--
19−-- /See:/ <http://developer.pagerduty.com/documentation/rest/incidents/notes>
20−module Network.PagerDuty.REST.Incidents.Notes
21− (
22− -- * List Notes
23− listNotes
24−
25− -- * Create Note
26− , CreateNote
27− , createNote
28− , createNoteBasic
29− , cnContent
30−
31− -- * Types
32− , Note
33− , nId
34− , nCreatedAt
35− , nUser
36− , nContent
37− ) where
38−
39−import Control.Lens hiding ((.=))
40−import Data.Aeson
41−import Data.Text (Text)
42−import Data.Time
43−import Network.HTTP.Types
44−import Network.PagerDuty.Internal.TH
45−import Network.PagerDuty.Internal.Types
46−import Network.PagerDuty.REST.Users
47−
48−default (Path)
49−
50−notes :: IncidentId -> Path
51−notes i = "incidents" % i % "notes"
52−
53−data Note = Note
54− { _nId :: NoteId
55− , _nCreatedAt :: Date
56− , _nUser :: User
57− , _nContent :: Text
58− } deriving (Eq, Show)
59−
60−deriveJSON ''Note
61−
62−makeLens "_nId" ''Note
63−makeLens "_nUser" ''Note
64−makeLens "_nContent" ''Note
65−
66−nCreatedAt :: Lens' Note UTCTime
67−nCreatedAt = lens _nCreatedAt (\n x -> n { _nCreatedAt = x }) . _D
68−
69−-- | List existing notes for the specified incident.
70−--
71−-- @GET \/incidents\/\:incident_id\/notes@
72−--
73−-- /See:/ <http://developer.pagerduty.com/documentation/rest/incidents/notes/create>
74−listNotes :: IncidentId -> Request Empty s [Note]
75−listNotes i = empty & path .~ notes i
76−
77−newtype CreateNote = CreateNote
78− { _cnContent' :: Maybe Text
79− } deriving (Eq, Show)
80−
81−makeLenses ''CreateNote
82−
83−instance ToJSON CreateNote where
84− toJSON cn = object ["note" .= object ["content" .= _cnContent' cn]]
85−
86−instance QueryLike CreateNote where
87− toQuery = const []
88−
89−-- | The note content.
90−cnContent :: Lens' (Request CreateNote s b) (Maybe Text)
91−cnContent = upd.cnContent'
92−
93−-- | Create a new note for the specified incident.
94−--
95−-- @POST \/incidents\/\:incident_id\/notes@
96−--
97−-- /See:/ <http://developer.pagerduty.com/documentation/rest/incidents/notes/create>
98−createNote :: IncidentId -> RequesterId -> Request CreateNote s Note
99−createNote i r = auth (createNoteBasic i) & query .~ [("requester_id", r)]
100−
101−-- | A version of 'createNote' which uses HTTP Basic authentication and
102−-- doesn't require a 'RequesterId'.
103−createNoteBasic :: IncidentId -> Request CreateNote s Note
104−createNoteBasic i =
105− mk CreateNote
106− { _cnContent' = Nothing
107− } & meth .~ POST
108− & path .~ notes i
src/Network/PagerDuty/REST/LogEntries.hs+11−469
@@ -1,11 +1,8 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE OverloadedStrings #-}
1+{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE StandaloneDeriving #-}
4−{-# LANGUAGE TemplateHaskell #-}
2+{-# LANGUAGE TemplateHaskell #-}
5−{-# LANGUAGE TypeFamilies #-}
6
3
7-- Module : Network.PagerDuty.REST.LogEntries
4-- Module : Network.PagerDuty.REST.LogEntries
8−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
5+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
9-- License : This Source Code Form is subject to the terms of
6-- License : This Source Code Form is subject to the terms of
10-- the Mozilla Public License, v. 2.0.
7-- the Mozilla Public License, v. 2.0.
11-- A copy of the MPL can be found in the LICENSE file or
8-- A copy of the MPL can be found in the LICENSE file or
@@ -20,494 +17,39 @@
20-- incidents. Log entry data includes details about the event(s) that triggered
17-- incidents. Log entry data includes details about the event(s) that triggered
21-- the incident, who was notified and when, how they were notified, and who
18-- the incident, who was notified and when, how they were notified, and who
22-- acknowledged or resolved it, amongst a few other things.
19-- acknowledged or resolved it, amongst a few other things.
23−--
24−-- /See:/ <http://developer.pagerduty.com/documentation/rest/log_entries>
25module Network.PagerDuty.REST.LogEntries
20module Network.PagerDuty.REST.LogEntries
26 (
21 (
27− -- * List Logs
28− ListLogs
29− , listLogs
30− , listUserLogs
31− , listIncidentLogs
32− , llTimeZone
33− , llSince
34− , llUntil
35− , llIsOverview
36−
37− -- * Get Log
38− , GetLog
39− , getLog
40− , glTimeZone
41−
42− -- * Types
43− -- ** Channels
44− , Channel (..)
45− , _ChanNagios
46− , _ChanAPI
47− , _ChanEmail
48− , _ChanUserEmail
49− , _ChanWebTrigger
50− , _ChanSMS
51− , _ChanWeb
52− , _ChanNote
53− , _ChanAuto
54− , _ChanTimeout
55−
56− , NagiosChannel
57− , ncSummary
58− , ncHost
59− , ncService
60− , ncState
61− , ncDetails
62−
63− , APIChannel
64− , acSummary
65− , acServiceKey
66− , acDescription
67− , acIncidentKey
68− , acDetails
69−
70− , EmailType (..)
71− , EmailChannel
72− , ecSummary
73− , ecTo
74− , ecFrom
75− , ecSubject
76− , ecBody
77− , ecBodyContentType
78− , ecRawUrl
79− , ecHtmlUrl
80−
81− , WebTriggerChannel
82− , wcSummary
83− , wcSubject
84− , wcDetails
85−
86− -- ** Entries
87− , Entry (..)
88− , _LogEntry
89− , _NotifyEntry
90−
91− , LogEntryType (..)
92− , LogEntry
93− , leId
94− , leType
95− , leCreatedAt
96− , leNote
97− , leAssignedUser
98− , leChannel
99−
100− , NotifyEntry
101− , neCreatedAt
102− , neUser
103− , neNotification
104−
105− , NotificationType (..)
106− , NotificationStatus (..)
107
22
108− , Notification
109− , nType
110− , nStatus
111− , nAddress
112 ) where
23 ) where
113
24
114−import Control.Lens hiding (Empty)
115−import Data.Aeson
116−import Data.Aeson.Lens
117−import qualified Data.Aeson.KeyMap as Map
118−import Data.Default.Class
119−import Data.Text (Text)
120−import qualified Data.Text as Text
121−import Data.Time
122−import Network.HTTP.Types
123−import Network.PagerDuty.Internal.TH
124−import Network.PagerDuty.Internal.Types
125−import Network.PagerDuty.REST.Users (User)
126−
127logs :: Path
25logs :: Path
128logs = "log_entries"
26logs = "log_entries"
129
27
130−includes :: Query
131−includes =
132− [ ("include[]", Just "channel")
133− , ("include[]", Just "incident")
134− , ("include[]", Just "service")
135− ]
136−
137−data NagiosChannel = NagiosChannel
138− { _ncSummary :: Text
139− , _ncHost :: Text
140− , _ncService :: Maybe Text
141− , _ncState :: Text
142− , _ncDetails :: Object
143− } deriving (Eq, Show)
144−
145−deriveJSON ''NagiosChannel
146−
147−-- | Same as host.
148−makeLens "_ncSummary" ''NagiosChannel
149−
150−-- | Nagios host.
151−makeLens "_ncHost" ''NagiosChannel
152−
153−-- | Nagios service that created the event, if applicable.
154−makeLens "_ncService" ''NagiosChannel
155−
156−-- | State the caused the event.
157−makeLens "_ncState" ''NagiosChannel
158−
159−-- | Additional details of the incident.
160−makeLens "_ncDetails" ''NagiosChannel
161−
162−data APIChannel = APIChannel
163− { _acSummary :: Text
164− , _acServiceKey :: ServiceKey
165− , _acDescription :: Text
166− , _acIncidentKey :: IncidentKey
167− , _acDetails :: Object
168− } deriving (Eq, Show)
169−
170−deriveJSON ''APIChannel
171−
172−-- | Same as description.
173−makeLens "_acSummary" ''APIChannel
174−
175−-- | API service key.
176−makeLens "_acServiceKey" ''APIChannel
177−
178−-- | Description of the event.
179−makeLens "_acDescription" ''APIChannel
180−
181−-- | Incident deduping string.
182−makeLens "_acIncidentKey" ''APIChannel
183−
184−-- | Additional details of the incident, if any.
185−makeLens "_acDetails" ''APIChannel
186−
187−data EmailType
188− = Plain
189− | HTML
190− deriving (Eq, Show)
191−
192−deriveNullary ''EmailType
193−
194−data EmailChannel = EmailChannel
195− { _ecSummary :: Text
196− , _ecTo :: Text
197− , _ecFrom :: Text
198− , _ecSubject :: Text
199− , _ecBody :: Text
200− , _ecBodyContentType :: EmailType
201− , _ecRawUrl :: Text
202− , _ecHtmlUrl :: Maybe Text
203− } deriving (Eq, Show)
204−
205−deriveJSON ''EmailChannel
206−
207−-- | Same as subject.
208−makeLens "_ecSummary" ''EmailChannel
209−
210−-- | To address of the email.
211−makeLens "_ecTo" ''EmailChannel
212−
213−-- | From address of the email.
214−makeLens "_ecFrom" ''EmailChannel
215−
216−-- | Subject of the email.
217−makeLens "_ecSubject" ''EmailChannel
218−
219−-- | Body of the email.
220−makeLens "_ecBody" ''EmailChannel
221−
222−-- | Content type of the email body.
223−makeLens "_ecBodyContentType" ''EmailChannel
224−
225−-- | URL for raw text of email.
226−makeLens "_ecRawUrl" ''EmailChannel
227−
228−-- | URL for html rendered version of the email.
229−--
230−-- Only present if content_type is 'HTML'.
231−makeLens "_ecHtmlUrl" ''EmailChannel
232−
233−data WebTriggerChannel = WebTriggerChannel
234− { _wcSummary :: Text
235− , _wcSubject :: Text
236− , _wcDetails :: Maybe Text
237− } deriving (Eq, Show)
238−
239−deriveJSON ''WebTriggerChannel
240−
241−-- | Same as subject.
242−makeLens "_wcSummary" ''WebTriggerChannel
243−
244−-- | Subject of the web trigger.
245−makeLens "_wcSubject" ''WebTriggerChannel
246−
247−-- | Details about the web trigger.
248−makeLens "_wcDetails" ''WebTriggerChannel
249−
250−-- | Representation of the means by which the action was channeled.
251−data Channel
252− = ChanNagios NagiosChannel
253− | ChanAPI APIChannel
254− | ChanEmail EmailChannel
255− | ChanUserEmail User EmailChannel
256− | ChanWebTrigger User WebTriggerChannel
257− | ChanSMS User
258− | ChanWeb User
259− | ChanNote User
260− | ChanAuto
261− | ChanTimeout
262− deriving (Eq, Show)
263−
264−makePrisms ''Channel
265−
266−instance FromJSON Channel where
267− parseJSON = withObject "agent+channel" $ \o -> do
268− t <- o .: "channel" >>= (.: "type")
269− let u = Map.member "user" o
270− case t of
271− -- service
272− "email" | not u -> ChanEmail <$> o .: "channel"
273− "nagios" -> ChanNagios <$> o .: "channel"
274− "api" -> ChanAPI <$> o .: "channel"
275− -- user
276− "email" | u -> ChanUserEmail <$> o .: "user" <*> o .: "channel"
277− "web_trigger" -> ChanWebTrigger <$> o .: "user" <*> o .: "channel"
278− "sms" -> ChanSMS <$> o .: "user"
279− "web" -> ChanWeb <$> o .: "user"
280− "note" -> ChanNote <$> o .: "user"
281− -- empty
282− "auto" -> pure ChanAuto
283− "timeout" -> pure ChanTimeout
284− _ -> fail $
285− "unrecognised service channel type: " ++ Text.unpack t
286−
287−data LogEntryType
288− = Trigger
289− -- ^ The incident was triggered.
290− | Acknowledge
291− -- ^ The incident was acknowledged.
292− | Unacknowledge
293− -- ^ The incident was unacknowledged.
294− | Resolve
295− -- ^ The incident was resolved.
296− | Escalate
297− -- ^ The incident was escalated.
298− | Assign
299− -- ^ The incident was assigned to a user.
300− | Annotate
301− -- ^ A note was added to the incident.
302− | ReachTriggerLimit
303− -- ^ The incident has reached the log entry trigger limit and
304− -- will not create any more.
305− | RepeatEscalationPath
306− -- ^ The incident has reached the end of its escalation policy
307− -- and will restart.
308− | ExhaustEscalationPath
309− -- ^ The incident has cycled through its escalation policy the
310− -- max allowed number of times.
311− | Notify
312− -- ^ A user was notified.
313− deriving (Eq, Show)
314−
315−deriveNullary ''LogEntryType
316−
317−-- | The raw log event.
318−data LogEntry = LogEntry'
319− { _leId :: LogEntryId
320− , _leType :: LogEntryType
321− , _leCreatedAt :: Date
322− , _leNote :: Maybe Text
323− , _leAssignedUser :: Maybe User
324− , _leChannel :: Channel
325− } deriving (Eq, Show)
326−
327−instance FromJSON LogEntry where
328− parseJSON = withObject "log_entry" $ \o ->
329− LogEntry' <$> o .: "id"
330− <*> o .: "type"
331− <*> o .: "created_at"
332− <*> o .:? "note"
333− <*> o .:? "assigned_user"
334− <*> parseJSON (Object o)
335−
336−-- | Id of the log entry.
337−makeLens "_leId" ''LogEntry
338−
339−-- | Time at which the log entry was created.
340−makeLens "_leCreatedAt" ''LogEntry
341−
342−-- | The type of the log entry.
343−makeLens "_leType" ''LogEntry
344−
345−-- | Optional field containing an action note, if one was included
346−-- with the action.
347−makeLens "_leNote" ''LogEntry
348−
349−-- | Only for assign, escalate log entries. The user to which the incident is
350−-- assigned.
351−makeLens "_leAssignedUser" ''LogEntry
352−
353−-- | Representation of the means by which the action was channeled and the
354−-- possible perfomer of this action.
355−makeLens "_leChannel" ''LogEntry
356−
357−data NotificationType
358− = SMS
359− | Email
360− | Phone
361− | IosPushNotification
362− deriving (Eq, Show)
363−
364−deriveNullary ''NotificationType
365−
366−data NotificationStatus
367− = Success
368− | Blocked
369− | Busy
370− | Failed
371− | NoAnswer
372− | BadAddress
373− deriving (Eq, Show)
374−
375−deriveNullary ''NotificationStatus
376−
377−data Notification = Notification
378− { _nType :: !NotificationType
379− , _nStatus :: !NotificationStatus
380− , _nAddress :: Address
381− } deriving (Eq, Show)
382−
383−deriveJSON ''Notification
384−
385−-- | Type of notification.
386−makeLens "_nType" ''Notification
387−
388−-- | The current status of the notification.
389−makeLens "_nStatus" ''Notification
390−
391−-- | The address to which the notification was sent. I.e., an email address,
392−-- phone number, or iPhone name.
393−makeLens "_nAddress" ''Notification
394−
395−-- | Notify log entries correspond to notifications sent to users. They have a
396−-- distinct format from action log entries.
397−data NotifyEntry = NotifyEntry'
398− { _neCreatedAt' :: Date
399− , _neUser' :: User
400− , _neNotification' :: Notification
401− } deriving (Eq, Show)
402−
403−deriveRecord ''NotifyEntry
404−
405−-- | Time at which the log entry was created
406−neCreatedAt :: Lens' NotifyEntry UTCTime
407−neCreatedAt = neCreatedAt'._D
408−
409−-- | User who was notified
410−neUser :: Lens' NotifyEntry User
411−neUser = neUser'
412−
413−-- | Object representing the notification itself
414−neNotification :: Lens' NotifyEntry Notification
415−neNotification = neNotification'
416−
417−data Entry
418− = LogEntry LogEntry
419− -- ^ Log entries come in a wide variety of types. Most types use this format,
420− -- the exception being the 'NotifyEntry' type.
421− | NotifyEntry NotifyEntry
422− -- ^ A user was notified.
423− deriving (Eq, Show)
424−
425−makePrisms ''Entry
426−
427−data ListLogs = ListLogs
428− { _llTimeZone' :: TZ
429− , _llSince' :: Maybe Date
430− , _llUntil' :: Maybe Date
431− , _llIsOverview' :: Bool'
432− } deriving (Eq, Show)
433−
434−instance Paginate ListLogs
435−
436−queryRequest ''ListLogs
437−
438−-- | Time zone in which dates in the result will be rendered.
439−--
440−-- /Default:/ UTC.
441−llTimeZone :: Lens' (Request ListLogs s b) TimeZone
442−llTimeZone = upd.llTimeZone'._TZ
443−
444−-- | The start of the date range over which you want to search.
445−llSince :: Lens' (Request ListLogs s b) (Maybe UTCTime)
446−llSince = upd.llSince'.mapping _D
447−
448−-- | The end of the date range over which you want to search.
449−llUntil :: Lens' (Request ListLogs s b) (Maybe UTCTime)
450−llUntil = upd.llUntil'.mapping _D
451−
452−-- | If true, will only return log entries of type trigger, acknowlldge, or resolve.
453−--
454−-- /Default:/ false.
455−llIsOverview :: Lens' (Request ListLogs s b) Bool
456−llIsOverview = upd.llIsOverview'._B
457−
458-- | List all incident log entries across the entire account.
28-- | List all incident log entries across the entire account.
459--
29--
460-- @GET \/log_entries@
30-- @GET \/log_entries@
461--
31--
462−-- /See:/ <http://developer.pagerduty.com/documentation/rest/log_entries/list>
32+-- See: <http://developer.pagerduty.com/documentation/rest/log_entries/list>
463−listLogs :: Request ListLogs s [LogEntry]
33+listLogs = undefined
464−listLogs =
465− mk ListLogs
466− { _llTimeZone' = def
467− , _llSince' = Nothing
468− , _llUntil' = Nothing
469− , _llIsOverview' = F
470− } & path .~ logs
471− & query .~ includes
472− & unwrap .~ key "log_entries"
473
34
474-- | List all incident log entries that describe interactions with a specific user.
35-- | List all incident log entries that describe interactions with a specific user.
475--
36--
476-- @GET \/users\/\:user_id\/log_entries@
37-- @GET \/users\/\:user_id\/log_entries@
477--
38--
478−-- /See:/ <http://developer.pagerduty.com/documentation/rest/log_entries/user_log_entries>
39+-- See: <http://developer.pagerduty.com/documentation/rest/log_entries/user_log_entries>
479−listUserLogs :: UserId -> Request ListLogs s [LogEntry]
40+listUserLogs = undefined
480−listUserLogs u = listLogs & path .~ "users" % u % logs
481
41
482-- | List all incident log entries for a specific incident.
42-- | List all incident log entries for a specific incident.
483--
43--
484-- @GET \/incidents\/\:incident_id\/log_entries@
44-- @GET \/incidents\/\:incident_id\/log_entries@
485--
45--
486−-- /See:/ <http://developer.pagerduty.com/documentation/rest/log_entries/incident_log_entries>
46+-- See: <http://developer.pagerduty.com/documentation/rest/log_entries/incident_log_entries>
487−listIncidentLogs :: IncidentKey -> Request ListLogs s [LogEntry]
47+listIncidentLogs = undefined
488−listIncidentLogs i = listLogs & path .~ "incidents" % i % logs
489−
490−newtype GetLog = GetLog
491− { _glTimeZone' :: TZ
492− } deriving (Eq, Show)
493−
494−queryRequest ''GetLog
495−
496−-- | Time zone in which dates in the result will be rendered.
497−--
498−-- /Default:/ UTC.
499−glTimeZone :: Lens' (Request GetLog s b) TimeZone
500−glTimeZone = upd.glTimeZone'._TZ
501
48
502-- | Get details for a specific incident log entry. This method provides additional
49-- | Get details for a specific incident log entry. This method provides additional
503-- information you can use to get at raw event data.
50-- information you can use to get at raw event data.
504--
51--
505-- @GET \/log_entries\/\:id@
52-- @GET \/log_entries\/\:id@
506--
53--
507−-- /See:/ <http://developer.pagerduty.com/documentation/rest/log_entries/show>
54+-- See: <http://developer.pagerduty.com/documentation/rest/log_entries/show>
508−getLog :: LogEntryId -> Request GetLog s LogEntry
55+getLog = undefined
509−getLog l =
510− mk GetLog
511− { _glTimeZone' = def
512− } & path .~ logs % l
513− & query .~ includes
src/Network/PagerDuty/REST/MaintenanceWindows.hs+3−270
@@ -1,10 +1,8 @@
1−{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE TemplateHaskell #-}
2{-# LANGUAGE TemplateHaskell #-}
4−{-# LANGUAGE TypeFamilies #-}
5
3
6-- Module : Network.PagerDuty.REST.MaintenanceWindows
4-- Module : Network.PagerDuty.REST.MaintenanceWindows
7−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
5+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
8-- License : This Source Code Form is subject to the terms of
6-- License : This Source Code Form is subject to the terms of
9-- the Mozilla Public License, v. 2.0.
7-- the Mozilla Public License, v. 2.0.
10-- A copy of the MPL can be found in the LICENSE file or
8-- A copy of the MPL can be found in the LICENSE file or
@@ -15,275 +13,10 @@
15
13
16-- | Maintenance windows allow you to schedule service maintenance periods,
14-- | Maintenance windows allow you to schedule service maintenance periods,
17-- during which no incidents will be created.
15-- during which no incidents will be created.
18−--
19−-- /See:/ <http://developer.pagerduty.com/documentation/rest/maintenance_windows>
20module Network.PagerDuty.REST.MaintenanceWindows
16module Network.PagerDuty.REST.MaintenanceWindows
21 (
17 (
22− -- * List Windows
23− ListWindows
24− , listWindows
25− , lwQuery
26− , lwServiceIds
27− , lwFilter
28
18
29− , ListWindowsResponse
30− , lwMaintenanceWindows
31− , lwCounts
32−
33− -- * Create Window
34− , CreateWindow
35− , createWindow
36− , createWindowBasic
37− , cwStartTime
38− , cwEndTime
39− , cwDescription
40− , cwServiceIds
41−
42− -- * Get Window
43− , getWindow
44−
45− -- * Update Window
46− , UpdateWindow
47− , updateWindow
48− , uwStartTime
49− , uwEndTime
50− , uwDescription
51− , uwServiceIds
52−
53− -- * Delete Window
54− , deleteWindow
55−
56− -- * Types
57− , ServiceInfo
58− , siId
59− , siName
60− , siUrl
61−
62− , Counts
63− , cOngoing
64− , cFuture
65− , cPast
66− , cAll
67−
68− , MaintenanceWindow
69− , mwSequenceNumber
70− , mwStartTime
71− , mwEndTime
72− , mwDescription
73− , mwCreatedBy
74− , mwServices
75 ) where
19 ) where
76
20
77−import Control.Lens hiding (Empty)
21+maintenance :: Path
78−import Data.Monoid
79−import Data.Text (Text)
80−import Data.Time
81−import Network.HTTP.Types
82−import Network.PagerDuty.Internal.TH
83−import Network.PagerDuty.Internal.Types
84−import Network.PagerDuty.REST.Users (User)
85−
86−windows :: Path
87−windows = "maintenance_windows"
22+maintenance = "maintenance_windows"
88−
89−data ServiceInfo = ServiceInfo
90− { _siId :: ServiceId
91− , _siName :: Text
92− , _siUrl :: Text
93− } deriving (Eq, Show)
94−
95−deriveRecord ''ServiceInfo
96−
97−data MaintenanceWindow = MaintenanceWindow
98− { _mwSequenceNumber :: !Int
99− , _mwStartTime :: Date
100− , _mwEndTime :: Date
101− , _mwDescription :: Maybe Text
102− , _mwCreatedBy :: User
103− , _mwServices :: [ServiceInfo]
104− } deriving (Eq, Show)
105−
106−deriveRecord ''MaintenanceWindow
107−
108−data ListWindows = ListWindows
109− { _lwQuery' :: Maybe Text
110− , _lwServiceIds' :: List ServiceId
111− , _lwFilter' :: Maybe Text
112− }
113−
114−queryRequest ''ListWindows
115−
116−-- | Filters the results, showing only the maintenance windows whose
117−-- descriptions contain the query.
118−lwQuery :: Lens' (Request ListWindows s b) (Maybe Text)
119−lwQuery = upd.lwQuery'
120−
121−-- | An list of service IDs, specifying services whose maintenance
122−-- windows shall be returned.
123−lwServiceIds :: Lens' (Request ListWindows s b) [ServiceId]
124−lwServiceIds = upd.lwServiceIds'._L
125−
126−-- | Only return maintenance windows that are of this type. Possible values
127−-- are past, future, ongoing. If this parameter is omitted, all maintenance
128−-- windows will be returned.
129−lwFilter :: Lens' (Request ListWindows s b) (Maybe Text)
130−lwFilter = upd.lwFilter'
131−
132−data Counts = Counts
133− { _cOngoing :: !Int
134− , _cFuture :: !Int
135− , _cPast :: !Int
136− , _cAll :: !Int
137− } deriving (Eq, Show)
138−
139−deriveRecord ''Counts
140−
141−data ListWindowsResponse = ListWindowsResponse
142− { _lwMaintenanceWindows :: [MaintenanceWindow]
143− , _lwCounts :: Counts
144− } deriving (Eq, Show)
145−
146−deriveRecord ''ListWindowsResponse
147−
148−-- | List existing maintenance windows, optionally filtered by service,
149−-- or whether they are from the past, present or future.
150−--
151−-- @GET \/maintenance_windows@
152−--
153−-- /See:/ <http://developer.pagerduty.com/documentation/rest/maintenance_windows/list>
154−listWindows :: Request ListWindows s ListWindowsResponse
155−listWindows =
156− mk ListWindows
157− { _lwQuery' = Nothing
158− , _lwServiceIds' = mempty
159− , _lwFilter' = Nothing
160− } & path .~ windows
161−
162−data CreateWindow' = CreateWindow'
163− { _cwStartTime' :: Date
164− , _cwEndTime' :: Date
165− , _cwDescription' :: Maybe Text
166− , _cwServiceIds' :: [ServiceId] -- ^ List1
167− } deriving (Eq, Show)
168−
169−deriveRecord ''CreateWindow'
170−
171−data CreateWindow = CreateWindow
172− { _cwRequesterId' :: Maybe RequesterId
173− , _cwMaintenanceWindow' :: CreateWindow'
174− } deriving (Eq, Show)
175−
176−jsonRequest ''CreateWindow
177−
178−-- | This maintenance window's start time. This is when the services will stop
179−-- creating incidents. If this date is in the past, it will be updated to be the
180−-- current time.
181−cwStartTime :: Lens' (Request CreateWindow s b) UTCTime
182−cwStartTime = upd.cwMaintenanceWindow'.cwStartTime'._D
183−
184−-- | This maintenance window's end time. This is when the services will start
185−-- creating incidents again. This date must be in the future and after the
186−-- start_time.
187−cwEndTime :: Lens' (Request CreateWindow s b) UTCTime
188−cwEndTime = upd.cwMaintenanceWindow'.cwEndTime'._D
189−
190−-- | A description for this maintenance window.
191−cwDescription :: Lens' (Request CreateWindow s b) (Maybe Text)
192−cwDescription = upd.cwMaintenanceWindow'.cwDescription'
193−
194−-- | The ids of the services that are affected by this maintenance window.
195−cwServiceIds :: Lens' (Request CreateWindow s b) [ServiceId]
196−cwServiceIds = upd.cwMaintenanceWindow'.cwServiceIds'
197−
198−-- | Create a new maintenance window for the specified services. No new
199−-- incidents will be created for a service that is currently in maintenance.
200−--
201−-- @POST \/maintenance_windows@
202−--
203−-- /See:/ <http://developer.pagerduty.com/documentation/rest/maintenance_windows/create>
204−createWindow :: RequesterId
205− -> UTCTime -- ^ 'cwStartTime'
206− -> UTCTime -- ^ 'cwEndTime'
207− -> [ServiceId] -- ^ 'cwServiceIds'
208− -> Request CreateWindow s MaintenanceWindow
209−createWindow r s e xs =
210− auth (createWindowBasic s e xs) & upd.cwRequesterId' ?~ r
211−
212−-- | A version of 'createWindow' which uses HTTP Basic authentication and
213−-- doesn't require a 'RequesterId'.
214−createWindowBasic :: UTCTime -- ^ 'cwStartTime'
215− -> UTCTime -- ^ 'cwEndTime'
216− -> [ServiceId] -- ^ 'cwServiceIds'
217− -> Request CreateWindow 'Basic MaintenanceWindow
218−createWindowBasic s e xs =
219− mk CreateWindow
220− { _cwRequesterId' = Nothing
221− , _cwMaintenanceWindow' = CreateWindow'
222− { _cwStartTime' = D s
223− , _cwEndTime' = D e
224− , _cwDescription' = Nothing
225− , _cwServiceIds' = xs
226− }
227− } & meth .~ POST
228− & path .~ windows
229−
230−-- | Get details about an existing maintenance window.
231−--
232−-- @GET \/maintenance_windows\/\:id@
233−--
234−-- /See:/ <http://developer.pagerduty.com/documentation/rest/maintenance_windows/show>
235−getWindow :: WindowId -> Request Empty s MaintenanceWindow
236−getWindow w = empty & path .~ windows % w
237−
238−data UpdateWindow = UpdateWindow
239− { _uwStartTime' :: Maybe Date
240− , _uwEndTime' :: Maybe Date
241− , _uwDescription' :: Maybe Text
242− , _uwServiceIds' :: Maybe [ServiceId]
243− } deriving (Eq, Show)
244−
245−jsonRequest ''UpdateWindow
246−
247−-- | The maintenance window's start time. Can only be updated on future
248−-- maintenance windows. If the start_time is set to a date in the past, it will be
249−-- updated to the current date.
250−uwStartTime :: Lens' (Request UpdateWindow s b) (Maybe Date)
251−uwStartTime = upd.uwStartTime'
252−
253−-- | The maintenance window's end time. Can only be updated on ongoing and
254−-- future maintenance windows, and cannot be set to a value before start_time.
255−uwEndTime :: Lens' (Request UpdateWindow s b) (Maybe Date)
256−uwEndTime = upd.uwEndTime'
257−
258−-- | Description for this maintenance window. Can only be updated on ongoing
259−-- and future maintenance windows.
260−uwDescription :: Lens' (Request UpdateWindow s b) (Maybe Text)
261−uwDescription = upd.uwDescription'
262−
263−-- | Services that are affected by this maintenance window. Can only be updated
264−-- on future maintenance windows.
265−uwServiceIds :: Lens' (Request UpdateWindow s b) (Maybe [ServiceId])
266−uwServiceIds = upd.uwServiceIds'
267−
268−-- | Update an existing maintenance window.
269−--
270−-- @PUT \/maintenance_windows\/\:id@
271−--
272−-- /See:/ <http://developer.pagerduty.com/documentation/rest/maintenance_windows/update>
273−updateWindow :: WindowId -> Request UpdateWindow s MaintenanceWindow
274−updateWindow w =
275− mk UpdateWindow
276− { _uwStartTime' = Nothing
277− , _uwEndTime' = Nothing
278− , _uwDescription' = Nothing
279− , _uwServiceIds' = Nothing
280− } & meth .~ PUT
281− & path .~ windows % w
282−
283−-- | Cancel or delete an existing maintenance window.
284−--
285−-- @DELETE \/maintenance_windows\/\:id@
286−--
287−-- /See:/ <http://developer.pagerduty.com/documentation/rest/maintenance_windows/delete>
288−deleteWindow :: WindowId -> Request Empty s Empty
289−deleteWindow w = empty & meth .~ DELETE & path .~ windows % w
src/Network/PagerDuty/REST/Reports.hs+10−161
@@ -1,13 +1,8 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE ExtendedDefaultRules #-}
3−{-# LANGUAGE OverloadedStrings #-}
1+{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE TemplateHaskell #-}
2+{-# LANGUAGE TemplateHaskell #-}
5−{-# LANGUAGE TypeFamilies #-}
6−
7−{-# OPTIONS_GHC -fno-warn-type-defaults #-}
8
3
9-- Module : Network.PagerDuty.REST.Reports
4-- Module : Network.PagerDuty.REST.Reports
10−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
5+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
11-- License : This Source Code Form is subject to the terms of
6-- License : This Source Code Form is subject to the terms of
12-- the Mozilla Public License, v. 2.0.
7-- the Mozilla Public License, v. 2.0.
13-- A copy of the MPL can be found in the LICENSE file or
8-- A copy of the MPL can be found in the LICENSE file or
@@ -16,173 +11,27 @@
16-- Stability : experimental
11-- Stability : experimental
17-- Portability : non-portable (GHC extensions)
12-- Portability : non-portable (GHC extensions)
18
13
19−-- | Access high level reports about alerts and incidents.
14+-- | Access high level reports about alerts and incidents. Useful for creating graphs.
20−-- Useful for creating graphs.
21−--
22−-- /See:/ <http://developer.pagerduty.com/documentation/rest/reports>
23module Network.PagerDuty.REST.Reports
15module Network.PagerDuty.REST.Reports
24 (
16 (
25− -- * Alerts Per Time
26− alertsPerTime
27−
28− -- * Incidents Per Time
29− , incidentsPerTime
30−
31− -- * Types
32− , Report
33− , rSince
34− , rUntil
35− , rRollup
36
17
37− , Rollup (..)
38−
39− , AlertReport
40− , arStart
41− , arEnd
42− , arNumberOfAlerts
43− , arNumberOfPhoneAlerts
44− , arNumberOfSmsAlerts
45− , arNumberOfEmailAlerts
46−
47− , AlertTotals
48− , atAlerts
49− , atTotalNumberOfAlerts
50− , atTotalNumberOfPhoneAlerts
51− , atTotalNumberOfSmsAlerts
52− , atTotalNumberOfEmailAlerts
53− , atTotalNumberOfBillableAlerts
54−
55− , IncidentReport
56− , irStart
57− , irEnd
58− , irNumberOfIncidents
59 ) where
18 ) where
60
19
61−import Control.Lens hiding (Empty)
62−import Data.Aeson.Lens
63−import Data.Time
64−import Network.PagerDuty.Internal.TH
65−import Network.PagerDuty.Internal.Types
66−
67−default (Path)
68−
69reports :: Path
20reports :: Path
70reports = "reports"
21reports = "reports"
71
22
72−data Rollup
73− = Daily
74− | Weekly
75− | Monthly
76− deriving (Eq, Show)
77−
78−deriveNullary ''Rollup
79−
80−data Report = Report
81− { _rSince' :: Date
82− , _rUntil' :: Date
83− , _rRollup' :: !Rollup
84− } deriving (Eq, Show)
85−
86−queryRequest ''Report
87−
88−-- | Start of the date range over which you want to search. The time element
89−-- is optional.
90−rSince :: Lens' (Request Report s b) UTCTime
91−rSince = upd.rSince'._D
92−
93−-- | The end of the date range over which you want to search. This should be
94−-- in the same format as since.
95−rUntil :: Lens' (Request Report s b) UTCTime
96−rUntil = upd.rUntil'._D
97−
98−-- | Specifies the bucket duration for each summation.
99−--
100−-- /Default:/ monthly.
101−--
102−-- Example: A time window of two years (based on since and until) with a
103−-- rollup of monthly will result in 24 sets of data points being returned
104−-- (one for each month in the span).
105−rRollup :: Lens' (Request Report s b) Rollup
106−rRollup = upd.rRollup'
107−
108−data AlertReport = AlertReport
109− { _arStart :: Date
110− , _arEnd :: Date
111− , _arNumberOfAlerts :: !Int
112− , _arNumberOfPhoneAlerts :: !Int
113− , _arNumberOfSmsAlerts :: !Int
114− , _arNumberOfEmailAlerts :: !Int
115− } deriving (Eq, Show)
116−
117−deriveJSON ''AlertReport
118−
119−arStart :: Lens' AlertReport UTCTime
120−arStart = lens _arStart (\r x -> r { _arStart = x }) ._D
121−
122−arEnd :: Lens' AlertReport UTCTime
123−arEnd = lens _arEnd (\r x -> r { _arEnd = x }) ._D
124−
125−makeLens "_arNumberOfAlerts" ''AlertReport
126−makeLens "_arNumberOfPhoneAlerts" ''AlertReport
127−makeLens "_arNumberOfSmsAlerts" ''AlertReport
128−makeLens "_arNumberOfEmailAlerts" ''AlertReport
129−
130−data AlertTotals = AlertTotals
131− { _atAlerts :: [AlertReport]
132− , _atTotalNumberOfAlerts :: !Int
133− , _atTotalNumberOfPhoneAlerts :: !Int
134− , _atTotalNumberOfSmsAlerts :: !Int
135− , _atTotalNumberOfEmailAlerts :: !Int
136− , _atTotalNumberOfBillableAlerts :: !Int
137− } deriving (Eq, Show)
138−
139−deriveRecord ''AlertTotals
140−
141-- | Get high level statistics about the number of alerts (SMSes, phone calls and
23-- | Get high level statistics about the number of alerts (SMSes, phone calls and
142-- emails) sent for the desired time period, summed daily, weekly or monthly.
24-- emails) sent for the desired time period, summed daily, weekly or monthly.
143--
25--
144-- @GET \/reports\/alerts_per_time@
26-- @GET \/reports\/alerts_per_time@
145--
27--
146−-- /See:/ <http://developer.pagerduty.com/documentation/rest/reports/alerts_per_time>
28+-- See: <http://developer.pagerduty.com/documentation/rest/reports/alerts_per_time>
147−alertsPerTime :: UTCTime -- ^ 'rSince'
29+alertsPerTime = undefined
148− -> UTCTime -- ^ 'rUntil'
149− -> Request Report s AlertTotals
150−alertsPerTime s u =
151− mk Report
152− { _rSince' = D s
153− , _rUntil' = D u
154− , _rRollup' = Monthly
155− } & path .~ reports % "alerts_per_time"
156−
157−data IncidentReport = IncidentReport
158− { _irStart :: Date
159− , _irEnd :: Date
160− , _irNumberOfIncidents :: !Int
161− } deriving (Eq, Show)
162−
163−deriveJSON ''IncidentReport
164−
165−irStart :: Lens' IncidentReport UTCTime
166−irStart = lens _irStart (\r x -> r { _irStart = x }) . _D
167−
168−irEnd :: Lens' IncidentReport UTCTime
169−irEnd = lens _irEnd (\r x -> r { _irEnd = x }) . _D
170−
171−makeLens "_irNumberOfIncidents" ''IncidentReport
172
30
173−-- | Get high level statistics about the number of incidents created for the
31+-- | Get high level statistics about the number of incidents created for the desired
174−-- desired time period, summed daily, weekly or monthly.
32+-- time period, summed daily, weekly or monthly.
175--
33--
176-- @GET \/reports\/incidents_per_time@
34-- @GET \/reports\/incidents_per_time@
177--
35--
178−-- /See:/ <http://developer.pagerduty.com/documentation/rest/reports/incidents_per_time>
36+-- See: <http://developer.pagerduty.com/documentation/rest/reports/incidents_per_time>
179−incidentsPerTime :: UTCTime -- ^ 'rSince'
37+incidentsPerTime = undefined
180− -> UTCTime -- ^ 'rUntil'
181− -> Request Report s [IncidentReport]
182−incidentsPerTime s u =
183− mk Report
184− { _rSince' = D s
185− , _rUntil' = D u
186− , _rRollup' = Monthly
187− } & path .~ reports % "incidents_per_time"
188− & unwrap .~ key "incidents"
src/Network/PagerDuty/REST/Schedules.hs+3−617
@@ -1,13 +1,8 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE ExtendedDefaultRules #-}
3−{-# LANGUAGE OverloadedStrings #-}
1+{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE TemplateHaskell #-}
2+{-# LANGUAGE TemplateHaskell #-}
5−{-# LANGUAGE TypeFamilies #-}
6−
7−{-# OPTIONS_GHC -fno-warn-type-defaults #-}
8
3
9-- Module : Network.PagerDuty.REST.Schedules
4-- Module : Network.PagerDuty.REST.Schedules
10−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
5+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
11-- License : This Source Code Form is subject to the terms of
6-- License : This Source Code Form is subject to the terms of
12-- the Mozilla Public License, v. 2.0.
7-- the Mozilla Public License, v. 2.0.
13-- A copy of the MPL can be found in the LICENSE file or
8-- A copy of the MPL can be found in the LICENSE file or
@@ -20,619 +15,10 @@
20-- a user is on-call he is eligible to receive alerts from incidents.
15-- a user is on-call he is eligible to receive alerts from incidents.
21--
16--
22-- This API allows users to manipulate on-call schedules.
17-- This API allows users to manipulate on-call schedules.
23−--
24−-- /See:/ <http://developer.pagerduty.com/documentation/rest/schedules/overrides>
25module Network.PagerDuty.REST.Schedules
18module Network.PagerDuty.REST.Schedules
26 (
19 (
27− -- * List Schedules
28− ListSchedules
29− , listSchedules
30− , lsQuery
31−
32− -- * Get Schedule
33− , GetSchedule
34− , getSchedule
35− , gsSince
36− , gsUntil
37− , gsTimeZone
38−
39− -- * Get Schedule Users
40− , GetScheduleUsers
41− , getScheduleUsers
42− , gsuSince
43− , gsuUntil
44−
45− -- * Get Schedule Entries
46− , GetScheduleEntries
47− , getScheduleEntries
48− , gseSince
49− , gseUntil
50− , gseOverflow
51− , gseTimeZone
52− , gseUserId
53−
54− -- * Create Schedule
55− , CreateSchedule
56− , createSchedule
57− , csName
58− , csOverflow
59− , csTimeZone
60− , csScheduleLayers
61−
62− -- * Update Schedule
63− , UpdateSchedule
64− , updateSchedule
65− , usOverflow
66− , usTimeZone
67− , usScheduleLayers
68−
69− -- * Preview Schedule
70− , PreviewSchedule
71− , previewSchedule
72− , psSince
73− , psUntil
74− , psOverflow
75− , psName
76− , psTimeZone
77− , psScheduleLayers
78−
79− -- * Delete Schedule
80− , deleteSchedule
81
20
82− -- * Types
83− , RestrictionType (..)
84− , Restriction
85− , rStartTimeOfDay
86− , rDurationSeconds
87−
88− , Rotation
89− , rMemberOrder
90− , rUser
91−
92− , ScheduleLayer
93− , slName
94− , slRenderedScheduleEntries
95− , slRestrictionType
96− , slRestrictions
97− , slPriority
98− , slStart
99− , slEnd
100− , slRenderedCoveragePercentage
101− , slRotationTurnLengthSeconds
102− , slRotationVirtualStart
103− , slUsers
104−
105− , HasScheduleInfo (..)
106− , ScheduleInfo
107− , Schedule
108− , sScheduleLayers
109− , sOverridesSubschedule
110− , sFinalSchedule
111 ) where
21 ) where
112
22
113−import Control.Lens hiding (Empty, (.=))
114−import Data.Aeson
115−import Data.Text (Text)
116−import Data.Time
117−import Network.HTTP.Types
118−import Network.PagerDuty.Internal.TH
119−import Network.PagerDuty.Internal.Types
120−import Network.PagerDuty.REST.Users (User)
121−
122−default (Path)
123−
124schedules :: Path
23schedules :: Path
125schedules = "schedules"
24schedules = "schedules"
126−
127−data RestrictionType
128− = Daily
129− | Weekly
130− deriving (Eq, Show)
131−
132−deriveNullary ''RestrictionType
133−
134−data Restriction = Restriction
135− { _rStartTimeOfDay :: Date
136− , _rDurationSeconds :: !Int
137− } deriving (Eq, Show)
138−
139−deriveJSON ''Restriction
140−
141−rStartTimeOfDay :: Lens' Restriction UTCTime
142−rStartTimeOfDay =
143− lens _rStartTimeOfDay (\r x -> r { _rStartTimeOfDay = x }) . _D
144−
145−makeLens "_rDurationSeconds" ''Restriction
146−
147−data Rotation = Rotation
148− { _rMemberOrder :: !Int
149− , _rUser :: User
150− } deriving (Eq, Show)
151−
152−deriveRecord ''Rotation
153−
154−-- | A schedule is composed of multiple schedule layers.
155−--
156−-- A layer is composed of a group of people who will rotate through the same
157−-- shift. In a basic weekly schedule, you create a single layer where each member
158−-- is on-call for one week, with a set day and time for transferring on-call duty.
159−--
160−-- When a schedule has multiple layers, the layer can be ordered using the
161−-- priority field. The layer with the highest priority has precedence over the
162−-- layers with lower priority. You can use restrictions to control how layers
163−-- overlap.
164−--
165−-- The override layer is a special layer where all the override entries are
166−-- stored.
167−--
168−-- The final layer is a special layer that contains the result of all the previous
169−-- layers put together. This layer cannot be edited.
170−data ScheduleLayer = ScheduleLayer
171− { _slName :: Text
172− , _slRenderedScheduleEntries :: [ScheduleId] -- FIXME: what is this a list of?
173− , _slRestrictionType :: !RestrictionType
174− , _slRestrictions :: [Restriction]
175− , _slPriority :: !Int
176− , _slStart :: Date
177− , _slEnd :: Date
178− , _slRenderedCoveragePercentage :: !Double
179− , _slRotationTurnLengthSeconds :: !Int
180− , _slRotationVirtualStart :: Date
181− , _slUsers :: [Rotation]
182− } deriving (Eq, Show)
183−
184−-- FIXME: most of these fields are maybes
185−
186−deriveJSON ''ScheduleLayer
187−
188−makeLens "_slName" ''ScheduleLayer
189−
190−-- | This is a list of entries to be rendered for the current time range.
191−makeLens "_slRenderedScheduleEntries" ''ScheduleLayer
192−
193−-- | This specifies the type of restrictions present on this layer.
194−makeLens "_slRestrictionType" ''ScheduleLayer
195−
196−-- | A list of time restrictions for this layer.
197−makeLens "_slRestrictions" ''ScheduleLayer
198−
199−-- | The priority of the layer. Layers with higher priority will override
200−-- layers with a lower priority.
201−makeLens "_slPriority" ''ScheduleLayer
202−
203−-- | The effective start date of the layer
204−makeLens "_slStart" ''ScheduleLayer
205−
206−-- | The effective end date of the layer. If 'Nothing', the layer has no end date.
207−makeLens "_slEnd" ''ScheduleLayer
208−
209−-- | The percentage of the time range covered by this layer.
210−makeLens "_slRenderedCoveragePercentage" ''ScheduleLayer
211−
212−-- | The duration of each on-call shift in seconds.
213−makeLens "_slRotationTurnLengthSeconds" ''ScheduleLayer
214−
215−-- | The effective start time of the layer. This can be before the start
216−-- time of the schedule.
217−makeLens "_slRotationVirtualStart" ''ScheduleLayer
218−
219−-- | An ordered list of users in this layer. The member_order field controls
220−-- the order in which the users apear in the rotation.
221−makeLens "_slUsers" ''ScheduleLayer
222−
223−data ScheduleInfo = ScheduleInfo
224− { _siId' :: ScheduleId
225− , _siName' :: Text
226− , _siTimeZone' :: TZ
227− , _siToday' :: Date
228− , _siEscalationPolicies' :: [EscalationPolicyId]
229− } deriving (Eq, Show)
230−
231−deriveRecord ''ScheduleInfo
232−
233−class HasScheduleInfo a where
234− scheduleInfo :: Lens' a ScheduleInfo
235−
236− -- | The unique identifier of the schedule.
237− sId :: Lens' a ScheduleId
238− -- | The name of the schedule.
239− sName :: Lens' a Text
240− -- | The time zone of the schedule.
241− sTimeZone :: Lens' a TimeZone
242− -- | The current day in the schedule's time zone.
243− sToday :: Lens' a UTCTime
244− -- | An list of all the escalation policies that uses this schedule.
245− sEscalationPolicies :: Lens' a [EscalationPolicyId]
246−
247− sId = scheduleInfo.siId'
248− sName = scheduleInfo.siName'
249− sTimeZone = scheduleInfo.siTimeZone'._TZ
250− sToday = scheduleInfo.siToday'._D
251− sEscalationPolicies = scheduleInfo.siEscalationPolicies'
252−
253−instance HasScheduleInfo ScheduleInfo where
254− scheduleInfo = id
255−
256−data Schedule = Schedule
257− { _sInfo :: ScheduleInfo
258− , _sScheduleLayers :: [ScheduleLayer]
259− , _sOverridesSubschedule :: ScheduleLayer
260− , _sFinalSchedule :: ScheduleLayer
261− } deriving (Eq, Show)
262−
263−deriveJSON ''Schedule
264−
265−instance HasScheduleInfo Schedule where
266− scheduleInfo = lens _sInfo (\s x -> s { _sInfo = x })
267−
268−-- | A list of schedule layers. See the schedule layers parameters for details.
269−makeLens "_sScheduleLayers" ''Schedule
270−
271−-- | The schedule layer object where all the overrides are stored.
272−makeLens "_sOverridesSubschedule" ''Schedule
273−
274−-- | The final schedule layer object.
275−makeLens "_sFinalSchedule" ''Schedule
276−
277−newtype ListSchedules = ListSchedules
278− { _lsQuery' :: Maybe Text
279− } deriving (Eq, Show)
280−
281−queryRequest ''ListSchedules
282−
283−-- | Filters the result, showing only the schedules whose name matches the query.
284−lsQuery :: Lens' (Request ListSchedules s b) (Maybe Text)
285−lsQuery = upd.lsQuery'
286−
287−instance Paginate ListSchedules
288−
289−-- | List existing on-call schedules.
290−--
291−-- @GET \/schedules@
292−--
293−-- /See:/ <http://developer.pagerduty.com/documentation/rest/schedules/list>
294−listSchedules :: RequesterId -> Request ListSchedules s [ScheduleInfo]
295−listSchedules r = auth listSchedulesBasic & query .~ [("requester_id", r)]
296−
297−-- | A version of 'listSchedules' which uses HTTP Basic authentication and
298−-- doesn't require a 'RequesterId'.
299−listSchedulesBasic :: Request ListSchedules s [ScheduleInfo]
300−listSchedulesBasic =
301− mk ListSchedules
302− { _lsQuery' = Nothing
303− } & path .~ schedules
304−
305−data GetSchedule = GetSchedule
306− { _gsSince' :: Maybe Date
307− , _gsUntil' :: Maybe Date
308− , _gsTimeZone' :: Maybe TZ
309− } deriving (Eq, Show)
310−
311−queryRequest ''GetSchedule
312−
313−-- | The start of the date range over which you want to return on-call schedule
314−-- entries and on-call schedule layers.
315−gsSince :: Lens' (Request GetSchedule s b) (Maybe UTCTime)
316−gsSince = upd.gsSince'.mapping _D
317−
318−-- | The end of the date range over which you want to return schedule entries
319−-- and on-call schedule layers.
320−gsUntil :: Lens' (Request GetSchedule s b) (Maybe UTCTime)
321−gsUntil = upd.gsUntil'.mapping _D
322−
323−-- | Time zone in which dates in the result will be rendered.
324−--
325−-- /Default:/ account time zone.
326−gsTimeZone :: Lens' (Request GetSchedule s b) (Maybe TimeZone)
327−gsTimeZone = upd.gsTimeZone'.mapping _TZ
328−
329−-- | Show detailed information about a schedule, including entries for each
330−-- layer and sub-schedule.
331−--
332−-- @GET \/schedules\/\:id@
333−--
334−-- /See:/ <http://developer.pagerduty.com/documentation/rest/schedules/show>
335−getSchedule :: Request GetSchedule s Schedule
336−getSchedule =
337− mk GetSchedule
338− { _gsSince' = Nothing
339− , _gsUntil' = Nothing
340− , _gsTimeZone' = Nothing
341− } & path .~ schedules
342−
343−
344−data GetScheduleUsers = GetScheduleUsers
345− { _gsuSince' :: Maybe Date
346− , _gsuUntil' :: Maybe Date
347− } deriving (Eq, Show)
348−
349−queryRequest ''GetScheduleUsers
350−
351−-- | The start of the date range over which you want to return on-call users.
352−gsuSince :: Lens' (Request GetScheduleUsers s b) (Maybe UTCTime)
353−gsuSince = upd.gsuSince'.mapping _D
354−
355−-- | The end time of the date range over which you want to return on-call users.
356−gsuUntil :: Lens' (Request GetScheduleUsers s b) (Maybe UTCTime)
357−gsuUntil = upd.gsuUntil'.mapping _D
358−
359−-- | List all the users on-call in a given schedule for a given time range.
360−--
361−-- @GET \/schedules\/\:id\/users@
362−--
363−-- /See:/ <http://developer.pagerduty.com/documentation/rest/schedules/users>
364−getScheduleUsers :: UserId -> Request GetScheduleUsers s [User]
365−getScheduleUsers u =
366− mk GetScheduleUsers
367− { _gsuSince' = Nothing
368− , _gsuUntil' = Nothing
369− } & path .~ schedules % u % "users"
370−
371−data GetScheduleEntries = GetScheduleEntries
372− { _gseSince' :: Date
373− , _gseUntil' :: Date
374− , _gseOverflow' :: !Bool'
375− , _gseTimeZone' :: Maybe TZ
376− , _gseUserId' :: Maybe UserId
377− } deriving (Eq, Show)
378−
379−queryRequest ''GetScheduleEntries
380−
381−-- | The start of the date range over which you want to return on-call
382−-- schedule entries.
383−-- The maximum range queryable at once is three months.
384−gseSince :: Lens' (Request GetScheduleEntries s b) UTCTime
385−gseSince = upd.gseSince'._D
386−
387−-- | The end of the date range over which you want to return schedule entries.
388−gseUntil :: Lens' (Request GetScheduleEntries s b) UTCTime
389−gseUntil = upd.gseUntil'._D
390−
391−-- | Any on-call schedule entries that pass the date range bounds will be
392−-- truncated at the bounds, unless the parameter overflow=true is passed.
393−--
394−-- Default: false.
395−--
396−-- Example: if your schedule is a rotation that changes daily at midnight UTC,
397−-- and your date range is from 2011-06-01T10:00:00Z to 2011-06-01T14:00:00Z: If
398−-- you don't pass the overflow=true parameter, you will get one schedule entry
399−-- returned with a start of 2011-06-01T10:00:00Z and end of 2011-06-01T14:00:00Z.
400−-- If you do pass the overflow=true parameter, you will get one schedule entry
401−-- returned with a start of 2011-06-01T00:00:00Z and end of 2011-06-02T00:00:00Z.
402−gseOverflow :: Lens' (Request GetScheduleEntries s b) Bool
403−gseOverflow = upd.gseOverflow'._B
404−
405−-- | Time zone in which dates in the result will be rendered.
406−--
407−-- Default: account time zone.
408−gseTimeZone :: Lens' (Request GetScheduleEntries s b) (Maybe TimeZone)
409−gseTimeZone = upd.gseTimeZone'.mapping _TZ
410−
411−-- | To filter the returned on-call schedule entries by a specific user, you
412−-- can optionally add the user_id parameter to the query.
413−gseUserId :: Lens' (Request GetScheduleEntries s b) (Maybe UserId)
414−gseUserId = upd.gseUserId'
415−
416−-- | List schedule entries that are active for a given time range for a
417−-- specified on-call schedule.
418−--
419−-- @GET \/schedules\/\:id\/entries@
420−--
421−-- /See:/ <http://developer.pagerduty.com/documentation/rest/schedules/entries>
422−getScheduleEntries :: UserId
423− -> Date -- ^ 'gseSince'
424− -> Date -- ^ 'gseUntil'
425− -> Request GetScheduleEntries s b
426−getScheduleEntries i s u =
427− mk GetScheduleEntries
428− { _gseSince' = s
429− , _gseUntil' = u
430− , _gseOverflow' = F
431− , _gseTimeZone' = Nothing
432− , _gseUserId' = Nothing
433− } & path .~ schedules % i
434−
435−data CreateSchedule = CreateSchedule
436− { _csName' :: Text
437− , _csOverflow' :: !Bool'
438− , _csTimeZone' :: TZ
439− , _csScheduleLayers' :: [ScheduleLayer]
440− } deriving (Eq, Show)
441−
442−makeLenses ''CreateSchedule
443−
444−instance ToJSON CreateSchedule where
445− toJSON cs = object
446− [ "name" .= _csName' cs
447− , "overflow" .= _csOverflow' cs
448− , "schedule" .= object
449− [ "time_zone" .= _csTimeZone' cs
450− , "schedule_layers" .= _csScheduleLayers' cs
451− ]
452− ]
453−
454−instance QueryLike CreateSchedule where
455− toQuery = const []
456−
457−-- | Any on-call schedule entries that pass the date range bounds will be
458−-- truncated at the bounds, unless 'csOverflow' is set to 'True'.
459−--
460−-- Default: 'False'.
461−csOverflow :: Lens' (Request CreateSchedule s b) Bool
462−csOverflow = upd.csOverflow'._B
463−
464−-- | The name of the schedule.
465−csName :: Lens' (Request CreateSchedule s b) Text
466−csName = upd.csName'
467−
468−-- | The time zone of the schedule.
469−--
470−-- Default: 'UTC'.
471−csTimeZone :: Lens' (Request CreateSchedule s b) TimeZone
472−csTimeZone = upd.csTimeZone'._TZ
473−
474−-- | A list of schedule layers.
475−csScheduleLayers :: Lens' (Request CreateSchedule s b) [ScheduleLayer]
476−csScheduleLayers = upd.csScheduleLayers'
477−
478−-- | Create a new on-call schedule.
479−--
480−-- @POST \/schedules@
481−--
482−-- /See:/ <http://developer.pagerduty.com/documentation/rest/schedules/create>
483−createSchedule :: Text -- ^ 'csName'
484− -> TimeZone -- ^ 'csTimeZone'
485− -> [ScheduleLayer] -- ^ 'csScheduleLayers'
486− -> Request CreateSchedule s Schedule
487−createSchedule n z ls =
488− mk CreateSchedule
489− { _csName' = n
490− , _csOverflow' = F
491− , _csTimeZone' = TZ z
492− , _csScheduleLayers' = ls
493− } & meth .~ POST
494− & path .~ schedules
495−
496−data UpdateSchedule = UpdateSchedule
497− { _usOverflow' :: !Bool'
498− , _usTimeZone' :: TZ
499− , _usScheduleLayers' :: [ScheduleLayer]
500− } deriving (Eq, Show)
501−
502−makeLenses ''UpdateSchedule
503−
504−instance ToJSON UpdateSchedule where
505− toJSON us = object
506− [ "overflow" .= _usOverflow' us
507− , "schedule" .= object
508− [ "time_zone" .= _usTimeZone' us
509− , "schedule_layers" .= _usScheduleLayers' us
510− ]
511− ]
512−
513−instance QueryLike UpdateSchedule where
514− toQuery = const []
515−
516−-- | Any on-call schedule entries that pass the date range bounds will be
517−-- truncated at the bounds, unless 'usOverflow' is set to 'True'.
518−--
519−-- Default: 'False'.
520−usOverflow :: Lens' (Request UpdateSchedule s b) Bool
521−usOverflow = upd.usOverflow'._B
522−
523−-- | The time zone of the schedule.
524−usTimeZone :: Lens' (Request UpdateSchedule s b) TimeZone
525−usTimeZone = upd.usTimeZone'._TZ
526−
527−-- | A list of schedule layers.
528−usScheduleLayers :: Lens' (Request UpdateSchedule s b) [ScheduleLayer]
529−usScheduleLayers = upd.usScheduleLayers'
530−
531−-- | Update an existing on-call schedule.
532−--
533−-- /Note:/ You cannot delete schedule layers. You must include all layers in
534−-- your update request. To delete a layer, set the end parameter to schedule its
535−-- termination.
536−--
537−-- @PUT \/schedules\/\:id@
538−--
539−-- /See:/ <http://developer.pagerduty.com/documentation/rest/schedules/update>
540−updateSchedule :: ScheduleId
541− -> TimeZone -- ^ 'usTimeZone'
542− -> [ScheduleLayer] -- ^ 'usScheduleLayers'
543− -> Request UpdateSchedule s Schedule
544−updateSchedule s z ls =
545− mk UpdateSchedule
546− { _usOverflow' = F
547− , _usTimeZone' = TZ z
548− , _usScheduleLayers' = ls
549− } & meth .~ PUT
550− & path .~ schedules % s
551−
552−data PreviewSchedule = PreviewSchedule
553− { _psSince' :: Maybe Date
554− , _psUntil' :: Maybe Date
555− , _psName' :: Text
556− , _psOverflow' :: !Bool'
557− , _psTimeZone' :: TZ
558− , _psScheduleLayers' :: [ScheduleLayer]
559− } deriving (Eq, Show)
560−
561−makeLenses ''PreviewSchedule
562−
563−instance ToJSON PreviewSchedule where
564− toJSON ps = object
565− [ "since" .= _psSince' ps
566− , "until" .= _psUntil' ps
567− , "name" .= _psName' ps
568− , "overflow" .= _psOverflow' ps
569− , "schedule" .= object
570− [ "time_zone" .= _psTimeZone' ps
571− , "schedule_layers" .= _psScheduleLayers' ps
572− ]
573− ]
574−
575−instance QueryLike PreviewSchedule where
576− toQuery = const []
577−
578−-- | The start of the date range over which you want to return on-call schedule
579−-- entries and on-call schedule layers.
580−psSince :: Lens' (Request PreviewSchedule s b) (Maybe UTCTime)
581−psSince = upd.psSince'.mapping _D
582−
583−-- | The end of the date range over which you want to return schedule entries
584−-- and on-call schedule layers.
585−psUntil :: Lens' (Request PreviewSchedule s b) (Maybe UTCTime)
586−psUntil = upd.psUntil'.mapping _D
587−
588−-- | Any on-call schedule entries that pass the date range bounds will be
589−-- truncated at the bounds, unless 'psOverflow' is set to 'True'.
590−--
591−-- Default: 'False'.
592−psOverflow :: Lens' (Request PreviewSchedule s b) Bool
593−psOverflow = upd.psOverflow'._B
594−
595−-- | The name of the schedule.
596−psName :: Lens' (Request PreviewSchedule s b) Text
597−psName = upd.psName'
598−
599−-- | The time zone of the schedule.
600−--
601−-- Default: 'UTC'.
602−psTimeZone :: Lens' (Request PreviewSchedule s b) TimeZone
603−psTimeZone = upd.psTimeZone'._TZ
604−
605−-- | A list of schedule layers.
606−psScheduleLayers :: Lens' (Request PreviewSchedule s b) [ScheduleLayer]
607−psScheduleLayers = upd.psScheduleLayers'
608−
609−-- | Preview what a schedule would look like without saving it. This work the
610−-- same as the update or create actions, except that the result is not
611−-- persisted. Preview optionally takes two additional arguments, since and until,
612−-- deliminating the span of the preview.
613−--
614−-- @POST \/schedules\/preview@
615−--
616−-- /See:/ <http://developer.pagerduty.com/documentation/rest/schedules/preview>
617−previewSchedule :: Text -- ^ 'psName'
618− -> TimeZone -- ^ 'psTimeZone'
619− -> [ScheduleLayer] -- ^ 'psScheduleLayers'
620− -> Request PreviewSchedule s Schedule
621−previewSchedule n z ls =
622− mk PreviewSchedule
623− { _psSince' = Nothing
624− , _psUntil' = Nothing
625− , _psName' = n
626− , _psOverflow' = F
627− , _psTimeZone' = TZ z
628− , _psScheduleLayers' = ls
629− } & meth .~ POST
630− & path .~ schedules % "preview"
631−
632−-- | Delete an on-call schedule.
633−--
634−-- @DELETE \/schedules\/\:id@
635−--
636−-- /See:/ <http://developer.pagerduty.com/documentation/rest/schedules/delete>
637−deleteSchedule :: ScheduleId -> Request Empty s Empty
638−deleteSchedule s = empty & meth .~ DELETE & path .~ schedules % s
src/Network/PagerDuty/REST/Schedules/Overrides.hsdeleted−188
@@ -1,188 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE ExtendedDefaultRules #-}
3−{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE TemplateHaskell #-}
5−{-# LANGUAGE TypeFamilies #-}
6−
7−{-# OPTIONS_GHC -fno-warn-type-defaults #-}
8−
9−-- Module : Network.PagerDuty.REST.Schedules
10−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
11−-- License : This Source Code Form is subject to the terms of
12−-- the Mozilla Public License, v. 2.0.
13−-- A copy of the MPL can be found in the LICENSE file or
14−-- you can obtain it at http://mozilla.org/MPL/2.0/.
15−-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
16−-- Stability : experimental
17−-- Portability : non-portable (GHC extensions)
18−
19−-- | Schedule overrides are custom, non-recurring exceptions to your regular
20−-- on-call schedules. Use them when your team members go on vacation, swap shifts,
21−-- or when you simply cannot achieve your normal scheduling with recurring layers.
22−--
23−-- /See:/ <http://developer.pagerduty.com/documentation/rest/schedules>
24−module Network.PagerDuty.REST.Schedules.Overrides
25− (
26− -- * List Overrides
27− ListOverrides
28− , listOverrides
29− , lsSince
30− , lsUntil
31− , lsEditable
32− , lsOverflow
33−
34− -- * Create Override
35− , CreateOverride
36− , createOverride
37− , coUserId
38− , coStart
39− , coEnd
40−
41− -- * Delete Override
42− , deleteOverride
43−
44− -- * Types
45− , HasUserInfo (..)
46− , Override
47− , oId
48− , oStart
49− , oEnd
50− , oUser
51− ) where
52−
53−import Control.Lens
54−import Data.Time
55−import Network.HTTP.Types
56−import Network.PagerDuty.Internal.TH
57−import Network.PagerDuty.Internal.Types
58−import Network.PagerDuty.REST.Users
59−
60−overrides :: ScheduleId -> Path
61−overrides i = "schedules" % i % "overrides"
62−
63−data Override = Override
64− { _oId :: Maybe OverrideId
65− , _oStart :: Date
66− , _oEnd :: Date
67− , _oUser :: UserInfo
68− } deriving (Eq, Show)
69−
70−deriveRecord ''Override
71−
72−instance HasUserInfo Override where
73− userInfo = oUser
74−
75−data ListOverrides = ListOverrides
76− { _lsSince' :: Date
77− , _lsUntil' :: Date
78− , _lsEditable' :: Bool'
79− , _lsOverflow' :: Bool'
80− } deriving (Eq, Show)
81−
82−queryRequest ''ListOverrides
83−
84−-- | The start time of the date range you want to retrieve override for.
85−--
86−-- The maximum date range queryable is 3 months.
87−lsSince :: Lens' (Request ListOverrides s b) UTCTime
88−lsSince = upd.lsSince'._D
89−
90−-- | The end time of the date range you want to retrieve override for.
91−lsUntil :: Lens' (Request ListOverrides s b) UTCTime
92−lsUntil = upd.lsUntil'._D
93−
94−-- | When 'True', only editable overrides will be returned.
95−--
96−-- The result will onlyinclude the id the override if this parameter is present.
97−-- Only future overrides are editable.
98−--
99−-- /Default:/ 'False.'
100−lsEditable :: Lens' (Request ListOverrides s b) Bool
101−lsEditable = upd.lsEditable'._B
102−
103−-- | Any on-call schedule entries that pass the date range bounds will be
104−-- truncated at the bounds, unless @lsEditable .~ True@ is specified.
105−--
106−-- /Default:/ 'False.'
107−lsOverflow :: Lens' (Request ListOverrides s b) Bool
108−lsOverflow = upd.lsOverflow'._B
109−
110−-- | List overrides for a given time range.
111−--
112−-- @GET \/schedules\/\:schedule_id\/overrides@
113−--
114−-- /See:/ <http://developer.pagerduty.com/documentation/rest/schedules/overrides/list>
115−listOverrides :: ScheduleId
116− -> Date -- ^ 'lsSince'
117− -> Date -- ^ 'lsUntil'
118− -> Request ListOverrides s [Override]
119−listOverrides i s u =
120− mk ListOverrides
121− { _lsSince' = s
122− , _lsUntil' = u
123− , _lsEditable' = F
124− , _lsOverflow' = F
125− } & path .~ overrides i
126−
127−data CreateOverride = CreateOverride
128− { _coStart' :: Date
129− , _coEnd' :: Date
130− , _coUserId' :: UserId
131− } deriving (Eq, Show)
132−
133−jsonRequest ''CreateOverride
134−
135−-- | The start date and time for the override.
136−coStart :: Lens' (Request CreateOverride s b) UTCTime
137−coStart = upd.coStart'._D
138−
139−-- | The end date and time for the override.
140−coEnd :: Lens' (Request CreateOverride s b) UTCTime
141−coEnd = upd.coEnd'._D
142−
143−-- | The ID of the user who will be on call for the duration of the override.
144−coUserId :: Lens' (Request CreateOverride s b) UserId
145−coUserId = upd.coUserId'
146−
147−-- | Create an override for a specific user covering the specified time range. If
148−-- you create an override on top of an existing one, the last created override
149−-- will have priority.
150−--
151−-- If no time zone information is present in the since and until parameters, the
152−-- schedule's time zone will be used.
153−--
154−-- /Note:/ You cannot create overrides in the past.
155−--
156−-- @POST \/schedules\/\:schedule_id\/overrides@
157−--
158−-- /See:/ <http://developer.pagerduty.com/documentation/rest/schedules/overrides/create>
159−createOverride :: ScheduleId
160− -> UserId -- ^ 'coUserId'
161− -> Date -- ^ 'coStart'
162− -> Date -- ^ 'coEnd'
163− -> Request CreateOverride s Override
164−createOverride i u s e =
165− mk CreateOverride
166− { _coUserId' = u
167− , _coStart' = s
168− , _coEnd' = e
169− } & meth .~ POST
170− & path .~ overrides i
171−
172−-- | Remove an override.
173−--
174−-- You cannot remove a past override. If the override start
175−-- time is before the current time, but the end time is after the current time,
176−-- the override will be truncated to the current time. If the override is
177−-- truncated, the status code will be 200 OK, as opposed to a 204 No Content for a
178−-- successful delete.
179−--
180−-- @DELETE \/schedules\/\:schedule_id\/overrides\/\:id@
181−--
182−-- /See:/ <http://developer.pagerduty.com/documentation/rest/schedules/overrides/delete>
183−
184−-- FIXME: How to parse whether truncated or deleted?
185−deleteOverride :: ScheduleId -> OverrideId -> Request Empty s Empty
186−deleteOverride i o = empty
187− & meth .~ DELETE
188− & path .~ overrides i % o
src/Network/PagerDuty/REST/Services.hs+168−107
@@ -1,13 +1,12 @@
1−{-# LANGUAGE DataKinds #-}
1+{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE ExtendedDefaultRules #-}
2+{-# LANGUAGE ExtendedDefaultRules #-}
3−{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE TemplateHaskell #-}
4+{-# LANGUAGE TemplateHaskell #-}
5−{-# LANGUAGE TypeFamilies #-}
6
5
7{-# OPTIONS_GHC -fno-warn-type-defaults #-}
6{-# OPTIONS_GHC -fno-warn-type-defaults #-}
8
7
9-- Module : Network.PagerDuty.REST.Services
8-- Module : Network.PagerDuty.REST.Services
10−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
9+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
11-- License : This Source Code Form is subject to the terms of
10-- License : This Source Code Form is subject to the terms of
12-- the Mozilla Public License, v. 2.0.
11-- the Mozilla Public License, v. 2.0.
13-- 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
@@ -24,16 +23,14 @@
24-- When a service is shown inlined in other resources, a deleted service will
23-- When a service is shown inlined in other resources, a deleted service will
25-- have its @html_url@ attribute set to 'Nothing'.
24-- have its @html_url@ attribute set to 'Nothing'.
26--
25--
27−-- /See:/ <http://developer.pagerduty.com/documentation/rest/services>
26+-- See: <http://developer.pagerduty.com/documentation/rest/services>
28module Network.PagerDuty.REST.Services
27module Network.PagerDuty.REST.Services
29 (
28 (
30 -- * List Services
29 -- * List Services
31− ListServices
32− , listServices
30+ listServices
33 , lsTimeZone
31 , lsTimeZone
34
32
35 -- * Create Service
33 -- * Create Service
36− , CreateService
37 , createService
34 , createService
38 , csName
35 , csName
39 , csDescription
36 , csDescription
@@ -48,7 +45,6 @@ module Network.PagerDuty.REST.Services
48 , getService
45 , getService
49
46
50 -- * Update Service
47 -- * Update Service
51− , UpdateService
52 , updateService
48 , updateService
53 , usName
49 , usName
54 , usEscalationPolicyId
50 , usEscalationPolicyId
@@ -72,6 +68,7 @@ module Network.PagerDuty.REST.Services
72 -- * Types
68 -- * Types
73 , EmailFilterMode (..)
69 , EmailFilterMode (..)
74 , EmailIncidentCreation (..)
70 , EmailIncidentCreation (..)
71+ , MatchMode (..)
75 , ServiceStatus (..)
72 , ServiceStatus (..)
76 , ServiceType (..)
73 , ServiceType (..)
77 , SeverityFilter (..)
74 , SeverityFilter (..)
@@ -82,6 +79,15 @@ module Network.PagerDuty.REST.Services
82 , cntResolved
79 , cntResolved
83 , cntTotal
80 , cntTotal
84
81
82+ , EmailFilters (..)
83+ , efsId
84+ , efsSubjectMode
85+ , efsSubjectRegex
86+ , efsBodyMode
87+ , efsBodyRegex
88+ , efsFromEmailMode
89+ , efsFromEmailRegex
90+
85 , PolicyInfo
91 , PolicyInfo
86 , pinfoId
92 , pinfoId
87 , pinfoName
93 , pinfoName
@@ -106,16 +112,15 @@ module Network.PagerDuty.REST.Services
106 , svcSeverityFilter
112 , svcSeverityFilter
107 ) where
113 ) where
108
114
109−import Control.Lens hiding (Empty)
115+import Control.Lens
110−import Data.Aeson.Lens
116+import Data.Aeson.Lens
111−import Data.Text (Text)
117+import Data.ByteString.Builder (Builder)
112−import Data.Time
118+import Data.Text (Text)
113−import Network.HTTP.Types
119+import Network.HTTP.Types
114−import Network.PagerDuty.Internal.TH
120+import Network.PagerDuty.TH
115−import Network.PagerDuty.Internal.Types
121+import Network.PagerDuty.Types
116−import Network.PagerDuty.REST.Services.EmailFilters
117
122
118−default (Path)
123+default (Builder)
119
124
120services :: Path
125services :: Path
121services = "services"
126services = "services"
@@ -133,7 +138,8 @@ data IncidentCounts = IncidentCounts
133 , _cntTotal :: !Int
138 , _cntTotal :: !Int
134 } deriving (Eq, Show)
139 } deriving (Eq, Show)
135
140
141+deriveJSON ''IncidentCounts
136−deriveRecord ''IncidentCounts
142+makeLenses ''IncidentCounts
137
143
138data EmailIncidentCreation
144data EmailIncidentCreation
139 = OnNewEmail
145 = OnNewEmail
@@ -144,7 +150,7 @@ data EmailIncidentCreation
144 -- ^ Open a new incident only if an open incident does not already exist.
150 -- ^ Open a new incident only if an open incident does not already exist.
145 deriving (Eq, Show)
151 deriving (Eq, Show)
146
152
147−deriveNullary ''EmailIncidentCreation
153+deriveJSON ''EmailIncidentCreation
148
154
149data EmailFilterMode
155data EmailFilterMode
150 = AllEmail
156 = AllEmail
@@ -155,7 +161,7 @@ data EmailFilterMode
155 -- ^ Accept email only if it matches ALL of the rules below
161 -- ^ Accept email only if it matches ALL of the rules below
156 deriving (Eq, Show)
162 deriving (Eq, Show)
157
163
158−deriveNullaryWith hyphenated ''EmailFilterMode
164+deriveJSONWith hyphenated ''EmailFilterMode
159
165
160data ServiceStatus
166data ServiceStatus
161 = Active
167 = Active
@@ -171,7 +177,7 @@ data ServiceStatus
171 -- ^ The service is disabled and will not have any new triggered incidents.
177 -- ^ The service is disabled and will not have any new triggered incidents.
172 deriving (Eq, Show)
178 deriving (Eq, Show)
173
179
174−deriveNullary ''ServiceStatus
180+deriveJSON ''ServiceStatus
175
181
176data ServiceType
182data ServiceType
177 = CloudKick
183 = CloudKick
@@ -184,14 +190,72 @@ data ServiceType
184 | SqlMonitor
190 | SqlMonitor
185 deriving (Eq, Show)
191 deriving (Eq, Show)
186
192
187−deriveNullary ''ServiceType
193+deriveJSON ''ServiceType
188
194
189data PolicyInfo = PolicyInfo
195data PolicyInfo = PolicyInfo
190− { _pinfoId :: EscalationPolicyId
196+ { _pinfoId :: PolicyId
191 , _pinfoName :: Text
197 , _pinfoName :: Text
192 } deriving (Eq, Show)
198 } deriving (Eq, Show)
193
199
194−deriveRecord ''PolicyInfo
200+makeLenses ''PolicyInfo
201+deriveJSON ''PolicyInfo
202+
203+data MatchMode
204+ = Always
205+ | Match
206+ | NoMatch
207+ deriving (Eq, Show)
208+
209+deriveJSONWith hyphenated ''MatchMode
210+
211+-- FIXME: Tighten up this type! Make the regex required for match/no-match.
212+data EmailFilters = EmailFilters
213+ { _efsId :: EmailFilterId
214+ , _efsSubjectMode :: Maybe MatchMode
215+ , _efsSubjectRegex :: Maybe Text
216+ , _efsBodyMode :: Maybe MatchMode
217+ , _efsBodyRegex :: Maybe Text
218+ , _efsFromEmailMode :: Maybe MatchMode
219+ , _efsFromEmailRegex :: Maybe Text
220+ } deriving (Eq, Show)
221+
222+deriveJSON ''EmailFilters
223+
224+-- | The email filter ID.
225+makeLens "_efsId" ''EmailFilters
226+
227+-- | One of always, match, no-match, which, respectively, means to not filter
228+-- the email trigger by subject, filter it if the email subject matches the
229+-- given regex, or filter if it doesn't match the given regex.
230+--
231+-- Defaults to always.
232+makeLens "_efsSubjectMode" ''EmailFilters
233+
234+-- | The regex to be used when subject_mode is match or no-match.
235+-- It is a required parameter on such cases.
236+makeLens "_efsSubjectRegex" ''EmailFilters
237+
238+-- | One of always, match, no-match, which, respectively, means to not filter
239+-- the email trigger by body, filter it if the body email matches the given regex,
240+-- or filter if it doesn't match the given regex.
241+--
242+-- Defaults to always.
243+makeLens "_efsBodyMode" ''EmailFilters
244+
245+-- | The regex to be used when body_mode is match or no-match.
246+-- It is a required parameter on such cases.
247+makeLens "_efsBodyRegex" ''EmailFilters
248+
249+-- | One of always, match, no-match, which, respectively, means to not filter
250+-- the email trigger by its from address, filter it if the email from address
251+-- matches the given regex, or filter if it doesn't match the given regex.
252+--
253+-- Defaults to always.
254+makeLens "_efsFromEmailMode" ''EmailFilters
255+
256+-- | The regex to be used when from_email_mode is match or no-match.
257+-- It is a required parameter on such cases.
258+makeLens "_efsFromEmailRegex" ''EmailFilters
195
259
196data SeverityFilter
260data SeverityFilter
197 = SevCritical
261 = SevCritical
@@ -206,7 +270,7 @@ data SeverityFilter
206 -- ^ SQL Monitor: Incidents are created for with high or medium severity
270 -- ^ SQL Monitor: Incidents are created for with high or medium severity
207 deriving (Eq, Show)
271 deriving (Eq, Show)
208
272
209−deriveNullaryWith (dropped 3 underscored) ''SeverityFilter
273+deriveJSONWith (dropped 3 underscored) ''SeverityFilter
210
274
211data Service = Service
275data Service = Service
212 { _svcId :: ServiceId
276 { _svcId :: ServiceId
@@ -223,8 +287,8 @@ data Service = Service
223 , _svcIncidentCounts :: IncidentCounts
287 , _svcIncidentCounts :: IncidentCounts
224 , _svcEmailFilterMode :: EmailFilterMode
288 , _svcEmailFilterMode :: EmailFilterMode
225 , _svcType :: ServiceType
289 , _svcType :: ServiceType
226− , _svcEscalationPolicy :: Maybe PolicyInfo -- FIXME: extract from inline.
290+ , _svcEscalationPolicy :: Maybe PolicyInfo -- FIXME: extract from inline.
227− , _svcEmailFilters :: Maybe [EmailFilterInfo] -- FIXME: extract from inline.
291+ , _svcEmailFilters :: Maybe EmailFilters -- FIXME: extract from inline.
228 , _svcSeverityFilter :: Maybe SeverityFilter
292 , _svcSeverityFilter :: Maybe SeverityFilter
229 } deriving (Eq, Show)
293 } deriving (Eq, Show)
230
294
@@ -256,17 +320,13 @@ makeLens "_svcAutoResolveTimeout" ''Service
256makeLens "_svcAcknowledgementTimeout" ''Service
320makeLens "_svcAcknowledgementTimeout" ''Service
257
321
258-- | The date/time when this service was created.
322-- | The date/time when this service was created.
259−svcCreatedAt :: Lens' Service UTCTime
323+makeLens "_svcCreatedAt" ''Service
260−svcCreatedAt = lens _svcCreatedAt (\s x -> s { _svcCreatedAt = x }) . _D
261
324
262-- | The current state of the Service.
325-- | The current state of the Service.
263makeLens "_svcStatus" ''Service
326makeLens "_svcStatus" ''Service
264
327
265-- | The date/time when the most recent incident was created for this service.
328-- | The date/time when the most recent incident was created for this service.
266−svcLastIncidentTimestamp :: Lens' Service (Maybe UTCTime)
329+makeLens "_svcLastIncidentTimestamp" ''Service
267−svcLastIncidentTimestamp =
268− lens _svcLastIncidentTimestamp
269− (\s x -> s { _svcLastIncidentTimestamp = x }) . mapping _D
270
330
271-- | If the service is a Generic Email service, this describes what kind of
331-- | If the service is a Generic Email service, this describes what kind of
272-- emails create an incident.
332-- emails create an incident.
@@ -294,35 +354,36 @@ makeLens "_svcEmailFilters" ''Service
294makeLens "_svcSeverityFilter" ''Service
354makeLens "_svcSeverityFilter" ''Service
295
355
296newtype ListServices = ListServices
356newtype ListServices = ListServices
297− { _lsTimeZone' :: Maybe TZ
357+ { _lsTimeZone' :: Maybe TimeZone
298 } deriving (Eq, Show)
358 } deriving (Eq, Show)
299
359
300instance Paginate ListServices
360instance Paginate ListServices
301
361
302−queryRequest ''ListServices
362+deriveJSON ''ListServices
303−
363+makeLenses ''ListServices
304−-- | Time zone in which dates in the result will be rendered.
305−--
306−-- /Default:/ account default time zone.
307−lsTimeZone :: Lens' (Request ListServices s r) (Maybe TimeZone)
308−lsTimeZone = upd.lsTimeZone'.mapping _TZ
309
364
310-- | List existing services.
365-- | List existing services.
311--
366--
312-- @GET \/services@
367-- @GET \/services@
313--
368--
314−-- /See:/ <http://developer.pagerduty.com/documentation/rest/services/list>
369+-- See: <http://developer.pagerduty.com/documentation/rest/services/list>
315listServices :: Request ListServices s [Service]
370listServices :: Request ListServices s [Service]
316listServices =
371listServices =
317 mk ListServices
372 mk ListServices
318 { _lsTimeZone' = Nothing
373 { _lsTimeZone' = Nothing
319 } & path .~ services
374 } & path .~ services
320− & query .~ includes
375+ & query <>~ includes
321 & unwrap .~ key "escalation_policies"
376 & unwrap .~ key "escalation_policies"
322
377
378+-- | Time zone in which dates in the result will be rendered.
379+--
380+-- Defaults to account default time zone.
381+lsTimeZone :: Lens' (Request ListServices s r) (Maybe TimeZone)
382+lsTimeZone = upd.lsTimeZone'
383+
323data CreateService = CreateService
384data CreateService = CreateService
324 { _csName' :: Text
385 { _csName' :: Text
325− , _csEscalationPolicyId' :: EscalationPolicyId
386+ , _csEscalationPolicyId' :: PolicyId
326 , _csType' :: !ServiceType
387 , _csType' :: !ServiceType
327 , _csVendorId' :: Maybe VendorId
388 , _csVendorId' :: Maybe VendorId
328 , _csDescription' :: Maybe Text
389 , _csDescription' :: Maybe Text
@@ -331,7 +392,30 @@ data CreateService = CreateService
331 , _csSeverityFilter' :: Maybe SeverityFilter
392 , _csSeverityFilter' :: Maybe SeverityFilter
332 } deriving (Eq, Show)
393 } deriving (Eq, Show)
333
394
334−jsonRequest ''CreateService
395+deriveJSON ''CreateService
396+makeLenses ''CreateService
397+
398+-- | Creates a new service.
399+--
400+-- @POST \/services@
401+--
402+-- See: <http://developer.pagerduty.com/documentation/rest/services/create>
403+createService :: Text
404+ -> PolicyId
405+ -> ServiceType
406+ -> Request CreateService s Service
407+createService n p t =
408+ mk CreateService
409+ { _csName' = n
410+ , _csEscalationPolicyId' = p
411+ , _csType' = t
412+ , _csVendorId' = Nothing
413+ , _csDescription' = Nothing
414+ , _csAcknowledgementTimeout' = Nothing
415+ , _csAutoResolveTimeout' = Nothing
416+ , _csSeverityFilter' = Nothing
417+ } & path .~ services
418+ & unwrap .~ key "service"
335
419
336-- | The name of the service.
420-- | The name of the service.
337csName :: Lens' (Request CreateService s r) Text
421csName :: Lens' (Request CreateService s r) Text
@@ -351,19 +435,19 @@ csVendorId :: Lens' (Request CreateService s r) (Maybe VendorId)
351csVendorId = upd.csVendorId'
435csVendorId = upd.csVendorId'
352
436
353-- | The id of the escalation policy to be used by this service.
437-- | The id of the escalation policy to be used by this service.
354−csEscalationPolicyId :: Lens' (Request CreateService s r) EscalationPolicyId
438+csEscalationPolicyId :: Lens' (Request CreateService s r) PolicyId
355csEscalationPolicyId = upd.csEscalationPolicyId'
439csEscalationPolicyId = upd.csEscalationPolicyId'
356
440
357-- | The duration in seconds before an incidents acknowledged in this service
441-- | The duration in seconds before an incidents acknowledged in this service
358-- become triggered again.
442-- become triggered again.
359--
443--
360−-- /Default:/ 30 minutes.
444+-- Defaults to 30 minutes.
361csAcknowledgementTimeout :: Lens' (Request CreateService s r) (Maybe Int)
445csAcknowledgementTimeout :: Lens' (Request CreateService s r) (Maybe Int)
362csAcknowledgementTimeout = upd.csAcknowledgementTimeout'
446csAcknowledgementTimeout = upd.csAcknowledgementTimeout'
363
447
364-- | The duration in seconds before a triggered incident auto-resolves itself.
448-- | The duration in seconds before a triggered incident auto-resolves itself.
365--
449--
366−-- /Default:/ 4 hours.
450+-- Defaults to 4 hours.
367csAutoResolveTimeout :: Lens' (Request CreateService s r) (Maybe Int)
451csAutoResolveTimeout :: Lens' (Request CreateService s r) (Maybe Int)
368csAutoResolveTimeout = upd.csAutoResolveTimeout'
452csAutoResolveTimeout = upd.csAutoResolveTimeout'
369
453
@@ -371,33 +455,11 @@ csAutoResolveTimeout = upd.csAutoResolveTimeout'
371csSeverityFilter :: Lens' (Request CreateService s r) (Maybe SeverityFilter)
455csSeverityFilter :: Lens' (Request CreateService s r) (Maybe SeverityFilter)
372csSeverityFilter = upd.csSeverityFilter'
456csSeverityFilter = upd.csSeverityFilter'
373
457
374−-- | Creates a new service.
375−--
376−-- @POST \/services@
377−--
378−-- /See:/ <http://developer.pagerduty.com/documentation/rest/services/create>
379−createService :: Text
380− -> EscalationPolicyId
381− -> ServiceType
382− -> Request CreateService s Service
383−createService n p t =
384− mk CreateService
385− { _csName' = n
386− , _csEscalationPolicyId' = p
387− , _csType' = t
388− , _csVendorId' = Nothing
389− , _csDescription' = Nothing
390− , _csAcknowledgementTimeout' = Nothing
391− , _csAutoResolveTimeout' = Nothing
392− , _csSeverityFilter' = Nothing
393− } & path .~ services
394− & unwrap .~ key "service"
395−
396-- | Get details about an existing service.
458-- | Get details about an existing service.
397--
459--
398-- @GET services\/\:id@
460-- @GET services\/\:id@
399--
461--
400−-- /See:/ <http://developer.pagerduty.com/documentation/rest/services/show>
462+-- See: <http://developer.pagerduty.com/documentation/rest/services/show>
401getService :: ServiceId -> Request Empty s Service
463getService :: ServiceId -> Request Empty s Service
402getService i = empty
464getService i = empty
403 & path .~ services % i
465 & path .~ services % i
@@ -407,13 +469,32 @@ getService i = empty
407data UpdateService = UpdateService
469data UpdateService = UpdateService
408 { _usName' :: Maybe Text
470 { _usName' :: Maybe Text
409 , _usDescription' :: Maybe Text
471 , _usDescription' :: Maybe Text
410− , _usEscalationPolicyId' :: Maybe EscalationPolicyId
472+ , _usEscalationPolicyId' :: Maybe PolicyId
411 , _usAcknowledgementTimeout' :: Maybe Int
473 , _usAcknowledgementTimeout' :: Maybe Int
412 , _usAutoResolveTimeout' :: Maybe Int
474 , _usAutoResolveTimeout' :: Maybe Int
413 , _usSeverityFilter' :: Maybe SeverityFilter
475 , _usSeverityFilter' :: Maybe SeverityFilter
414 } deriving (Eq, Show)
476 } deriving (Eq, Show)
415
477
478+deriveJSON ''UpdateService
416−jsonRequest ''UpdateService
479+makeLenses ''UpdateService
480+
481+-- | Update an existing service.
482+--
483+-- @PUT services\/\:id@
484+--
485+-- See: <http://developer.pagerduty.com/documentation/rest/services/update>
486+updateService :: ServiceId -> Request UpdateService s Service
487+updateService i =
488+ mk UpdateService
489+ { _usName' = Nothing
490+ , _usEscalationPolicyId' = Nothing
491+ , _usDescription' = Nothing
492+ , _usAcknowledgementTimeout' = Nothing
493+ , _usAutoResolveTimeout' = Nothing
494+ , _usSeverityFilter' = Nothing
495+ } & meth .~ PUT
496+ & path .~ services % i
497+ & unwrap .~ key "service"
417
498
418-- | The name of the service.
499-- | The name of the service.
419usName :: Lens' (Request UpdateService s r) (Maybe Text)
500usName :: Lens' (Request UpdateService s r) (Maybe Text)
@@ -424,19 +505,19 @@ usDescription :: Lens' (Request UpdateService s r) (Maybe Text)
424usDescription = upd.usDescription'
505usDescription = upd.usDescription'
425
506
426-- | The id of the escalation policy to be used by this service.
507-- | The id of the escalation policy to be used by this service.
427−usEscalationPolicyId :: Lens' (Request UpdateService s r) (Maybe EscalationPolicyId)
508+usEscalationPolicyId :: Lens' (Request UpdateService s r) (Maybe PolicyId)
428usEscalationPolicyId = upd.usEscalationPolicyId'
509usEscalationPolicyId = upd.usEscalationPolicyId'
429
510
430-- | The duration in seconds before an incidents acknowledged in this service
511-- | The duration in seconds before an incidents acknowledged in this service
431-- become triggered again.
512-- become triggered again.
432--
513--
433−-- /Default:/ 30 minutes.
514+-- Defaults to 30 minutes.
434usAcknowledgementTimeout :: Lens' (Request UpdateService s r) (Maybe Int)
515usAcknowledgementTimeout :: Lens' (Request UpdateService s r) (Maybe Int)
435usAcknowledgementTimeout = upd.usAcknowledgementTimeout'
516usAcknowledgementTimeout = upd.usAcknowledgementTimeout'
436
517
437-- | The duration in seconds before a triggered incident auto-resolves itself.
518-- | The duration in seconds before a triggered incident auto-resolves itself.
438--
519--
439−-- /Default:/ 4 hours.
520+-- Defaults to 4 hours.
440usAutoResolveTimeout :: Lens' (Request UpdateService s r) (Maybe Int)
521usAutoResolveTimeout :: Lens' (Request UpdateService s r) (Maybe Int)
441usAutoResolveTimeout = upd.usAutoResolveTimeout'
522usAutoResolveTimeout = upd.usAutoResolveTimeout'
442
523
@@ -444,31 +525,13 @@ usAutoResolveTimeout = upd.usAutoResolveTimeout'
444usSeverityFilter :: Lens' (Request UpdateService s r) (Maybe SeverityFilter)
525usSeverityFilter :: Lens' (Request UpdateService s r) (Maybe SeverityFilter)
445usSeverityFilter = upd.usSeverityFilter'
526usSeverityFilter = upd.usSeverityFilter'
446
527
447−-- | Update an existing service.
448−--
449−-- @PUT services\/\:id@
450−--
451−-- /See:/ <http://developer.pagerduty.com/documentation/rest/services/update>
452−updateService :: ServiceId -> Request UpdateService s Service
453−updateService i =
454− mk UpdateService
455− { _usName' = Nothing
456− , _usEscalationPolicyId' = Nothing
457− , _usDescription' = Nothing
458− , _usAcknowledgementTimeout' = Nothing
459− , _usAutoResolveTimeout' = Nothing
460− , _usSeverityFilter' = Nothing
461− } & meth .~ PUT
462− & path .~ services % i
463− & unwrap .~ key "service"
464−
465-- | Delete an existing service. Once the service is deleted, it will not be
528-- | Delete an existing service. Once the service is deleted, it will not be
466-- accessible from the web UI and new incidents won't be able to be created
529-- accessible from the web UI and new incidents won't be able to be created
467-- for this service.
530-- for this service.
468--
531--
469-- @DELETE \/services/:id@
532-- @DELETE \/services/:id@
470--
533--
471−-- /See:/ <http://developer.pagerduty.com/documentation/rest/services/delete>
534+-- See: <http://developer.pagerduty.com/documentation/rest/services/delete>
472deleteService :: ServiceId -> Request Empty s Empty
535deleteService :: ServiceId -> Request Empty s Empty
473deleteService i = empty & meth .~ DELETE & path .~ services % i
536deleteService i = empty & meth .~ DELETE & path .~ services % i
474
537
@@ -476,14 +539,13 @@ deleteService i = empty & meth .~ DELETE & path .~ services % i
476--
539--
477-- @PUT services\/\:id\/enable@
540-- @PUT services\/\:id\/enable@
478--
541--
479−-- /See:/ <http://developer.pagerduty.com/documentation/rest/services/enable>
542+-- See: <http://developer.pagerduty.com/documentation/rest/services/enable>
480enableService :: RequesterId -> ServiceId -> Request Empty s Empty
543enableService :: RequesterId -> ServiceId -> Request Empty s Empty
481−enableService r i =
482− auth (enableServiceBasic i) & query .~ [("requester_id", r)]
544+enableService r i = auth (enableServiceBasic i) & query .~ [("requester_id", r)]
483
545
484-- | A version of 'enableService' which uses HTTP Basic authentication and
546-- | A version of 'enableService' which uses HTTP Basic authentication and
485-- doesn't require a 'RequesterId'.
547-- doesn't require a 'RequesterId'.
486−enableServiceBasic :: ServiceId -> Request Empty 'Basic Empty
548+enableServiceBasic :: ServiceId -> Request Empty Basic Empty
487enableServiceBasic i = empty & meth .~ PUT & path .~ services % i % "enable"
549enableServiceBasic i = empty & meth .~ PUT & path .~ services % i % "enable"
488
550
489-- | Disable a service. Once a service is disabled, it will not be able to
551-- | Disable a service. Once a service is disabled, it will not be able to
@@ -491,14 +553,13 @@ enableServiceBasic i = empty & meth .~ PUT & path .~ services % i % "enable"
491--
553--
492-- @PUT services\/\:id\/disable@
554-- @PUT services\/\:id\/disable@
493--
555--
494−-- /See:/ <http://developer.pagerduty.com/documentation/rest/services/disable>
556+-- See: <http://developer.pagerduty.com/documentation/rest/services/disable>
495disableService :: RequesterId -> ServiceId -> Request Empty s Empty
557disableService :: RequesterId -> ServiceId -> Request Empty s Empty
496−disableService r i =
497− auth (disableServiceBasic i) & query .~ [("requester_id", r)]
558+disableService r i = auth (disableServiceBasic i) & query .~ [("requester_id", r)]
498
559
499-- | A version of 'disableService' which uses HTTP Basic authentication and
560-- | A version of 'disableService' which uses HTTP Basic authentication and
500-- doesn't require a 'RequesterId'.
561-- doesn't require a 'RequesterId'.
501−disableServiceBasic :: ServiceId -> Request Empty 'Basic Empty
562+disableServiceBasic :: ServiceId -> Request Empty Basic Empty
502disableServiceBasic i = empty & meth .~ PUT & path .~ services % i % "disable"
563disableServiceBasic i = empty & meth .~ PUT & path .~ services % i % "disable"
503
564
504-- | Regenerate a new service key for an existing service.
565-- | Regenerate a new service key for an existing service.
@@ -508,6 +569,6 @@ disableServiceBasic i = empty & meth .~ PUT & path .~ services % i % "disable"
508--
569--
509-- @POST services\/\:id\/regenerate_key@
570-- @POST services\/\:id\/regenerate_key@
510--
571--
511−-- /See:/ <http://developer.pagerduty.com/documentation/rest/services/regenerate_key>
572+-- See: <http://developer.pagerduty.com/documentation/rest/services/regenerate_key>
512regenerateKey :: ServiceId -> Request Empty s Service
573regenerateKey :: ServiceId -> Request Empty s Service
513regenerateKey i = empty & meth .~ POST & path .~ services % i % "regenerate_key"
574regenerateKey i = empty & meth .~ POST & path .~ services % i % "regenerate_key"
src/Network/PagerDuty/REST/Services/EmailFilters.hsdeleted−180
@@ -1,180 +0,0 @@
1−{-# LANGUAGE ExtendedDefaultRules #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE TemplateHaskell #-}
4−
5−{-# OPTIONS_GHC -fno-warn-type-defaults #-}
6−
7−-- Module : Network.PagerDuty.REST.Services.EmailFilters
8−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
9−-- License : This Source Code Form is subject to the terms of
10−-- the Mozilla Public License, v. 2.0.
11−-- A copy of the MPL can be found in the LICENSE file or
12−-- you can obtain it at http://mozilla.org/MPL/2.0/.
13−-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
14−-- Stability : experimental
15−-- Portability : non-portable (GHC extensions)
16−
17−-- | Email Filters are a set of rules that are applied to triggering email's body,
18−-- subject and from address. It only applies to generic_email kind of
19−-- Services. The way multiple filters are combined depends on the
20−-- email_filter_mode attribute of the service.
21−--
22−-- /See:/ <http://developer.pagerduty.com/documentation/rest/services/email_filters>
23−module Network.PagerDuty.REST.Services.EmailFilters
24− (
25− -- * Create Email Filter
26− createEmailFilter
27−
28− -- * Update Email Filter
29− , updateEmailFilter
30−
31− -- * Delete Email Filter
32− , deleteEmailFilter
33−
34− -- * Types
35− , MatchMode (..)
36− , HasEmailFilterInfo (..)
37− , EmailFilterInfo
38− , EmailFilter
39− , efId
40− ) where
41−
42−import Control.Applicative hiding (empty)
43−import Control.Lens hiding ((.=))
44−import Data.Aeson
45−import Data.Default.Class
46−import Data.Monoid
47−import Data.Text (Text)
48−import Network.HTTP.Types
49−import Network.PagerDuty.Internal.TH
50−import Network.PagerDuty.Internal.Types
51−
52−default (Path)
53−
54−filters :: ServiceId -> Path
55−filters s = "services" % s % "email_filters"
56−
57−data MatchMode
58− = Always
59− | Match
60− | NoMatch
61− deriving (Eq, Show)
62−
63−deriveNullaryWith hyphenated ''MatchMode
64−
65−-- FIXME: Tighten up this type! Make the regex required for match/no-match and
66−-- encode the conditional invariants.
67−data EmailFilterInfo = EmailFilterInfo
68− { _efSubjectMode' :: Maybe MatchMode
69− , _efSubjectRegex' :: Maybe Text
70− , _efBodyMode' :: Maybe MatchMode
71− , _efBodyRegex' :: Maybe Text
72− , _efFromEmailMode' :: Maybe MatchMode
73− , _efFromEmailRegex' :: Maybe Text
74− } deriving (Eq, Show)
75−
76−deriveRecord ''EmailFilterInfo
77−
78−instance Default EmailFilterInfo where
79− def = EmailFilterInfo Nothing Nothing Nothing Nothing Nothing Nothing
80−
81−instance QueryLike EmailFilterInfo where
82− toQuery = const []
83−
84−class HasEmailFilterInfo a where
85− emailFilterInfo :: Lens' a EmailFilterInfo
86−
87− -- | One of always, match, no-match, which, respectively, means to not
88− -- filter the email trigger by subject, filter it if the email subject
89− -- matches the given regex, or filter if it doesn't match the given regex.
90− --
91− -- /Default:/ always.
92− efSubjectMode :: Lens' a (Maybe MatchMode)
93−
94− -- | The regex to be used when subject_mode is match or no-match.
95− -- It is a required parameter on such cases.
96− efSubjectRegex :: Lens' a (Maybe Text)
97−
98− -- | One of always, match, no-match, which, respectively, means to not filter
99− -- the email trigger by body, filter it if the body email matches the given
100− -- regex, or filter if it doesn't match the given regex.
101− --
102− -- /Default:/ always.
103− efBodyMode :: Lens' a (Maybe MatchMode)
104−
105− -- | The regex to be used when body_mode is match or no-match.
106− -- It is a required parameter on such cases.
107− efBodyRegex :: Lens' a (Maybe Text)
108−
109− -- | One of always, match, no-match, which, respectively, means to not filter
110− -- the email trigger by its from address, filter it if the email from address
111− -- matches the given regex, or filter if it doesn't match the given regex.
112− --
113− -- /Default:/ always.
114− efFromEmailMode :: Lens' a (Maybe MatchMode)
115−
116− -- | The regex to be used when from_email_mode is match or no-match.
117− -- It is a required parameter on such cases.
118− efFromEmailRegex :: Lens' a (Maybe Text)
119−
120− efSubjectMode = emailFilterInfo.efSubjectMode'
121− efSubjectRegex = emailFilterInfo.efSubjectRegex'
122− efBodyMode = emailFilterInfo.efBodyMode'
123− efBodyRegex = emailFilterInfo.efBodyRegex'
124− efFromEmailMode = emailFilterInfo.efFromEmailMode'
125− efFromEmailRegex = emailFilterInfo.efFromEmailRegex'
126−
127−instance (QueryLike a, ToJSON a, HasEmailFilterInfo a)
128− => HasEmailFilterInfo (Request a s b) where
129− emailFilterInfo = upd.emailFilterInfo
130−
131−instance HasEmailFilterInfo EmailFilterInfo where
132− emailFilterInfo = id
133−
134−data EmailFilter = EmailFilter
135− { _efId :: EmailFilterId
136− , _efInfo :: EmailFilterInfo
137− } deriving (Eq, Show)
138−
139−instance FromJSON EmailFilter where
140− parseJSON = withObject "email_filter" $ \o ->
141− EmailFilter <$> parseJSON (Object o)
142− <*> o .: "id"
143−
144−instance ToJSON EmailFilter where
145− toJSON e = Object (x <> y)
146− where
147− Object x = toJSON (_efInfo e)
148− Object y = object ["id" .= _efId e]
149−
150−instance HasEmailFilterInfo EmailFilter where
151− emailFilterInfo = lens _efInfo (\e x -> e { _efInfo = x })
152−
153−-- | The email filter ID.
154−makeLens "_efId" ''EmailFilter
155−
156−-- | Create a new Email Filter for the specified service.
157−--
158−-- @POST \/services\/\:service_id\/email_filters@
159−--
160−-- /See:/ <http://developer.pagerduty.com/documentation/rest/services/email_filters/create>
161−createEmailFilter :: ServiceId -> Request EmailFilterInfo s EmailFilter
162−createEmailFilter s = mk def & meth .~ POST & path .~ filters s
163−
164−-- | Update an existing Email Filter.
165−--
166−-- @PUT \/services\/\:service_id\/email_filters\/\:id@
167−--
168−-- /See:/ <http://developer.pagerduty.com/documentation/rest/services/email_filters/update>
169−updateEmailFilter :: ServiceId
170− -> EmailFilterId
171− -> Request EmailFilterInfo s Empty
172−updateEmailFilter s e = mk def & meth .~ PUT & path .~ filters s % e
173−
174−-- | Delete an existing Email Filter.
175−--
176−-- @DELETE \/services\/\:service_id\/email_filters\/\:id@
177−--
178−-- /See:/ <http://developer.pagerduty.com/documentation/rest/services/email_filters/delete>
179−deleteEmailFilter :: ServiceId -> EmailFilterId -> Request Empty s Empty
180−deleteEmailFilter s e = empty & meth .~ DELETE & path .~ filters s % e
src/Network/PagerDuty/REST/Users.hs+3−364
@@ -1,13 +1,8 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE ExtendedDefaultRules #-}
3−{-# LANGUAGE OverloadedStrings #-}
1+{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE TemplateHaskell #-}
2+{-# LANGUAGE TemplateHaskell #-}
5−{-# LANGUAGE TypeFamilies #-}
6−
7−{-# OPTIONS_GHC -fno-warn-type-defaults #-}
8
3
9-- Module : Network.PagerDuty.REST.Users
4-- Module : Network.PagerDuty.REST.Users
10−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
5+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
11-- License : This Source Code Form is subject to the terms of
6-- License : This Source Code Form is subject to the terms of
12-- the Mozilla Public License, v. 2.0.
7-- the Mozilla Public License, v. 2.0.
13-- A copy of the MPL can be found in the LICENSE file or
8-- A copy of the MPL can be found in the LICENSE file or
@@ -19,366 +14,10 @@
19-- | Access and manipulate user data for your PagerDuty account. When a user is
14-- | Access and manipulate user data for your PagerDuty account. When a user is
20-- shown inlined in other resources, a deleted user will have its @html_url@ attribute
15-- shown inlined in other resources, a deleted user will have its @html_url@ attribute
21-- set to null.
16-- set to null.
22−--
23−-- /See:/ <http://developer.pagerduty.com/documentation/rest/users>
24module Network.PagerDuty.REST.Users
17module Network.PagerDuty.REST.Users
25 (
18 (
26− -- * List Users
27− ListUsers
28− , listUsers
29− , luQuery
30−
31− -- * List On Call Users
32− , listOnCallUsers
33−
34− -- * Create User
35− , CreateUser
36− , createUser
37− , cuName
38− , cuEmail
39− , cuRole
40− , cuJobTitle
41− , cuTimeZone
42−
43− -- * Get User
44− , getUser
45−
46− -- * Get User On Call
47− , getUserOnCall
48−
49− -- * Update User
50− , UpdateUser
51− , updateUser
52− , uuName
53− , uuEmail
54− , uuRole
55− , uuJobTitle
56− , uuTimeZone
57−
58− -- * Delete User
59− , deleteUser
60−
61− -- * Types
62− , PolicyInfo
63− , piId
64− , piName
65
19
66− , OnCall
67− , ocLevel
68− , ocStart
69− , ocEnd
70− , ocEscalationPolicy
71−
72− , Role (..)
73−
74− , HasUserInfo (..)
75− , UserInfo
76− , User
77− , uRole
78− , uAvatarUrl
79− , uUserUrl
80− , uInvitationSent
81− , uJobTitle
82 ) where
20 ) where
83
21
84−import Control.Applicative hiding (empty)
85−import Control.Lens hiding (Empty, (.=))
86−import Data.Aeson
87−import Data.Default.Class
88−import Data.Monoid
89−import Data.Text (Text)
90−import Data.Time
91−import Network.HTTP.Types
92−import Network.PagerDuty.Internal.TH
93−import Network.PagerDuty.Internal.Types
94−
95−default (Path)
96−
97users :: Path
22users :: Path
98users = "users"
23users = "users"
99−
100−includes :: Query
101−includes =
102− [ ("include[]", Just "contact_methods")
103− , ("include[]", Just "notification_rules")
104− ]
105−
106−data UserInfo = UserInfo
107− { _uId' :: UserId
108− , _uName' :: Text
109− , _uEmail' :: Address
110− , _uColor' :: Text
111− , _uTimeZone' :: TZ
112− } deriving (Eq, Show)
113−
114−deriveRecord ''UserInfo
115−
116−class HasUserInfo a where
117− userInfo :: Lens' a UserInfo
118−
119− -- | The id of the user.
120− uId :: Lens' a UserId
121−
122− -- | The name of the user.
123− uName :: Lens' a Text
124−
125− -- | The user's email address.
126− uEmail :: Lens' a Address
127−
128− -- | The color used to represent the user in schedules.
129− uColor :: Lens' a Text
130−
131− -- | The user's personal time zone.
132− uTimeZone :: Lens' a TimeZone
133−
134− uId = userInfo.uId'
135− uName = userInfo.uName'
136− uEmail = userInfo.uEmail'
137− uColor = userInfo.uColor'
138− uTimeZone = userInfo.uTimeZone'._TZ
139−
140−instance (QueryLike a, ToJSON a, HasUserInfo a)
141− => HasUserInfo (Request a s b) where
142− userInfo = upd.userInfo
143−
144−instance HasUserInfo UserInfo where
145− userInfo = id
146−
147−data PolicyInfo = PolicyInfo
148− { _piId :: EscalationPolicyId
149− , _piName :: Text
150− } deriving (Eq, Show)
151−
152−deriveRecord ''PolicyInfo
153−
154−data OnCall = OnCall
155− { _ocLevel :: !Int
156− , _ocStart :: Maybe Date
157− , _ocEnd :: Maybe Date
158− , _ocEscalationPolicy :: PolicyInfo
159− } deriving (Eq, Show)
160−
161−deriveRecord ''OnCall
162−
163−data Role
164− = RoleAdmin
165− | RoleUser
166− | RoleLimitedUser
167− deriving (Eq, Show)
168−
169−deriveNullaryWith (dropped 4 underscored) ''Role
170−
171−instance Default Role where
172− def = RoleUser
173−
174−data User = User
175− { _uInfo :: UserInfo
176− , _uRole :: !Role
177− , _uAvatarUrl :: Text
178− , _uUserUrl :: Text
179− , _uInvitationSent' :: !Bool'
180− , _uJobTitle :: Maybe Text
181− } deriving (Eq, Show)
182−
183− -- FIXME: add notification_rules, contact_methods, on_call
184−
185−makeLenses ''User
186−
187−instance FromJSON User where
188− parseJSON = withObject "user" $ \o ->
189− User <$> parseJSON (Object o)
190− <*> o .: "role"
191− <*> o .: "avatar_url"
192− <*> o .: "user_url"
193− <*> o .: "invitation_sent"
194− <*> o .:? "job_title"
195−
196−instance ToJSON User where
197− toJSON u = Object (x <> y)
198− where
199− Object x = toJSON (_uInfo u)
200− Object y = object
201− [ "role" .= _uRole u
202− , "avatar_url" .= _uAvatarUrl u
203− , "user_url" .= _uUserUrl u
204− , "invitation_sent" .= _uInvitationSent' u
205− , "job_title" .= _uJobTitle u
206− ]
207−
208−instance HasUserInfo User where
209− userInfo = uInfo
210−
211−uInvitationSent :: Lens' User Bool
212−uInvitationSent = uInvitationSent'._B
213−
214−newtype ListUsers = ListUsers
215− { _luQuery' :: Maybe Text
216− }
217−
218−queryRequest ''ListUsers
219−
220−instance Paginate ListUsers
221−
222−-- | Filters the result, showing only the users whose names or email addresses
223−-- match the query.
224−luQuery :: Lens' (Request ListUsers s b) (Maybe Text)
225−luQuery = upd.luQuery'
226−
227−-- | List users of your PagerDuty account, optionally filtered by a search query.
228−--
229−-- @GET \/users@
230−--
231−-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/list>
232−listUsers :: Request ListUsers s [User]
233−listUsers =
234− mk ListUsers
235− { _luQuery' = Nothing
236− } & path .~ users
237− & query .~ includes
238−
239−-- | List all the existing escalation policies with currently on-call users.
240−--
241−-- If the start and end of an on-call object are null, then the user is always
242−-- on-call for an escalation policy level.
243−--
244−-- @GET \/escalation_policies\/on_call@
245−--
246−-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/on_call>
247−listOnCallUsers :: Request ListUsers s [User]
248−listOnCallUsers = listUsers & path .~ users % "on_call"
249−
250−-- | Get information about an existing user.
251−--
252−-- @GET \/users\/\:id@
253−--
254−-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/show>
255−getUser :: UserId -> Request Empty s User
256−getUser u = empty & path .~ users % u & query .~ includes
257−
258−-- | Get a user object with that user's current on-call status. If the on-call
259−-- object is an empty list, the user is never on-call.
260−--
261−-- If the start and end of an on-call object are null, then the user is always
262−-- on-call for an escalation policy level.
263−--
264−-- @GET \/users\/\:id\/on_call@
265−--
266−-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/show_on_call>
267−getUserOnCall :: UserId -> Request Empty s User
268−getUserOnCall u = empty & path .~ users % u % "on_call" & query .~ includes
269−
270−data CreateUser = CreateUser
271− { _cuName' :: Text
272− , _cuEmail' :: Address
273− , _cuRole' :: Maybe Role
274− , _cuJobTitle' :: Maybe Text
275− , _cuTimeZone' :: Maybe TZ
276− } deriving (Eq, Show)
277−
278−jsonRequest ''CreateUser
279−
280−-- | The name of the user.
281−cuName :: Lens' (Request CreateUser s b) Text
282−cuName = upd.cuName'
283−
284−-- | The email of the user. The newly created user will receive an email asking
285−-- to confirm the subscription.
286−cuEmail :: Lens' (Request CreateUser s b) Address
287−cuEmail = upd.cuEmail'
288−
289−-- | The user's role.
290−cuRole :: Lens' (Request CreateUser s b) (Maybe Role)
291−cuRole = upd.cuRole'
292−
293−-- | The job title of the user.
294−cuJobTitle :: Lens' (Request CreateUser s b) (Maybe Text)
295−cuJobTitle = upd.cuJobTitle'
296−
297−-- | The time zone the user is in. If not specified, the time zone of the
298−-- account making the API call will be used.
299−cuTimeZone :: Lens' (Request CreateUser s b) (Maybe TimeZone)
300−cuTimeZone = upd.cuTimeZone'.mapping _TZ
301−
302−-- | Create a new user for your account. An invite email will be sent asking
303−-- the user to choose a password.
304−--
305−-- @POST \/users@
306−--
307−-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/create>
308−createUser :: RequesterId
309− -> Text -- ^ 'cuName'
310− -> Address -- ^ 'cuEmail'
311− -> Request CreateUser s User
312−createUser r n e = auth (createUserBasic n e) & query .~ [("requester_id", r)]
313−
314−-- | A version of 'disableService' which uses HTTP Basic authentication and
315−-- doesn't require a 'RequesterId'.
316−createUserBasic :: Text -- ^ 'cuName'
317− -> Address -- ^ 'cuEmail'
318− -> Request CreateUser 'Basic User
319−createUserBasic n e =
320− mk CreateUser
321− { _cuName' = n
322− , _cuEmail' = e
323− , _cuRole' = Nothing
324− , _cuJobTitle' = Nothing
325− , _cuTimeZone' = Nothing
326− } & meth .~ POST
327− & path .~ users
328−
329−data UpdateUser = UpdateUser
330− { _uuName' :: Maybe Text
331− , _uuEmail' :: Maybe Address
332− , _uuRole' :: Maybe Role
333− , _uuJobTitle' :: Maybe Text
334− , _uuTimeZone' :: Maybe TZ
335− } deriving (Eq, Show)
336−
337−jsonRequest ''UpdateUser
338−
339−-- | The name of the user.
340−uuName :: Lens' (Request UpdateUser s b) (Maybe Text)
341−uuName = upd.uuName'
342−
343−-- | The email of the user. The newly created user will receive an email asking
344−-- to confirm the subscription.
345−uuEmail :: Lens' (Request UpdateUser s b) (Maybe Address)
346−uuEmail = upd.uuEmail'
347−
348−-- | The user's role.
349−uuRole :: Lens' (Request UpdateUser s b) (Maybe Role)
350−uuRole = upd.uuRole'
351−
352−-- | The job title of the user.
353−uuJobTitle :: Lens' (Request UpdateUser s b) (Maybe Text)
354−uuJobTitle = upd.uuJobTitle'
355−
356−-- | The time zone the user is in. If not specified, the time zone of the
357−-- account making the API call will be used.
358−uuTimeZone :: Lens' (Request UpdateUser s b) (Maybe TimeZone)
359−uuTimeZone = upd.uuTimeZone'.mapping _TZ
360−
361−-- | Update an existing user.
362−--
363−-- @PUT \/users\/\:id@
364−--
365−-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/update>
366−updateUser :: UserId -> Request UpdateUser s User
367−updateUser u =
368− mk UpdateUser
369− { _uuName' = Nothing
370− , _uuEmail' = Nothing
371− , _uuRole' = Nothing
372− , _uuJobTitle' = Nothing
373− , _uuTimeZone' = Nothing
374− } & meth .~ PUT
375− & path .~ users % u
376−
377−-- | Remove an existing user.
378−--
379−-- @DELETE \/users\/\:id@
380−--
381−-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/delete>
382−deleteUser :: UserId -> Request Empty s Empty
383−deleteUser u = empty & meth .~ DELETE & path .~ users % u
384−-- FIXME: deal with conflict errors
src/Network/PagerDuty/REST/Users/ContactMethods.hsdeleted−236
@@ -1,236 +0,0 @@
1−{-# LANGUAGE ExtendedDefaultRules #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE TemplateHaskell #-}
4−
5−{-# OPTIONS_GHC -fno-warn-type-defaults #-}
6−
7−-- Module : Network.PagerDuty.REST.Users.ContactMethods
8−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
9−-- License : This Source Code Form is subject to the terms of
10−-- the Mozilla Public License, v. 2.0.
11−-- A copy of the MPL can be found in the LICENSE file or
12−-- you can obtain it at http://mozilla.org/MPL/2.0/.
13−-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
14−-- Stability : experimental
15−-- Portability : non-portable (GHC extensions)
16−
17−-- | Contact methods describe the various channels (phone numbers, SMS numbers
18−-- and email addresses) used to contact a user when an incident is assigned to
19−-- the user.
20−--
21−-- Access and manipulate the contact methods for a user.
22−--
23−-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/contact_methods>
24−module Network.PagerDuty.REST.Users.ContactMethods
25− (
26− -- * List Contacts
27− listContacts
28−
29− -- * Create Contact
30− , CreateContact
31− , createContact
32− , ccType
33− , ccAddress
34− , ccCountryCode
35− , ccLabel
36− , ccSendShortEmail
37−
38− -- * Get Contact
39− , getContact
40−
41− -- * Update Contact
42− , UpdateContact
43− , updateContact
44− , ucAddress
45− , ucCountryCode
46− , ucLabel
47− , ucSendShortEmail
48−
49− -- * Delete Contact
50− , deleteContact
51−
52− -- * Types
53− , ContactType (..)
54−
55− , HasContact (..)
56− , Contact
57− ) where
58−
59−import Control.Lens
60−import Data.Aeson.Lens
61−import Data.Text (Text)
62−import Network.HTTP.Types
63−import Network.PagerDuty.Internal.TH
64−import Network.PagerDuty.Internal.Types
65−
66−default (Path)
67−
68−contacts :: UserId -> Path
69−contacts u = "users" % u % "contact_methods"
70−
71−data ContactType
72− = SMS
73− | Phone
74− | Email
75− deriving (Eq, Show)
76−
77−deriveNullary ''ContactType
78−
79−data Contact = Contact
80− { _cId :: ContactId
81− , _cUserId :: UserId
82− , _cLabel :: Text
83− , _cAddress :: Address
84− , _cType :: !ContactType
85− , _cCountryCode :: Maybe Int
86− , _cSendShortEmail :: Maybe Bool'
87− , _cBlacklisted :: Maybe Bool'
88− } deriving (Eq, Show)
89−
90−deriveJSON ''Contact
91−makeClassy ''Contact
92−
93−-- | List existing contact methods for the specified user.
94−--
95−-- @GET \/users\/\:user_id\/contact_methods@
96−--
97−-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/contact_methods/list>
98−listContacts :: UserId -> Request Empty s [Contact]
99−listContacts u = empty & path .~ contacts u
100−
101−-- | Get details for a contact method.
102−--
103−-- @GET \/users\/\:user_id\/contact_methods\/\:id@
104−--
105−-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/contact_methods/show>
106−getContact :: UserId -> ContactId -> Request Empty s Contact
107−getContact u c = empty & path .~ contacts u % c
108−
109−data CreateContact = CreateContact
110− { _ccType' :: !ContactType
111− , _ccAddress' :: Address
112− , _ccCountryCode' :: Maybe Int
113− , _ccLabel' :: Maybe Text
114− , _ccSendShortEmail' :: Maybe Bool'
115− } deriving (Eq, Show)
116−
117−jsonRequest ''CreateContact
118−
119−-- | The type of the contact method.
120−ccType :: Lens' (Request CreateContact s b) ContactType
121−ccType = upd.ccType'
122−
123−-- | The id of the contact method. For 'SMS' and 'Phone' it is the number, and for
124−-- 'Email' it is the email address.
125−ccAddress :: Lens' (Request CreateContact s b) Address
126−ccAddress = upd.ccAddress'
127−
128−-- | The number code for your country. Not used for 'Email'.
129−--
130−-- /Default:/ 1
131−ccCountryCode :: Lens' (Request CreateContact s b) (Maybe Int)
132−ccCountryCode = upd.ccCountryCode'
133−
134−-- | A human friendly label for the contact method.
135−--
136−-- /Example:/ "Home Phone", "Work Email", etc.
137−--
138−-- /Default:/ The type of the contact method and the address (with country code
139−-- for phone numbers).
140−ccLabel :: Lens' (Request CreateContact s b) (Maybe Text)
141−ccLabel = upd.ccLabel'
142−
143−-- | Send an abbreviated email message instead of the standard email
144−-- output. Useful for email-to-SMS gateways and email based pagers. Only valid for
145−-- 'Email' contact methods.
146−--
147−-- /Default:/ false.
148−ccSendShortEmail :: Lens' (Request CreateContact s b) (Maybe Bool)
149−ccSendShortEmail = upd.ccSendShortEmail'.mapping _B
150−
151−-- | Create a new contact method for a given user. A contact method can be one
152−-- of the following types: SMS, email, and phone. push_notification contact
153−-- methods cannot be created using this API, they are added automatically during
154−-- device registration.
155−--
156−-- @POST \/users\/\:user_id\/contact_methods@
157−--
158−-- /Note:/ The contact info must be unique.
159−--
160−-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/contact_methods/create>
161−createContact :: UserId
162− -> ContactType
163− -> Address
164− -> Request CreateContact s Contact
165−createContact u t a =
166− mk CreateContact
167− { _ccType' = t
168− , _ccAddress' = a
169− , _ccCountryCode' = Nothing
170− , _ccLabel' = Nothing
171− , _ccSendShortEmail' = Nothing
172− } & meth .~ POST
173− & path .~ contacts u
174− & unwrap .~ key "contact_method"
175−
176−data UpdateContact = UpdateContact
177− { _ucAddress' :: Maybe Address
178− , _ucCountryCode' :: Maybe Int
179− , _ucLabel' :: Maybe Text
180− , _ucSendShortEmail' :: Maybe Bool'
181− } deriving (Eq, Show)
182−
183−jsonRequest ''UpdateContact
184−
185−-- | The id of the contact method. For 'SMS' and 'Phone' it is the number, and for
186−-- 'Email' it is the email address.
187−ucAddress :: Lens' (Request UpdateContact s b) (Maybe Address)
188−ucAddress = upd.ucAddress'
189−
190−-- | The number code for your country. Not used for 'Email'.
191−--
192−-- /Default:/ 1
193−ucCountryCode :: Lens' (Request UpdateContact s b) (Maybe Int)
194−ucCountryCode = upd.ucCountryCode'
195−
196−-- | A human friendly label for the contact method.
197−--
198−-- /Example:/ "Home Phone", "Work Email", etc.
199−--
200−-- /Default:/ The type of the contact method and the address (with country code
201−-- for phone numbers).
202−ucLabel :: Lens' (Request UpdateContact s b) (Maybe Text)
203−ucLabel = upd.ucLabel'
204−
205−-- | Send an abbreviated email message instead of the standard email
206−-- output. Useful for email-to-SMS gateways and email based pagers. Only valid for
207−-- 'Email' contact methods.
208−--
209−-- /Default:/ false.
210−ucSendShortEmail :: Lens' (Request UpdateContact s b) (Maybe Bool)
211−ucSendShortEmail = upd.ucSendShortEmail'.mapping _B
212−
213−-- | Update an existing contact method of a given user. Note that you cannot
214−-- change the type of an existing method.
215−--
216−-- @PUT \/users\/\:user_id\/contact_methods\/\:id@
217−--
218−-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/contact_methods/update>
219−updateContact :: UserId -> ContactId -> Request UpdateContact s Contact
220−updateContact u c =
221− mk UpdateContact
222− { _ucAddress' = Nothing
223− , _ucCountryCode' = Nothing
224− , _ucLabel' = Nothing
225− , _ucSendShortEmail' = Nothing
226− } & meth .~ PUT
227− & path .~ contacts u % c
228− & unwrap .~ key "contact_method"
229−
230−-- | Remove a contact method and any corresponding notification rules.
231−--
232−-- @DELETE \/users\/\:user_id\/contact_methods\/\:id@
233−--
234−-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/contact_methods/delete>
235−deleteContact :: UserId -> ContactId -> Request Empty s Empty
236−deleteContact u c = empty & meth .~ DELETE & path .~ contacts u % c
src/Network/PagerDuty/REST/Users/NotificationRules.hsdeleted−164
@@ -1,164 +0,0 @@
1−{-# LANGUAGE ExtendedDefaultRules #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE TemplateHaskell #-}
4−
5−{-# OPTIONS_GHC -fno-warn-type-defaults #-}
6−
7−-- Module : Network.PagerDuty.REST.Users.NotificationRules
8−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
9−-- License : This Source Code Form is subject to the terms of
10−-- the Mozilla Public License, v. 2.0.
11−-- A copy of the MPL can be found in the LICENSE file or
12−-- you can obtain it at http://mozilla.org/MPL/2.0/.
13−-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
14−-- Stability : experimental
15−-- Portability : non-portable (GHC extensions)
16−
17−-- | When a user is assigned an incident, the user's notification rules are
18−-- used to determine which contact method will be used to alert the user and how
19−-- long after the incident to do so.
20−--
21−-- Access and manipulate the notification rules for a user.
22−--
23−-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/notification_rules>
24−module Network.PagerDuty.REST.Users.NotificationRules
25− (
26− -- * List Rules
27− listRules
28−
29− -- * Create Rule
30− , CreateRule
31− , createRule
32− , crStartDelayInMinutes
33− , crContactMethodId
34−
35− -- * Get Rule
36− , getRule
37−
38− -- * Update Rule
39− , UpdateRule
40− , updateRule
41− , urStartDelayInMinutes
42− , urContactMethodId
43−
44− -- * Delete Rule
45− , deleteRule
46−
47− -- * Types
48− , Rule
49− , rId
50− , rStartDelayInMinutes
51− , rContactMethod
52− ) where
53−
54−import Control.Lens
55−import Data.Aeson.Lens
56−import Network.HTTP.Types
57−import Network.PagerDuty.Internal.TH
58−import Network.PagerDuty.Internal.Types
59−import Network.PagerDuty.REST.Users.ContactMethods
60−
61−default (Path)
62−
63−rules :: UserId -> Path
64−rules u = "users" % u % "notification_rules"
65−
66−data Rule = Rule
67− { _rId :: NotificationRuleId
68− , _rStartDelayInMinutes :: !Int
69− , _rContactMethod :: Contact
70− } deriving (Eq, Show)
71−
72−deriveJSON ''Rule
73−makeLenses ''Rule
74−
75−instance HasContact Rule where
76− contact = rContactMethod
77−
78−-- | List existing notification rules for the specified user.
79−--
80−-- @GET \/users\/\:user_id\/notification_rules@
81−--
82−-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/notification_rules/list>
83−listRules :: UserId -> Request Empty s Rule
84−listRules u = empty & path .~ rules u
85−
86−-- | Get details for a notification rule.
87−--
88−-- @GET \/users\/\:user_id\/notification_rules\/\:id@
89−--
90−-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/notification_rules/show>
91−getRule :: UserId -> NotificationRuleId -> Request Empty s Rule
92−getRule u n = empty & path .~ rules u % n
93−
94−data CreateRule = CreateRule
95− { _crStartDelayInMinutes' :: !Int
96− , _crContactMethodId' :: ContactId
97− } deriving (Eq, Show)
98−
99−jsonRequest ''CreateRule
100−
101−-- | Number of minutes it will take for the notification rule to be activated
102−-- (from the time the incident is assigned to the owning user) and an alert be
103−-- fired.
104−crStartDelayInMinutes :: Lens' (Request CreateRule s b) Int
105−crStartDelayInMinutes = upd.crStartDelayInMinutes'
106−
107−-- | The id of the contact method.
108−crContactMethodId :: Lens' (Request CreateRule s b) ContactId
109−crContactMethodId = upd.crContactMethodId'
110−
111−-- | Create a new notification rule for the specified user.
112−--
113−-- @POST \/users\/\:user_id\/notification_rules@
114−--
115−-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/notification_rules/create>
116−createRule :: UserId -> ContactId -> Int -> Request CreateRule s Rule
117−createRule u c n =
118− mk CreateRule
119− { _crStartDelayInMinutes' = n
120− , _crContactMethodId' = c
121− } & meth .~ POST
122− & path .~ rules u
123− & unwrap .~ key "notification_rule"
124−
125−data UpdateRule = UpdateRule
126− { _urStartDelayInMinutes' :: Maybe Int
127− , _urContactMethodId' :: Maybe ContactId
128− } deriving (Eq, Show)
129−
130−jsonRequest ''UpdateRule
131−
132−-- | Number of minutes it will take for the notification rule to be activated
133−-- (from the time the incident is assigned to the owning user) and an alert be
134−-- fired.
135−urStartDelayInMinutes :: Lens' (Request UpdateRule s b) (Maybe Int)
136−urStartDelayInMinutes = upd.urStartDelayInMinutes'
137−
138−-- | The id of the contact method.
139−urContactMethodId :: Lens' (Request UpdateRule s b) (Maybe ContactId)
140−urContactMethodId = upd.urContactMethodId'
141−
142−-- | Update an existing notification rule.
143−--
144−-- @PUT \/users\/\:user_id\/notification_rules\/\:id@
145−--
146−-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/notification_rules/update>
147−updateRule :: UserId -> NotificationRuleId -> Request UpdateRule s Rule
148−updateRule u r =
149− mk UpdateRule
150− { _urStartDelayInMinutes' = Nothing
151− , _urContactMethodId' = Nothing
152− } & meth .~ PUT
153− & path .~ rules u % r
154− & unwrap .~ key "notification_rule"
155−
156−-- | Remove a notification rule.
157−--
158−-- @DELETE \/users\/\:user_id\/notification_rules\/\:id@
159−--
160−-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/notification_rules/delete>
161−deleteRule :: UserId
162− -> NotificationRuleId
163− -> Request Empty s Empty
164−deleteRule u n = empty & meth .~ DELETE & path .~ rules u % n
src/Network/PagerDuty/REST/Webhooks.hs+5−91
@@ -1,9 +1,8 @@
1−{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE TemplateHaskell #-}
2{-# LANGUAGE TemplateHaskell #-}
4
3
5-- Module : Network.PagerDuty.REST.Webhooks
4-- Module : Network.PagerDuty.REST.Webhooks
6−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
5+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
7-- License : This Source Code Form is subject to the terms of
6-- License : This Source Code Form is subject to the terms of
8-- the Mozilla Public License, v. 2.0.
7-- the Mozilla Public License, v. 2.0.
9-- A copy of the MPL can be found in the LICENSE file or
8-- A copy of the MPL can be found in the LICENSE file or
@@ -22,95 +21,10 @@
22-- certain interesting changes to an incident's state will cause other types of
21-- certain interesting changes to an incident's state will cause other types of
23-- incident webhook messages to be sent: Generally, any change to the @status@ or
22-- incident webhook messages to be sent: Generally, any change to the @status@ or
24-- @assigned_to_user@ of an incident will cause an outgoing message to be sent.
23-- @assigned_to_user@ of an incident will cause an outgoing message to be sent.
25−--
26−-- /See:/ <http://developer.pagerduty.com/documentation/rest/webhooks>
27module Network.PagerDuty.REST.Webhooks
24module Network.PagerDuty.REST.Webhooks
28− ( WebhookType (..)
25+ (
29− , Webhook
30− , wId
31− , wType
32− , wCreatedOn
33− ) where
34−
35−import Control.Applicative hiding (empty)
36−import Control.Lens
37−import Data.Aeson
38−import Data.ByteString.Conversion (ToByteString (..),
39− toByteString')
40−import Data.Text (Text)
41−import qualified Data.Text.Encoding as Text
42−import Data.Time
43−import Network.PagerDuty.Internal.TH
44−import Network.PagerDuty.Internal.Types
45−import Network.PagerDuty.REST.Incidents
46−
47−data WebhookType
48− = WTrigger
49− -- ^ Sent when an incident is newly created/triggered.
50− | WAcknowledge
51− -- ^ Sent when an incident has had its status changed from triggered to
52− -- acknowledged.
53− | WUnacknowledge
54− -- ^ Sent when an incident is unacknowledged due to timeout.
55− | WResolve
56− -- ^ Sent when an incident has been resolved.
57− | WAssign
58− -- ^ Sent when an incident has been manually reassigned to another user
59− -- in a different escalation chain.
60− | WEscalate
61− -- ^ Sent when an incident has been escalated to another user in the
62− -- same escalation chain.
63− | WDelegate
64− -- ^ Sent when an incident has been reassigned to another escalation chain.
65− | WOther Text
66− -- ^ /Note:/ As new types of incident actions are supported,
67− -- new incident webhook message types will be added.
68− deriving (Eq, Show)
69−
70−instance ToByteString WebhookType where
71− builder = \case
72− WTrigger -> "incident.trigger"
73− WAcknowledge -> "incident.acknowledge"
74− WUnacknowledge -> "incident.unacknowledge"
75− WResolve -> "incident.resolve"
76− WAssign -> "incident.assign"
77− WEscalate -> "incident.escalate"
78− WDelegate -> "incident.delegate"
79− WOther t -> builder t
80−
81−instance FromJSON WebhookType where
82− parseJSON = withText "status" $ pure . \case
83− "incident.trigger" -> WTrigger
84− "incident.acknowledge" -> WAcknowledge
85− "incident.unacknowledge" -> WUnacknowledge
86− "incident.resolve" -> WResolve
87− "incident.assign" -> WAssign
88− "incident.escalate" -> WEscalate
89− "incident.delegate" -> WDelegate
90− t -> (WOther t)
91
26
92−instance ToJSON WebhookType where
27+ ) where
93− toJSON = String . Text.decodeUtf8 . toByteString'
94−
95−data Webhook = Webhook
96− { _wId :: WebhookId
97− , _wType :: !WebhookType
98− , _wCreatedOn :: !Date
99− , _wData :: Incident
100− } deriving (Eq, Show)
101−
102−deriveJSON ''Webhook
103−
104−instance HasIncident Webhook where
105− incident = lens _wData (\s x -> s { _wData = x })
106−
107−-- | Uniquely identifies this outgoing webhook message; can be used for
108−-- idempotency when processing the messages.
109−makeLens "_wId" ''Webhook
110−
111−-- | The webhook message type.
112−makeLens "_wType" ''Webhook
113
28
114−-- | The date/time when the incident changed state.
29+-- Just create the types + fromJSON instances
115−wCreatedOn :: Lens' Webhook UTCTime
30+decodeWebhook = undefined
116−wCreatedOn = lens _wCreatedOn (\i x -> i { _wCreatedOn = x }) . _D
src/Network/PagerDuty/Internal/Options.hs → src/Network/PagerDuty/TH.hsrenamed+23−4
@@ -1,5 +1,7 @@
1+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
2+
1−-- Module : Network.PagerDuty.Internal.Options
3+-- Module : Network.PagerDuty.TH
2−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
4+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
3-- License : This Source Code Form is subject to the terms of
5-- License : This Source Code Form is subject to the terms of
4-- the Mozilla Public License, v. 2.0.
6-- the Mozilla Public License, v. 2.0.
5-- A copy of the MPL can be found in the LICENSE file or
7-- A copy of the MPL can be found in the LICENSE file or
@@ -8,16 +10,33 @@
8-- Stability : experimental
10-- Stability : experimental
9-- Portability : non-portable (GHC extensions)
11-- Portability : non-portable (GHC extensions)
10
12
11−module Network.PagerDuty.Internal.Options
13+module Network.PagerDuty.TH
14+ (
15+ -- * Lenses
16+ makeLens
17+ -- * JSON
18+ , deriveJSON
19+ , deriveJSONWith
20+ -- ** Options
12− ( dropped
21+ , dropped
13 , hyphenated
22 , hyphenated
14 , underscored
23 , underscored
15 ) where
24 ) where
16
25
26+import Control.Lens
27+import qualified Data.Aeson.TH as Aeson
17import Data.Aeson.Types
28import Data.Aeson.Types
18import Data.Char
29import Data.Char
19import Data.List
30import Data.List
20
31
32+makeLens k = makeLensesWith
33+ $ lensRulesFor [(k, drop 1 k)]
34+ & simpleLenses .~ True
35+
36+deriveJSON = deriveJSONWith underscored
37+
38+deriveJSONWith = Aeson.deriveJSON
39+
21dropped :: Int -> Options -> Options
40dropped :: Int -> Options -> Options
22dropped n o = o
41dropped n o = o
23 { constructorTagModifier = constructorTagModifier o . drop n
42 { constructorTagModifier = constructorTagModifier o . drop n
src/Network/PagerDuty/Types.hs+377−84
@@ -1,5 +1,17 @@
1+{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6+{-# LANGUAGE KindSignatures #-}
7+{-# LANGUAGE OverloadedStrings #-}
8+{-# LANGUAGE RankNTypes #-}
9+{-# LANGUAGE StandaloneDeriving #-}
10+{-# LANGUAGE TemplateHaskell #-}
11+{-# LANGUAGE ViewPatterns #-}
12+
1-- Module : Network.PagerDuty.Types
13-- Module : Network.PagerDuty.Types
2−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
14+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
3-- License : This Source Code Form is subject to the terms of
15-- License : This Source Code Form is subject to the terms of
4-- the Mozilla Public License, v. 2.0.
16-- the Mozilla Public License, v. 2.0.
5-- A copy of the MPL can be found in the LICENSE file or
17-- A copy of the MPL can be found in the LICENSE file or
@@ -8,86 +20,367 @@
8-- Stability : experimental
20-- Stability : experimental
9-- Portability : non-portable (GHC extensions)
21-- Portability : non-portable (GHC extensions)
10
22
11−module Network.PagerDuty.Types
23+module Network.PagerDuty.Types where
12− (
24+ -- (
13− -- * Configuration
14− -- ** Environment
15− Env
16− , envDomain
17− , envAuth
18− , envManager
19− , envLogger
20−
21− -- ** Logging
22− , Logger (..)
23− , debug
24−
25− -- * Types
26− -- ** Requests
25+ -- -- * Requests
27− , Paginate
26+ -- Auth (..)
27+ -- , Cred (..)
28+ -- , Domain (..)
29+
30+ -- , Request (..)
28− , Request
31+ -- , Request'
29−
32+
33+ -- , Paginate (..)
34+
30− -- ** Errors
35+ -- -- * Errors
31− , Error
36+ -- , Code (..)
32− , _Internal
37+ -- , message
33− , _Integration
38+ -- , RestError (..)
34− , _REST
39+ -- , Error (..)
35− -- *** Messages
40+
36− , HasMessage (..)
41+ -- -- * Primitives
37− -- *** Fields
42+ -- , Key (..)
38− , HasErrors (..)
43+ -- , ServiceKey
39− -- *** Integration
44+ -- , IncidentKey
40− , IntegrationError
45+
41− , status
46+ -- , Id (..)
42− -- *** REST
47+ -- , ServiceId
43− , RESTError
48+ -- , RequesterId
44− , Code
49+
45− , code
50+ -- , Empty (..)
46− , description
51+ -- ) where
47−
52+
53+import Control.Applicative
54+import Control.Lens hiding ((.=))
55+import Data.Aeson hiding (Error)
56+import Data.Aeson.Types (Parser)
57+import Data.ByteString (ByteString)
58+import qualified Data.ByteString.Char8 as BS
59+import Data.ByteString.Conversion
60+import Data.Function
61+import qualified Data.HashMap.Strict as Map
62+import Data.Monoid
63+import Data.String
64+import Data.Text (Text)
65+import qualified Data.Time as Time
66+import Data.Time hiding (TimeZone)
67+import GHC.TypeLits
68+import Network.HTTP.Types
69+import Network.HTTP.Types.QueryLike
70+import Network.PagerDuty.TH
71+
72+-- FIXME: Query String parameters vs JSON bodies for GET
73+
74+newtype Date = Date { unDate :: ZonedTime }
75+ deriving (Show)
76+
77+instance Eq Date where
78+ (Date a) == (Date b) =
79+ on (==) zonedTimeToLocalTime a b
80+ || on (==) zonedTimeZone a b
81+
82+instance FromJSON Date where
83+ parseJSON = fmap Date . parseJSON
84+
85+instance ToJSON Date where
86+ toJSON = toJSON . unDate
87+
88+newtype TimeZone = TimeZone { unTZ :: Time.TimeZone }
89+ deriving (Eq, Ord, Show)
90+
91+instance FromJSON TimeZone where
92+ parseJSON = undefined
93+
94+instance ToJSON TimeZone where
95+ toJSON = undefined
96+
97+data Security = Basic | Token -- None
98+ deriving (Eq, Show)
99+
100+data Auth (a :: Security) where
101+ AuthBasic :: ByteString -> ByteString -> Auth Basic
102+ AuthToken :: ByteString -> Auth Token
103+-- AuthNone :: Auth None
104+
105+deriving instance Eq (Auth a)
106+deriving instance Show (Auth a)
107+
108+newtype SubDomain = SubDomain ByteString
109+ deriving (Eq, Show, IsString)
110+
111+domain :: SubDomain -> ByteString
112+domain (SubDomain s)
113+ | base `BS.isSuffixOf` s = s
114+ | otherwise = s <> base
115+ where
116+ base = ".pagerduty.com"
117+
118+newtype Code = Code Integer
119+ deriving (Eq, Show)
120+
121+deriveJSON ''Code
122+
123+description :: Code -> Text
124+description (Code c) =
125+ case c of
126+ 2000 -> "Internal Error"
127+ 2001 -> "Invalid Input Provided"
128+ 2002 -> "Arguments Caused Error"
129+ 2003 -> "Missing Arguments"
130+ 2004 -> "Invalid 'since' or 'until' Parameter Values"
131+ 2005 -> "Invalid Query Date Range"
48− -- ** Authentication
132+ 2006 -> "Authentication Failed"
49− , Security (..)
133+ 2007 -> "Account Not Found"
50− , Auth (..)
134+ 2008 -> "Account Locked"
51−
135+ 2009 -> "Only HTTPS Allowed For This Call"
52− -- ** Keys
136+ 2010 -> "Access Denied"
53− , Key
137+ 2011 -> "The action requires a 'requester_id' to be specified"
54− , mkKey
138+ 2012 -> "Your account is expired and cannot use the API"
55− -- *** Aliases
139+ _ -> "Unrecognised error code"
140+
141+data IntegrationError = IntegrationError
142+ { _ieStatus :: Text
143+ , _ieMessage :: Text
144+ , _ieErrors :: [Text]
145+ } deriving (Eq, Show)
146+
147+deriveJSON ''IntegrationError
148+makeLenses ''IntegrationError
149+
150+data RestError = RestError
151+ { _reCode :: Code
152+ , _reMessage :: Text
153+ , _reErrors :: [Text]
154+ } deriving (Eq, Show)
155+
156+deriveJSON ''RestError
157+makeLenses ''RestError
158+
159+data Error
160+ = Internal String
161+ | Integration IntegrationError
162+ | Rest RestError
163+ deriving (Eq, Show)
164+
165+instance FromJSON Error where
166+ parseJSON o = (Rest <$> parseJSON o)
167+ <|> (Integration <$> parseJSON o)
168+
169+makePrisms ''Error
170+
171+data Pager = Pager
172+ { _pgOffset :: !Int
173+ -- ^ The offset used in the execution of the query.
174+ , _pgLimit :: !Int
175+ -- ^ The limit used in the execution of the query.
176+ , _pgTotal :: !Int
177+ -- ^ The total number of records available.
178+ } deriving (Eq, Show)
179+
180+makeLenses ''Pager
181+
182+instance FromJSON a => FromJSON (a, Maybe Pager) where
183+ parseJSON = withObject "paginated" $ \o -> (,)
184+ <$> parseJSON (Object o)
185+ <*> optional (parse o)
186+ where
187+ parse o = Pager
188+ -- The offset of the first record returned.
189+ -- Default is 0.
190+ <$> o .: "offset" .!= 0
191+ -- The number of records returned.
192+ -- Default (and max limit) is 100 for most APIs.
193+ <*> o .: "limit" .!= 100
194+ <*> o .: "total"
195+
196+instance ToJSON Pager where
197+ toJSON p = object
198+ [ "offset" .= _pgOffset p
199+ , "limit" .= _pgLimit p
200+ ]
201+
202+-- | A path segment.
203+data Path where
204+ Path :: Path
205+ Seg :: ToByteString a => a -> Path
206+
207+instance Monoid Path where
208+ mempty = Path
209+ mappend x Path = x
210+ mappend Path y = y
211+ mappend (Seg x) (Seg y) = Seg (builder x <> "/" <> builder y)
212+
213+instance IsString Path where
214+ fromString = Seg
215+
216+instance ToByteString Path where
217+ builder Path = mempty
218+ builder (Seg x) = builder x
219+
220+(%) :: ToByteString a => Path -> a -> Path
221+a % b = a <> Seg b
222+
223+renderPath :: Path -> ByteString
224+renderPath = toByteString' . mappend v1
225+ where
226+ v1 :: Path
227+ v1 = "/api/v1"
228+
229+data Request a (s :: Security) b where
230+ Request :: ToJSON a
231+ => { _rqPayload :: a
232+ , _rqMethod :: !StdMethod
233+ , _rqPath :: Path
234+ , _rqQuery :: Query
235+ , _rqPager :: Maybe Pager
236+ , _rqUnwrap :: Value -> Parser Value
237+ }
238+ -> Request a s b
239+
240+instance ToJSON (Request a s b) where
241+ -- Manually unwrapped to ensure GADT constraint holds.
242+ toJSON (Request p _ _ _ q _) = Object $
243+ let Object x = toJSON p
244+ in case toJSON q of
245+ (Object y) -> x <> y
246+ _ -> x
247+
248+type Unwrap = Getting (First Value) Value Value
249+
250+-- | Create a defaulted request from the payload type.
251+mk :: ToJSON a => a -> Request a s b
252+mk x = Request x GET mempty mempty Nothing pure
253+
254+empty :: Request Empty s r
255+empty = mk Empty
256+
257+-- | Modify the request state.
258+upd :: ToJSON a => Lens' (Request a s b) a
259+upd = lens _rqPayload (\(Request _ m p q g u) x -> Request x m p q g u)
260+
261+-- | Drop the security constraint.
262+auth :: Request a s b -> Request a t b
263+auth (Request x m p q g u) = Request x m p q g u
264+
265+meth :: Lens' (Request a s b) StdMethod
266+meth = lens _rqMethod (\r x -> r { _rqMethod = x })
267+
268+path :: Lens' (Request a s b) Path
269+path = lens _rqPath (\r x -> r { _rqPath = x })
270+
271+query :: QueryValueLike v
272+ => Lens (Request a s b) (Request a s b) Query [(ByteString, v)]
273+query = lens _rqQuery (\r x -> r { _rqQuery = toQuery x })
274+
275+pager :: Lens' (Request a s b) (Maybe Pager)
276+pager = lens _rqPager (\r x -> r { _rqPager = x })
277+
278+unwrap :: Setter (Request a s b) (Request a s b) (Value -> Parser Value) Unwrap
279+unwrap f r = f (_rqUnwrap r) <&> \k -> r { _rqUnwrap = g k }
280+ where
281+ g k x = maybe (fail "Failed to extract nested keys.") return (x ^? k)
282+
283+-- | Primarily to obtain a constraint for the pagination function, as well as
284+-- the overrideable flexibility.
285+class Paginate a where
286+ next :: Request a s b -> Maybe Pager -> Maybe (Request a s b)
287+ next _ Nothing = Nothing
288+ next rq (Just x)
289+ | x^.pgTotal == 0 = Nothing
290+ | otherwise = Just (rq & pager ?~ (x & pgOffset +~ x^.pgTotal))
291+
292+newtype Key (a :: Symbol) = Key Text
293+ deriving (Eq, Show, IsString)
294+
295+instance ToByteString (Key a) where
296+ builder (Key k) = builder k
297+
298+instance FromJSON (Key a) where
299+ parseJSON = withText "key" (return . Key)
300+
301+instance ToJSON (Key a) where
302+ toJSON (Key k) = toJSON k
303+
304+instance QueryValueLike (Key a) where
305+ toQueryValue = Just . toByteString'
306+
56− , ServiceKey
307+type ServiceKey = Key "service"
57− , IncidentKey
308+type IncidentKey = Key "incident"
58−
309+
59− -- ** Identifiers
310+newtype Id (a :: Symbol) = Id Text
60− , Id
311+ deriving (Eq, Show, IsString)
61− , mkId
312+
62− -- *** Aliases
313+instance ToByteString (Id a) where
314+ builder (Id i) = builder i
315+
316+instance FromJSON (Id a) where
317+ parseJSON = withText "id" (return . Id)
318+
319+instance ToJSON (Id a) where
320+ toJSON (Id i) = toJSON i
321+
322+instance QueryValueLike (Id a) where
323+ toQueryValue = Just . toByteString'
324+
63− , AlertId
325+type AlertId = Id "alert"
64− , ContactId
326+type PolicyId = Id "policy"
327+type RequesterId = Id "requester"
328+type RuleId = Id "rule"
329+type ScheduleId = Id "schedule"
330+type ServiceId = Id "service"
331+type TargetId = Id "target"
332+type UserId = Id "user"
65− , EmailFilterId
333+type EmailFilterId = Id "email-filter"
66− , EscalationPolicyId
67− , EscalationRuleId
68− , IncidentId
69− , LogEntryId
70− , NoteId
71− , NotificationRuleId
72− , OverrideId
73− , RequesterId
74− , ScheduleId
75− , ServiceId
76− , UserId
77− , VendorId
334+type VendorId = Id "vendor"
78− , WebhookId
335+
79− , WindowId
336+data Empty = Empty
80−
337+
81− -- ** SubDomain
338+instance ToJSON Empty where
82− , SubDomain
339+ toJSON = const (object [])
83− , mkSubDomain
340+
84−
341+instance FromJSON Empty where
342+ parseJSON = withObject "empty" f
343+ where
344+ f !o | Map.null o = pure Empty
345+ | otherwise = fail "Unexpected non-empty JSON object."
346+
347+newtype Email = Email Text
348+ deriving (Eq, Show, IsString)
349+
350+deriveJSON ''Email
351+
352+newtype Phone = Phone Text
353+ deriving (Eq, Show, IsString)
354+
355+deriveJSON ''Phone
356+
357+data Address
358+ = AddrEmail Email
359+ | AddrPhone Phone
360+ deriving (Eq, Show)
361+
362+instance FromJSON Address where
363+ parseJSON o =
364+ AddrEmail <$> parseJSON o
365+ <|> AddrPhone <$> parseJSON o
366+
367+instance ToJSON Address where
368+ toJSON (AddrEmail e) = toJSON e
369+ toJSON (AddrPhone p) = toJSON p
370+
85− -- ** Address
371+makePrisms ''Address
86− , Address
372+
87− , mkAddress
373+data User = User
88−
374+ { _userId :: UserId
89− -- ** Miscellaneous
375+ , _userName :: Text
90− , Empty (..)
376+ , _userEmail :: Email
91− ) where
377+ , _userTimeZone :: TimeZone
92−
378+ , _userColor :: Text
93−import Network.PagerDuty.Internal.Types
379+ , _userRole :: Text
380+ , _userAvatarUrl :: Text
381+ , _userUrl :: Text
382+ , _userInvitationSent :: Bool
383+ } deriving (Eq, Show)
384+
385+deriveJSON ''User
386+makeLenses ''User
stack.yamldeleted−7
@@ -1,7 +0,0 @@
1−resolver: lts-19.23
2−
3−packages:
4−- .
5−
6−nix:
7− packages: [zlib]