git.iko.soy/typeable/pagerduty
on a384b2f help sign in
40 files changed+1861−4135
since splitsnapshots
unifiedsplit
.gitignore−1 .travis.yml−30 Makefile+17 README.md−14 pagerduty.cabal+40−57 script/travis-lifecycle-before_install−11 script/travis-lifecycle-install−13 script/travis-lifecycle-script−9 script/travis-timeout−15 src/Control/Monad/Trans/PagerDuty.hs+72−55 src/Network/PagerDuty/API/Integration.hs+77 src/Network/PagerDuty/API/LogEntries.hs+28 src/Network/PagerDuty/API/MaintenanceWindows.hs+232 src/Network/PagerDuty/API/Services.hs+292 src/Network/PagerDuty/IO.hs+66 src/Network/PagerDuty/Integration.hs+151−191 src/Network/PagerDuty/Internal/IO.hs−76 src/Network/PagerDuty/Internal/Types.hs−497 src/Network/PagerDuty/Internal/Options.hs → src/Network/PagerDuty/Options.hs+6−6 src/Network/PagerDuty/Internal/Query.hs → src/Network/PagerDuty/Query.hs+28−30 src/Network/PagerDuty/REST.hs+24−44 src/Network/PagerDuty/REST/Alerts.hs+28−28 src/Network/PagerDuty/REST/EscalationPolicies.hs+131−47 src/Network/PagerDuty/REST/EscalationPolicies/EscalationRules.hs−277 src/Network/PagerDuty/REST/Incidents.hs+18−567 src/Network/PagerDuty/REST/Incidents/Notes.hs−108 src/Network/PagerDuty/REST/LogEntries.hs+23−24 src/Network/PagerDuty/REST/MaintenanceWindows.hs+19−21 src/Network/PagerDuty/REST/Reports.hs+19−20 src/Network/PagerDuty/REST/Schedules.hs+3−617 src/Network/PagerDuty/REST/Schedules/Overrides.hs−188 src/Network/PagerDuty/REST/Services.hs+111−46 src/Network/PagerDuty/REST/Services/EmailFilters.hs−180 src/Network/PagerDuty/REST/Users.hs+38−351 src/Network/PagerDuty/REST/Users/ContactMethods.hs−236 src/Network/PagerDuty/REST/Users/NotificationRules.hs−164 src/Network/PagerDuty/REST/Webhooks.hs+5−91 src/Network/PagerDuty/Internal/TH.hs → src/Network/PagerDuty/TH.hs+27−30 src/Network/PagerDuty/Types.hs+406−84 stack.yaml−7
.gitignore−1
@@ -9,7 +9,6 @@
99cabal.sandbox.config
1010
1111# Dirs
12−.stack-work
1312cabal-dev
1413bin
1514dist
.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+40−57
@@ -1,32 +1,20 @@
11name: pagerduty
2−version: 0.0.8
3−synopsis: Client library for PagerDuty Integration and REST APIs.
2+version: 0.1.0
3+synopsis: Pager Duty API Client
44homepage: http://github.com/brendanhay/pagerduty
55license: OtherLicense
66license-file: LICENSE
7−author: Brendan Hay
8−maintainer: Brendan Hay <brendan.g.hay@gmail.com>
9−copyright: Copyright (c) 2013-2015 Brendan Hay, 2014 Kim Altintop
10−category: Network, PagerDuty, Monitoring
7+author: Brendan Hay, Kim Altintop
8+maintainer: Brendan Hay <brendan.g.hay@gmail.com>, Kim Altintop <kim.altintop@gmail.com>
9+copyright: Copyright (c) 2013-2014 Brendan Hay, 2014 Kim Altintop
10+category: Network, Monitoring
1111build-type: Simple
1212cabal-version: >= 1.10
1313
1414description:
15− PagerDuty is an alerting system for IT professionals. PagerDuty connects
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>
15+ Simple API client that wraps the PagerDuty REST APIs documented here:
2516 .
26− /Warning:/ This is an experimental preview release which is still under
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>.
17+ * Integration API - <http://developer.pagerduty.com/documentation/integration/events>
3018
3119extra-source-files:
3220 README.md
@@ -47,51 +35,46 @@ library
4735 , Network.PagerDuty.REST
4836 , Network.PagerDuty.REST.Alerts
4937 , Network.PagerDuty.REST.EscalationPolicies
50− , Network.PagerDuty.REST.EscalationPolicies.EscalationRules
51− , Network.PagerDuty.REST.Incidents
52− , Network.PagerDuty.REST.Incidents.Notes
38+ -- , Network.PagerDuty.REST.Incidents
5339 , Network.PagerDuty.REST.LogEntries
5440 , Network.PagerDuty.REST.MaintenanceWindows
5541 , Network.PagerDuty.REST.Reports
56− , Network.PagerDuty.REST.Schedules
57− , Network.PagerDuty.REST.Schedules.Overrides
58− , Network.PagerDuty.REST.Services
59− , Network.PagerDuty.REST.Services.EmailFilters
60− , Network.PagerDuty.REST.Users
61− , Network.PagerDuty.REST.Users.ContactMethods
62− , Network.PagerDuty.REST.Users.NotificationRules
63− , Network.PagerDuty.REST.Webhooks
42+ -- , Network.PagerDuty.REST.Schedules
43+ , Network.PagerDuty.REST.Services
44+ -- , Network.PagerDuty.REST.Users
45+ -- , Network.PagerDuty.REST.Webhooks
6446
6547 other-modules:
66− Network.PagerDuty.Internal.IO
67− , Network.PagerDuty.Internal.Options
68− , Network.PagerDuty.Internal.Query
69− , Network.PagerDuty.Internal.TH
70− , Network.PagerDuty.Internal.Types
48+ Network.PagerDuty.IO
49+ , Network.PagerDuty.Options
50+ , Network.PagerDuty.Query
51+ , Network.PagerDuty.TH
7152 , Network.PagerDuty.Types
7253
7354 build-depends:
74− aeson >= 2.0
75− , base >= 4.7 && < 5
76− , bifunctors >= 4.1
77− , bytestring >= 0.9
55+ aeson > 0.7 && <= 8.0
56+ , base >= 4.5 && < 5.0
57+-- , base64-bytestring >= 1.0 && < 1.1
58+ , bifunctors
59+
60+ , bytestring >= 0.9 && < 1.0
7861 , bytestring-conversion >= 0.2.1
79− , conduit > 1.1
80− , data-default-class >= 0.0.1
62+ , conduit >= 0.5.5
63+ , data-default >= 0.5
8164 , exceptions >= 0.6
82− , generics-sop >= 0.5.0.0
83− , http-client >= 0.5 && < 1
84− , http-types >= 0.8
85− , lens >= 4.4
86− , lens-aeson >= 1
87− , mmorph >= 1
88− , monad-control >= 1
89− , mtl >= 2.1.3.1
90− , template-haskell >= 2.2
91− , text >= 1.1
92− , time >= 1.2
93− , time-locale-compat >= 0.1.0.1
94− , transformers >= 0.2
95− , transformers-compat >= 0.3
96− , transformers-base >= 0.4.2
65+ , http-client >= 0.3.6 && < 0.5
66+ , http-types >= 0.8 && < 1.0
67+ , lens >= 4.0 && < 5.0
68+ , lens-aeson >= 1.0
69+ , mmorph >= 1.0
70+ , mtl >= 2.2.1 && < 3.0
71+ , old-locale
72+ , text >= 1.1 && < 2.0
73+ , time == 1.4.*
74+ , transformers >= 0.4.1 && < 0.5
9775 , unordered-containers >= 0.2.3
76+
77+ , generics-sop
78+ , monad-control
79+ , template-haskell
80+ , transformers-base
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 @@
22{-# LANGUAGE FlexibleContexts #-}
33{-# LANGUAGE FlexibleInstances #-}
44{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+{-# LANGUAGE KindSignatures #-}
56{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE RecordWildCards #-}
8+{-# LANGUAGE TemplateHaskell #-}
69{-# LANGUAGE TypeFamilies #-}
710{-# LANGUAGE UndecidableInstances #-}
811
912-- 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>
1114-- License : This Source Code Form is subject to the terms of
1215-- the Mozilla Public License, v. 2.0.
1316-- A copy of the MPL can be found in the LICENSE file or
@@ -19,50 +22,57 @@
1922module Control.Monad.Trans.PagerDuty
2023 (
2124 -- * Transformer
22− PagerDuty
23− , PagerDutyT
25+ PD
26+ , PDT
2427
25− -- * Running
26− , runPagerDutyT
28+ -- * Run
29+ , runPDT
2730
28− -- * Integration events
31+ -- * Environment
32+ , Env
33+ , envDomain
34+ , envAuth
35+ , envManager
36+-- , envLogging
37+
38+ -- * Integration API
2939 , submit
30− , submitCatch
3140
32− -- * REST requests
41+ -- * REST API
3342 , send
34− , sendCatch
3543 , paginate
36− , paginateCatch
37−
38− -- ** Lifting errors
39− , hoistError
40−
41− , module Network.PagerDuty.Types
4244 ) where
4345
4446import Control.Applicative
45−import Control.Monad
47+import Control.Lens
4648import Control.Monad.Base
4749import Control.Monad.Catch
48−import Control.Monad.Except (MonadError (..))
50+import Control.Monad.Except
4951import Control.Monad.Morph
5052import Control.Monad.Reader
5153import Control.Monad.Trans.Control
52−import Control.Monad.Trans.Except
5354import Data.Aeson
5455import Data.Conduit
55−import Network.PagerDuty.Integration (Event, Response)
56−import qualified Network.PagerDuty.Integration as Int
57−import Network.PagerDuty.Internal.Types
58−import qualified Network.PagerDuty.REST as REST
56+import Network.HTTP.Client (Manager)
57+import Network.PagerDuty.Integration (Event, Response)
58+import qualified Network.PagerDuty.Integration as Int
59+import qualified Network.PagerDuty.REST as REST
5960import Network.PagerDuty.Types
6061
61−-- | A convenient alias for 'PagerDutyT' 'IO'.
62−type PagerDuty s = PagerDutyT s IO
62+data Env (s :: Security) = Env
63+ { _envDomain :: SubDomain
64+ , _envAuth :: Auth s
65+ , _envManager :: Manager
66+-- , _envLogging ::
67+ }
68+
69+makeLenses ''Env
70+
71+-- | A convenient alias for 'PDT' 'IO'.
72+type PD s = PDT s IO
6373
64−newtype PagerDutyT s m a = PagerDutyT
65− { unPagerDutyT :: ReaderT (Env s) (ExceptT Error m) a
74+newtype PDT s m a = PDT
75+ { unPDT :: ReaderT (Env s) (ExceptT Error m) a
6676 } deriving
6777 ( Functor
6878 , Applicative
@@ -74,48 +84,50 @@ newtype PagerDutyT s m a = PagerDutyT
7484 , MonadError Error
7585 )
7686
77−instance MonadTrans (PagerDutyT s) where
78− lift = PagerDutyT . lift . lift
87+instance MonadTrans (PDT s) where
88+ lift = PDT . lift . lift
7989 {-# INLINE lift #-}
8090
81−instance MonadBase b m => MonadBase b (PagerDutyT s m) where
91+instance MonadBase b m => MonadBase b (PDT s m) where
8292 liftBase = liftBaseDefault
8393 {-# INLINE liftBase #-}
8494
85−instance MonadTransControl (PagerDutyT s) where
86− type StT (PagerDutyT s) a = StT (ExceptT Error) (StT (ReaderT (Env s)) a)
95+instance MonadTransControl (PDT s) where
96+ newtype StT (PDT s) a = StTAWS
97+ { unStTAWS :: StT (ExceptT Error) (StT (ReaderT (Env s)) a)
98+ }
8799
88− liftWith f = PagerDutyT $
100+ liftWith f = PDT $
89101 liftWith $ \g ->
90− liftWith $ \h ->
91− f (h . g . unPagerDutyT)
102+ liftWith $ \h ->
103+ f (liftM StTAWS . h . g . unPDT)
92104 {-# INLINE liftWith #-}
93105
94− restoreT = PagerDutyT . restoreT . restoreT
106+ restoreT = PDT . restoreT . restoreT . liftM unStTAWS
95107 {-# INLINE restoreT #-}
96108
97−instance MonadBaseControl b m => MonadBaseControl b (PagerDutyT s m) where
98− type StM (PagerDutyT s m) a = ComposeSt (PagerDutyT s) m a
109+instance MonadBaseControl b m => MonadBaseControl b (PDT s m) where
110+ newtype StM (PDT s m) a = StMPDT { unStMPDT :: ComposeSt (PDT s) m a }
99111
100− liftBaseWith = defaultLiftBaseWith
112+ liftBaseWith = defaultLiftBaseWith StMPDT
101113 {-# INLINE liftBaseWith #-}
102114
103− restoreM = defaultRestoreM
115+ restoreM = defaultRestoreM unStMPDT
104116 {-# INLINE restoreM #-}
105117
106−instance MFunctor (PagerDutyT s) where
107− hoist nat m = PagerDutyT (ReaderT (ExceptT . nat . runPagerDutyT m))
118+instance MFunctor (PDT s) where
119+ hoist nat m = PDT (ReaderT (ExceptT . nat . runPDT m))
108120 {-# INLINE hoist #-}
109121
110−instance MMonad (PagerDutyT s) where
111− embed f m = ask >>= f . runPagerDutyT m >>= either throwError return
122+instance MMonad (PDT s) where
123+ embed f m = ask >>= f . runPDT m >>= either throwError return
112124 {-# INLINE embed #-}
113125
114−runPagerDutyT :: PagerDutyT s m a -> Env s -> m (Either Error a)
115−runPagerDutyT (PagerDutyT k) = runExceptT . runReaderT k
126+runPDT :: PDT s m a -> Env s -> m (Either Error a)
127+runPDT (PDT k) = runExceptT . runReaderT k
116128
117−hoistError :: (MonadError Error m) => Either Error a -> m a
118−hoistError = either throwError return
129+hoistEither :: (MonadError Error m) => Either Error a -> m a
130+hoistEither = either throwError return
119131
120132scoped :: MonadReader (Env s) m => (Env s -> m a) -> m a
121133scoped f = ask >>= f
@@ -123,17 +135,20 @@ scoped f = ask >>= f
123135submit :: ( MonadIO m
124136 , MonadReader (Env s) m
125137 , MonadError Error m
138+ , Event a
126139 )
127− => Event
140+ => a
128141 -> m Response
129−submit = submitCatch >=> hoistError
142+submit = submitCatch >=> hoistEither
130143
131144submitCatch :: ( MonadIO m
132145 , MonadReader (Env s) m
146+ , Event a
133147 )
134− => Event
148+ => a
135149 -> 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
137152
138153send :: ( MonadIO m
139154 , MonadReader (Env s) m
@@ -142,7 +157,7 @@ send :: ( MonadIO m
142157 )
143158 => Request a s b
144159 -> m b
145−send = sendCatch >=> hoistError
160+send = sendCatch >=> hoistEither
146161
147162sendCatch :: ( MonadIO m
148163 , MonadReader (Env s) m
@@ -150,7 +165,8 @@ sendCatch :: ( MonadIO m
150165 )
151166 => Request a s b
152167 -> m (Either Error b)
153−sendCatch x = scoped (`REST.sendWith` x)
168+sendCatch x = scoped $ \Env{..} ->
169+ REST.send _envAuth _envDomain _envManager x
154170
155171paginate :: ( MonadIO m
156172 , MonadReader (Env s) m
@@ -160,7 +176,7 @@ paginate :: ( MonadIO m
160176 )
161177 => Request a s b
162178 -> Source m b
163−paginate x = paginateCatch x $= awaitForever (hoistError >=> yield)
179+paginate x = paginateCatch x $= awaitForever (hoistEither >=> yield)
164180
165181paginateCatch :: ( MonadIO m
166182 , MonadReader (Env s) m
@@ -169,4 +185,5 @@ paginateCatch :: ( MonadIO m
169185 )
170186 => Request a s b
171187 -> 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 #-}
2−{-# LANGUAGE FunctionalDependencies #-}
3−{-# LANGUAGE LambdaCase #-}
4−{-# LANGUAGE MultiParamTypeClasses #-}
5−{-# LANGUAGE OverloadedStrings #-}
6−{-# LANGUAGE TemplateHaskell #-}
1+{-# LANGUAGE GADTs #-}
2+{-# LANGUAGE DefaultSignatures #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE TemplateHaskell #-}
75
86-- Module : Network.PagerDuty.Integration
9−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
7+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
108-- License : This Source Code Form is subject to the terms of
119-- the Mozilla Public License, v. 2.0.
1210-- A copy of the MPL can be found in the LICENSE file or
@@ -35,60 +33,55 @@
3533-- The same event-based API can also be used to integrate a PagerDuty
3634-- service with ticketing systems and various other software tools.
3735--
38−-- /See:/ <http://developer.pagerduty.com/documentation/integration/events>
36+-- See: <http://developer.pagerduty.com/documentation/integration/events>
3937module Network.PagerDuty.Integration
4038 (
41− -- * Sending events
39+ -- * Events
4240 submit
43− , submitWith
4441
4542 -- ** Trigger
4643 , Trigger
4744 , trigger
48− , client
49− , clientUrl
45+ , tDescription
46+ , tIncidentKey
47+ , tClient
48+ , tClientUrl
49+ , tDetails
5050
5151 -- ** Acknowledge
5252 , Acknowledge
5353 , acknowledge
54+ , aDescription
55+ , aDetails
5456
5557 -- ** Resolve
5658 , Resolve
5759 , resolve
58−
59− -- * Fields
60− , HasServiceKey (..)
61− , HasIncidentKey (..)
62− , HasDescription (..)
63− , HasDetails (..)
60+ , rDescription
61+ , rDetails
6462
6563 -- * Types
66− , Event (..)
67− , _Trigger
68− , _Acknowledge
69− , _Resolve
64+ , Event
65+ , AnyEvent (..)
7066
7167 , Response
7268 , rsStatus
7369 , rsMessage
7470 , rsIncidentKey
75−
76− , Generic
77−
78− , module Network.PagerDuty.Types
7971 ) where
8072
8173import Control.Lens
8274import Control.Monad.IO.Class
8375import Data.Aeson
84−import qualified Data.Aeson.KeyMap as Map
85−import Data.Text (Text)
86−import Network.HTTP.Client (Manager)
87−import qualified Network.HTTP.Client as Client
88−import Network.PagerDuty.Internal.IO
89−import Network.PagerDuty.Internal.TH
90−import Network.PagerDuty.Internal.Types
91−import Network.PagerDuty.Types hiding (description, message)
76+import Data.Default
77+import qualified Data.HashMap.Strict as Map
78+import Data.Monoid
79+import Data.Text (Text)
80+import Network.HTTP.Client (Manager)
81+import qualified Network.HTTP.Client as Client
82+import Network.PagerDuty.IO
83+import Network.PagerDuty.TH
84+import Network.PagerDuty.Types
9285
9386data Response = Response
9487 { _rsStatus :: Text
@@ -107,161 +100,128 @@ makeLens "_rsMessage" ''Response
107100-- | The key of the incident that will be affected by the request.
108101makeLens "_rsIncidentKey" ''Response
109102
110−class HasServiceKey s a | s -> a where
111− -- | The GUID of one of your "Generic API" services. This is the "service key"
112− -- listed on a Generic API's service detail page.
113− serviceKey :: Lens' s a
114−
115−class HasIncidentKey s a | s -> a where
116− -- | Identifies the incident to which this trigger event should be applied.
117− -- If there's no open (i.e. unresolved) incident with this key, a new one
118− -- will be created. If there's already an open incident with a matching key,
119− -- this event will be appended to that incident's log. The event key provides
120− -- an easy way to "de-dup" problem reports. If this field isn't provided,
121− -- PagerDuty will automatically open a new incident with a unique key.
122− incidentKey :: Lens' s a
123−
124−class HasDescription s a | s -> a where
125− -- | A short description of the problem that led to this trigger.
126− -- This field (or a truncated version) will be used when generating phone
127− -- calls, SMS messages and alert emails. It will also appear on the incidents
128− -- tables in the PagerDuty UI. The maximum length is 1024 characters.
129− description :: Lens' s a
130−
131−class HasDetails s a | s -> a where
132− -- | An arbitrary JSON object containing any data you'd like included
133− -- in the incident log.
134− details :: Lens' s a
135−
136−data Trigger = Trigger'
137− { _tServiceKey' :: ServiceKey
138− , _tIncidentKey' :: IncidentKey
139− , _tDescription' :: Text
140− , _tDetails' :: Maybe Object
141− , _tClient' :: Maybe Text
142− , _tClientUrl' :: Maybe Text
143− } deriving (Eq, Show)
103+class Event a where
104+ eventType :: a -> Text
105+ eventPayload :: a -> Object
144106
145−deriveRecord ''Trigger
107+ default eventPayload :: ToJSON a => a -> Object
108+ eventPayload x = let Object o = toJSON x in o
146109
147−instance HasServiceKey Trigger ServiceKey where serviceKey = tServiceKey'
148−instance HasIncidentKey Trigger IncidentKey where incidentKey = tIncidentKey'
149−instance HasDescription Trigger Text where description = tDescription'
150−instance HasDetails Trigger (Maybe Object) where details = tDetails'
110+data AnyEvent where
111+ Event :: Event a => a -> AnyEvent
151112
152−-- | The name of the monitoring client that is triggering this event.
153−client :: Lens' Trigger (Maybe Text)
154−client = tClient'
113+instance Event AnyEvent where
114+ eventType (Event x) = eventType x
115+ eventPayload (Event x) = eventPayload x
155116
156−-- | The URL of the monitoring client that is triggering this event.
157−clientUrl :: Lens' Trigger (Maybe Text)
158−clientUrl = tClientUrl'
159−
160−data Generic = Generic'
161− { _gServiceKey' :: ServiceKey
162− , _gIncidentKey' :: IncidentKey
163− , _gDescription' :: Maybe Text
164− , _gDetails' :: Maybe Object
117+data Generic = Generic
118+ { _gServiceKey :: ServiceKey
119+ , _gDescription :: Maybe Text
120+ , _gIncidentKey :: IncidentKey
121+ , _gDetails :: Object
165122 } deriving (Eq, Show)
166123
167−deriveRecord ''Generic
168−
169−instance HasServiceKey Generic ServiceKey where serviceKey = gServiceKey'
170−instance HasIncidentKey Generic IncidentKey where incidentKey = gIncidentKey'
171−instance HasDescription Generic (Maybe Text) where description = gDescription'
172−instance HasDetails Generic (Maybe Object) where details = gDetails'
173−
174−type Resolve = Generic
175−type Acknowledge = Generic
176−
177−data Event
178− = Trigger Trigger -- ^ /See:/ 'trigger'
179− | Acknowledge Generic -- ^ /See:/ 'acknowledge'
180− | Resolve Generic -- ^ /See:/ 'resolve'
181− deriving (Eq, Show)
182−
183−makePrisms ''Event
184−
185−instance HasServiceKey Event ServiceKey where
186− serviceKey = lens f g
187− where
188− f (Trigger s) = _tServiceKey' s
189− f (Acknowledge s) = _gServiceKey' s
190− f (Resolve s) = _gServiceKey' s
191−
192− g (Trigger s) x = Trigger $ s { _tServiceKey' = x }
193− g (Acknowledge s) x = Acknowledge $ s { _gServiceKey' = x }
194− g (Resolve s) x = Resolve $ s { _gServiceKey' = x }
195−
196−instance HasIncidentKey Event IncidentKey where
197− incidentKey = lens f g
198− where
199− f (Trigger s) = _tIncidentKey' s
200− f (Acknowledge s) = _gIncidentKey' s
201− f (Resolve s) = _gIncidentKey' s
202−
203− g (Trigger s) x = Trigger $ s { _tIncidentKey' = x }
204− g (Acknowledge s) x = Acknowledge $ s { _gIncidentKey' = x }
205− g (Resolve s) x = Resolve $ s { _gIncidentKey' = x }
206−
207−instance HasDetails Event (Maybe Object) where
208− details = lens f g
209− where
210− f (Trigger s) = _tDetails' s
211− f (Acknowledge s) = _gDetails' s
212− f (Resolve s) = _gDetails' s
213−
214− g (Trigger s) x = Trigger $ s { _tDetails' = x }
215− g (Acknowledge s) x = Acknowledge $ s { _gDetails' = x }
216− g (Resolve s) x = Resolve $ s { _gDetails' = x }
217−
218−instance ToJSON Event where
219− toJSON = \case
220− Trigger x -> event "trigger" x
221− Acknowledge x -> event "acknowledge" x
222− Resolve x -> event "resolve" x
223− where
224− event k x =
225− case toJSON x of
226− Object o -> Object (Map.insert "event_type" (String k) o)
227− v -> v
124+deriveJSON ''Generic
125+
126+makeLens "_gDescription" ''Generic
127+makeLens "_gDetails" ''Generic
128+
129+data Trigger = Trigger
130+ { _tServiceKey :: ServiceKey
131+ , _tDescription :: Text
132+ , _tIncidentKey :: Maybe IncidentKey
133+ , _tClient :: Maybe Text
134+ , _tClientUrl :: Maybe Text
135+ , _tDetails :: Object
136+ } deriving (Eq, Show)
137+
138+deriveJSON ''Trigger
139+
140+instance Event Trigger where
141+ eventType = const "trigger"
228142
229143-- | Your monitoring tools should send PagerDuty a trigger event to report a new
230144-- or ongoing problem. When PagerDuty receives a trigger event, it will either open
231145-- a new incident, or add a new trigger log entry to an existing incident,
232146-- depending on the provided incident_key.
233−trigger :: ServiceKey -- ^ 'serviceKey'
234− -> IncidentKey -- ^ 'incidentKey'
235− -> Text -- ^ 'description'
236− -> Event
237−trigger k i d =
238− Trigger Trigger'
239− { _tServiceKey' = k
240− , _tDescription' = d
241− , _tIncidentKey' = i
242− , _tClient' = Nothing
243− , _tClientUrl' = Nothing
244− , _tDetails' = Nothing
147+trigger :: ServiceKey
148+ -> Text -- ^ 'tDescription'
149+ -> Trigger
150+trigger k d =
151+ Trigger
152+ { _tServiceKey = k
153+ , _tDescription = d
154+ , _tIncidentKey = Nothing
155+ , _tClient = Nothing
156+ , _tClientUrl = Nothing
157+ , _tDetails = mempty
245158 }
246159
160+-- | A short description of the problem that led to this trigger.
161+-- This field (or a truncated version) will be used when generating phone
162+-- calls, SMS messages and alert emails. It will also appear on the incidents
163+-- tables in the PagerDuty UI. The maximum length is 1024 characters.
164+makeLens "_tDescription" ''Trigger
165+
166+-- | Identifies the incident to which this trigger event should be applied.
167+-- If there's no open (i.e. unresolved) incident with this key, a new one
168+-- will be created. If there's already an open incident with a matching key,
169+-- this event will be appended to that incident's log. The event key provides
170+-- an easy way to "de-dup" problem reports. If this field isn't provided,
171+-- PagerDuty will automatically open a new incident with a unique key.
172+makeLens "_tIncidentKey" ''Trigger
173+
174+-- | The name of the monitoring client that is triggering this event.
175+makeLens "_tClient" ''Trigger
176+
177+-- | The URL of the monitoring client that is triggering this event.
178+makeLens "_tClientUrl" ''Trigger
179+
180+-- | An arbitrary JSON object containing any data you'd like included
181+-- in the incident log.
182+makeLens "_tDetails" ''Trigger
183+
184+newtype Acknowledge = Acknowledge Generic
185+
186+deriveJSON ''Acknowledge
187+makePrisms ''Acknowledge
188+
189+instance Event Acknowledge where
190+ eventType = const "acknowledge"
191+
247192-- | Acknowledge events cause the referenced incident to enter the acknowledged
248193-- state.
249194--
250195-- While an incident is acknowledged, it won't generate any additional
251196-- notifications, even if it receives new trigger events. Your monitoring tools
252−-- should send PagerDuty an acknowledge event when they know someone is
253−-- presently working on the problem.
254−acknowledge :: ServiceKey -- ^ 'serviceKey'
255− -> IncidentKey -- ^ 'incidentKey'
256− -> Event
197+-- should send PagerDuty an acknowledge event when they know someone is presently
198+-- working on the problem.
199+acknowledge :: ServiceKey -> IncidentKey -> Acknowledge
257200acknowledge k i =
258− Acknowledge Generic'
259− { _gServiceKey' = k
260− , _gIncidentKey' = i
261− , _gDescription' = Nothing
262− , _gDetails' = Nothing
201+ Acknowledge Generic
202+ { _gServiceKey = k
203+ , _gDescription = Nothing
204+ , _gIncidentKey = i
205+ , _gDetails = mempty
263206 }
264207
208+-- | Text that will appear in the incident's log associated with this event.
209+aDescription :: Lens' Acknowledge (Maybe Text)
210+aDescription = _Acknowledge.gDescription
211+
212+-- | An arbitrary JSON object containing any data you'd like included
213+-- in the incident log.
214+aDetails :: Lens' Acknowledge Object
215+aDetails = _Acknowledge.gDetails
216+
217+newtype Resolve = Resolve Generic
218+
219+deriveJSON ''Resolve
220+makePrisms ''Resolve
221+
222+instance Event Resolve where
223+ eventType = const "acknowledge"
224+
265225-- | Resolve events cause the referenced incident to enter the resolved state.
266226--
267227-- Once an incident is resolved, it won't generate any additional
@@ -269,30 +229,30 @@ acknowledge k i =
269229-- incident won't re-open the incident. Instead, a new incident will be
270230-- created. Your monitoring tools should send PagerDuty a resolve event when the
271231-- problem that caused the initial trigger event has been fixed.
272−resolve :: ServiceKey -- ^ 'serviceKey'
273− -> IncidentKey -- ^ 'incidentKey'
274− -> Event
232+resolve :: ServiceKey -> IncidentKey -> Resolve
275233resolve k i =
276− Resolve Generic'
277− { _gServiceKey' = k
278− , _gIncidentKey' = i
279− , _gDescription' = Nothing
280− , _gDetails' = Nothing
234+ Resolve Generic
235+ { _gServiceKey = k
236+ , _gDescription = Nothing
237+ , _gIncidentKey = i
238+ , _gDetails = mempty
281239 }
282240
241+-- | Text that will appear in the incident's log associated with this event.
242+rDescription :: Lens' Resolve (Maybe Text)
243+rDescription = _Resolve.gDescription
244+
245+-- | An arbitrary JSON object containing any data youd like included
246+-- in the incident log.
247+rDetails :: Lens' Resolve Object
248+rDetails = _Resolve.gDetails
249+
283250-- | Send an event to the integration API.
284−submit :: MonadIO m => Manager -> Event -> m (Either Error Response)
285−submit m = submitWith m None
286−
287−-- | /See:/ 'submit'
288−submitWith :: MonadIO m
289− => Manager
290− -> Logger
291− -> Event
292− -> m (Either Error Response)
293−submitWith m l e = request m l e $
294− Client.defaultRequest
295− { Client.host = "events.pagerduty.com"
296− , Client.path = "/generic/2010-04-15/create_event.json"
297− , Client.method = "POST"
298− }
251+submit :: (MonadIO m, Event a) => Manager -> a -> m (Either Error Response)
252+submit m x = request m payload $ def
253+ { Client.host = "events.pagerduty.com"
254+ , Client.path = "/generic/2010-04-15/create_event.json"
255+ }
256+ where
257+ payload = Object $
258+ Map.insert "event_type" (String (eventType x)) (eventPayload x)
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/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/Internal/Options.hs → src/Network/PagerDuty/Options.hsrenamed+6−6
@@ -1,5 +1,5 @@
1−-- Module : Network.PagerDuty.Internal.Options
2−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
1+-- Module : Network.PagerDuty.Options
2+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
33-- License : This Source Code Form is subject to the terms of
44-- the Mozilla Public License, v. 2.0.
55-- A copy of the MPL can be found in the LICENSE file or
@@ -8,15 +8,15 @@
88-- Stability : experimental
99-- Portability : non-portable (GHC extensions)
1010
11−module Network.PagerDuty.Internal.Options
11+module Network.PagerDuty.Options
1212 ( dropped
1313 , hyphenated
1414 , underscored
1515 ) where
1616
17−import Data.Aeson.Types
18−import Data.Char
19−import Data.List
17+import Data.Aeson.Types
18+import Data.Char
19+import Data.List
2020
2121dropped :: Int -> Options -> Options
2222dropped n o = o
src/Network/PagerDuty/Internal/Query.hs → src/Network/PagerDuty/Query.hsrenamed+28−30
@@ -1,13 +1,12 @@
11{-# LANGUAGE ConstraintKinds #-}
22{-# LANGUAGE DefaultSignatures #-}
3−{-# LANGUAGE FlexibleContexts #-}
43{-# LANGUAGE GADTs #-}
54{-# LANGUAGE OverloadedStrings #-}
65{-# LANGUAGE ScopedTypeVariables #-}
76{-# LANGUAGE TupleSections #-}
87
9−-- Module : Network.PagerDuty.Internal.Query
10−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
8+-- Module : Network.PagerDuty.Query
9+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
1110-- License : This Source Code Form is subject to the terms of
1211-- the Mozilla Public License, v. 2.0.
1312-- A copy of the MPL can be found in the LICENSE file or
@@ -16,58 +15,57 @@
1615-- Stability : experimental
1716-- Portability : non-portable (GHC extensions)
1817
19−module Network.PagerDuty.Internal.Query
20− ( QueryValues (..)
18+module Network.PagerDuty.Query
19+ ( ToQuery (..)
2120 , gquery
2221 , gqueryWith
2322 ) where
2423
2524import Data.Aeson.Types
2625import Data.Bifunctor
27−import Data.ByteString (ByteString)
28−import qualified Data.ByteString.Char8 as BS
26+import Data.ByteString (ByteString)
27+import qualified Data.ByteString.Char8 as BS
2928import 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
29+import Data.Function (on)
30+import Data.List (groupBy)
31+import Data.Monoid ((<>))
32+import Data.Text (Text)
33+import qualified Data.Text.Encoding as Text
3534import Generics.SOP
3635import Network.HTTP.Types
37−import Network.PagerDuty.Internal.Options
36+import Network.PagerDuty.Options
3837
39−class QueryValues a where
38+class ToQuery a where
4039 queryValues :: a -> [ByteString]
4140
4241 default queryValues :: ToByteString a => a -> [ByteString]
4342 queryValues = (:[]) . toByteString'
4443
45−instance QueryValues a => QueryValues (Maybe a) where
44+instance ToQuery a => ToQuery (Maybe a) where
4645 queryValues (Just x) = queryValues x
4746 queryValues Nothing = []
4847
49−instance QueryValues Text where
48+instance ToQuery Text where
5049 queryValues x = [Text.encodeUtf8 x]
5150
52−gquery :: forall a. (Generic a, HasDatatypeInfo a, All2 QueryValues (Code a))
51+gquery :: forall a. (Generic a, HasDatatypeInfo a, All2 ToQuery (Code a))
5352 => a
5453 -> Query
5554gquery = gqueryWith underscored
5655
57−gqueryWith :: forall a. (Generic a, HasDatatypeInfo a, All2 QueryValues (Code a))
56+gqueryWith :: forall a. (Generic a, HasDatatypeInfo a, All2 ToQuery (Code a))
5857 => Options
5958 -> a
6059 -> Query
6160gqueryWith o a = case datatypeInfo (Proxy :: Proxy a) of
62− ADT _ _ cs _ -> go cs (from a)
63− Newtype _ _ c -> go (c :* Nil) (from a)
61+ ADT _ _ cs -> go cs (from a)
62+ Newtype _ _ c -> go (c :* Nil) (from a)
6463 where
65− go :: (All2 QueryValues xss, SListI xss)
64+ go :: (All2 ToQuery xss, SingI xss)
6665 => NP ConstructorInfo xss
6766 -> SOP I xss
6867 -> Query
69− go cs (SOP sop) =
70− group . hcollapse $ hcliftA2' p (gctor o) cs sop
68+ go cs (SOP sop) = group . unI . hcollapse $ hcliftA2' p (gctor o) cs sop
7169
7270 group :: [(ByteString, ByteString)] -> Query
7371 group = concatMap f . groupBy ((==) `on` fst)
@@ -76,7 +74,7 @@ gqueryWith o a = case datatypeInfo (Proxy :: Proxy a) of
7674 f [(k, v)] = [(k, Just v)]
7775 f xs@((k,_):_) = let n = k <> "[]" in map (bimap (const n) Just) xs
7876
79−gctor :: All QueryValues xs
77+gctor :: All ToQuery xs
8078 => Options
8179 -> ConstructorInfo xs
8280 -> NP I xs
@@ -84,7 +82,7 @@ gctor :: All QueryValues xs
8482gctor o (Constructor n) args =
8583 K . concat . hcollapse $ hcliftA p (K . map (k,) . queryValues . unI) args
8684 where
87− k = BS.pack (constructorTagModifier o n)
85+ k = BS.pack $ (constructorTagModifier o) n
8886
8987gctor o (Record _ ns) args =
9088 K . concat . hcollapse $ hcliftA2 p (gfield o) ns args
@@ -92,12 +90,12 @@ gctor o (Record _ ns) args =
9290gctor o (Infix n _ _) (x :* y :* Nil) =
9391 K $ map (k,) (queryValues (unI x) ++ queryValues (unI y))
9492 where
95− k = BS.pack (constructorTagModifier o n)
93+ k = BS.pack $ (constructorTagModifier o) n
9694
97−gctor _ Infix{} _ =
95+gctor _ (Infix _ _ _) _ =
9896 error "Network.PagerDuty.Generics.inaccessible"
9997
100−gfield :: QueryValues a
98+gfield :: ToQuery a
10199 => Options
102100 -> FieldInfo a
103101 -> I a
@@ -105,7 +103,7 @@ gfield :: QueryValues a
105103gfield o (FieldInfo f) (I a) =
106104 K $ map (k,) (queryValues a)
107105 where
108− k = BS.pack (fieldLabelModifier o f)
106+ k = BS.pack $ (fieldLabelModifier o) f
109107
110−p :: Proxy QueryValues
108+p :: Proxy ToQuery
111109p = Proxy
src/Network/PagerDuty/REST.hs+24−44
@@ -2,7 +2,7 @@
22{-# LANGUAGE OverloadedStrings #-}
33
44-- 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>
66-- License : This Source Code Form is subject to the terms of
77-- the Mozilla Public License, v. 2.0.
88-- A copy of the MPL can be found in the LICENSE file or
@@ -15,11 +15,7 @@ module Network.PagerDuty.REST
1515 (
1616 -- * Sending requests
1717 send
18− , sendWith
1918 , paginate
20− , paginateWith
21−
22− , module Network.PagerDuty.Types
2319 ) where
2420
2521import Control.Applicative
@@ -27,69 +23,53 @@ import Control.Lens
2723import Control.Monad
2824import Control.Monad.IO.Class
2925import Control.Monad.Trans
30−import Data.Aeson (FromJSON)
26+import Data.Aeson (FromJSON)
3127import Data.Conduit
28+import Data.Default
3229import Data.Monoid
33−import Network.HTTP.Client (Manager)
34−import qualified Network.HTTP.Client as Client
30+import Network.HTTP.Client (Manager)
31+import qualified Network.HTTP.Client as Client
3532import Network.HTTP.Types
36−import Network.PagerDuty.Internal.IO
37−import Network.PagerDuty.Internal.Types
33+import Network.PagerDuty.IO
3834import Network.PagerDuty.Types
3935
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'
4536send :: (MonadIO m, FromJSON b)
46− => SubDomain
47− -> Auth s
37+ => Auth s
38+ -> SubDomain
4839 -> Manager
4940 -> Request a s b
5041 -> 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
5843
59−-- | /See:/ 'paginateWith'
6044paginate :: (MonadIO m, Paginate a, FromJSON b)
61− => SubDomain
62− -> Auth s
45+ => Auth s
46+ -> SubDomain
6347 -> Manager
6448 -> Request a s b
6549 -> Source m (Either Error b)
66−paginate d a m = paginateWith (prod d a m)
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
50+paginate a d m = go
7351 where
7452 go rq = do
75− rs <- lift (http e rq)
76− yield (_pgItem <$> rs)
53+ rs <- lift (http a d m rq)
54+ yield (fst <$> rs)
7755 either (const (return ()))
78− (maybe (return ()) go . next rq . _pgPager)
56+ (maybe (return ()) go . next rq . snd)
7957 rs
8058
8159http :: (MonadIO m, FromJSON b)
82− => Env s
60+ => Auth s
61+ -> SubDomain
62+ -> Manager
8363 -> Request a s b
84− -> m (Either Error (Page b))
85−http e rq = request (e ^. envManager) (e ^. envLogger) rq $ raw
86− { Client.host = domain (e ^. envDomain)
64+ -> m (Either Error (b, Maybe Pager))
65+http a (SubDomain h) m rq = request m rq $ raw
66+ { Client.host = h
8767 , Client.path = renderPath (rq ^. path)
8868 , Client.queryString = renderQuery False (rq ^. query)
8969 }
9070 where
91− raw = case e ^. envAuth of
92− AuthBasic u p -> Client.applyBasicAuth u p Client.defaultRequest
93− AuthToken t -> Client.defaultRequest
71+ raw = case a of
72+ AuthBasic u p -> Client.applyBasicAuth u p def
73+ AuthToken t -> def
9474 { Client.requestHeaders = [("Authorization", "Token token=" <> t)]
9575 }
src/Network/PagerDuty/REST/Alerts.hs+28−28
@@ -4,7 +4,7 @@
44{-# LANGUAGE TypeFamilies #-}
55
66-- Module : Network.PagerDuty.REST.Alerts
7−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
7+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
88-- License : This Source Code Form is subject to the terms of
99-- the Mozilla Public License, v. 2.0.
1010-- A copy of the MPL can be found in the LICENSE file or
@@ -21,7 +21,7 @@
2121-- This API allows you to access read-only data regarding what alerts have been
2222-- sent to your users.
2323--
24−-- /See:/ <http://developer.pagerduty.com/documentation/rest/alerts>
24+-- See: <http://developer.pagerduty.com/documentation/rest/alerts>
2525module Network.PagerDuty.REST.Alerts
2626 (
2727 -- * List Alerts
@@ -43,12 +43,12 @@ module Network.PagerDuty.REST.Alerts
4343 , alertAddress
4444 ) where
4545
46−import Control.Lens hiding (Empty)
47−import Data.Aeson.Lens
48−import Data.Time
49−import Network.PagerDuty.Internal.TH
50−import Network.PagerDuty.Internal.Types
51−import Network.PagerDuty.REST.Users (User)
46+import Control.Lens
47+import Data.Aeson.Lens
48+import Data.Time
49+import Network.PagerDuty.REST.Users (User)
50+import Network.PagerDuty.TH
51+import Network.PagerDuty.Types
5252
5353alerts :: Path
5454alerts = "alerts"
@@ -81,7 +81,25 @@ data ListAlerts = ListAlerts
8181
8282instance Paginate ListAlerts
8383
84−queryRequest ''ListAlerts
84+deriveQuery ''ListAlerts
85+
86+-- | List existing alerts for a given time range, optionally filtered by type
87+-- (SMS, Email, Phone, or Push).
88+--
89+-- @GET \/alerts@
90+--
91+-- See: <http://developer.pagerduty.com/documentation/rest/alerts/list>
92+listAlerts :: Date -- ^ 'laSince'
93+ -> Date -- ^ 'laUntil'
94+ -> Request ListAlerts s [Alert]
95+listAlerts s u =
96+ mk ListAlerts
97+ { _laSince' = s
98+ , _laUntil' = u
99+ , _laFilter' = Nothing
100+ , _laTimeZone' = Nothing
101+ } & path .~ alerts
102+ & unwrap .~ key "alerts"
85103
86104-- | The start of the date range over which you want to search.
87105laSince :: Lens' (Request ListAlerts s b) UTCTime
@@ -100,24 +118,6 @@ laFilter = upd.laFilter'
100118
101119-- | Time zone in which dates in the result will be rendered.
102120--
103−-- /Default:/ account time zone.
121+-- Defaults to account time zone.
104122laTimeZone :: Lens' (Request ListAlerts s b) (Maybe TimeZone)
105123laTimeZone = upd.laTimeZone'.mapping _TZ
106−
107−-- | List existing alerts for a given time range, optionally filtered by type
108−-- (SMS, Email, Phone, or Push).
109−--
110−-- @GET \/alerts@
111−--
112−-- /See:/ <http://developer.pagerduty.com/documentation/rest/alerts/list>
113−listAlerts :: Date -- ^ 'laSince'
114− -> Date -- ^ 'laUntil'
115− -> Request ListAlerts s [Alert]
116−listAlerts s u =
117− mk ListAlerts
118− { _laSince' = s
119− , _laUntil' = u
120− , _laFilter' = Nothing
121− , _laTimeZone' = Nothing
122− } & path .~ alerts
123− & unwrap .~ key "alerts"
src/Network/PagerDuty/REST/EscalationPolicies.hs+131−47
@@ -1,13 +1,10 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE ExtendedDefaultRules #-}
3−{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE TemplateHaskell #-}
5−{-# LANGUAGE TypeFamilies #-}
6−
7−{-# OPTIONS_GHC -fno-warn-type-defaults #-}
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE TemplateHaskell #-}
4+{-# LANGUAGE TypeFamilies #-}
85
96-- Module : Network.PagerDuty.REST.EscalationPolicies
10−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
7+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
118-- License : This Source Code Form is subject to the terms of
129-- the Mozilla Public License, v. 2.0.
1310-- A copy of the MPL can be found in the LICENSE file or
@@ -18,7 +15,7 @@
1815
1916-- | This API lets you access and manipulate escalation policies and rules.
2017--
21−-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies>
18+-- See: <http://developer.pagerduty.com/documentation/rest/escalation_policies>
2219module Network.PagerDuty.REST.EscalationPolicies
2320 (
2421 -- * List Policies
@@ -26,9 +23,6 @@ module Network.PagerDuty.REST.EscalationPolicies
2623 , listPolicies
2724 , lpQuery
2825
29− -- * List On Call Policies
30− , listOnCallPolicies
31−
3226 -- * Create Policy
3327 , CreatePolicy
3428 , createPolicy
@@ -52,6 +46,26 @@ module Network.PagerDuty.REST.EscalationPolicies
5246 , deletePolicy
5347
5448 -- * Types
49+ , Target (..)
50+ , _TSchedule
51+ , _TUser
52+
53+ , ScheduleTarget
54+ , stId
55+ , stName
56+
57+ , UserTarget
58+ , utId
59+ , utName
60+ , utEmail
61+ , utTimeZone
62+ , utColor
63+
64+ , Rule
65+ , rId
66+ , rEscalationDelayInMinutes
67+ , rTargets
68+
5569 , Policy
5670 , pId
5771 , pName
@@ -60,23 +74,104 @@ module Network.PagerDuty.REST.EscalationPolicies
6074 , pServices
6175 ) where
6276
63−import Control.Lens hiding (Empty)
77+import Control.Applicative ((<$>))
78+import Control.Lens
79+import Data.Aeson
6480import Data.Aeson.Lens
65−import Data.Text (Text)
81+import qualified Data.HashMap.Strict as Map
82+import Data.Text (Text)
83+import qualified Data.Text as Text
84+import Data.Time
6685import Network.HTTP.Types
67−import Network.PagerDuty.Internal.TH
68−import Network.PagerDuty.Internal.Types
69−import Network.PagerDuty.REST.Services (Service)
70−
71−import Network.PagerDuty.REST.EscalationPolicies.EscalationRules
72−
73−default (Path)
86+import Network.PagerDuty.REST.Services (Service)
87+import Network.PagerDuty.TH
88+import Network.PagerDuty.Types
7489
7590policies :: Path
7691policies = "escalation_policies"
7792
93+data ScheduleTarget = ScheduleTarget
94+ { _stId :: ScheduleId
95+ , _stName :: Text
96+ } deriving (Eq, Show)
97+
98+deriveJSON ''ScheduleTarget
99+
100+-- | The id of the target.
101+makeLens "_stId" ''ScheduleTarget
102+
103+-- | The name of the target.
104+makeLens "_stName" ''ScheduleTarget
105+
106+data UserTarget = UserTarget
107+ { _utId :: UserId
108+ , _utName :: Text
109+ , _utEmail :: Address
110+ , _utTimeZone :: TZ
111+ , _utColor :: Text
112+ } deriving (Eq, Show)
113+
114+deriveJSON ''UserTarget
115+
116+-- | The id of the user.
117+makeLens "_utId" ''UserTarget
118+
119+-- | The name of the user.
120+makeLens "_utName" ''UserTarget
121+
122+-- | The user's email address.
123+makeLens "_utEmail" ''UserTarget
124+
125+-- | The user's personal time zone.
126+utTimeZone :: Lens' UserTarget TimeZone
127+utTimeZone = lens _utTimeZone (\t x -> t { _utTimeZone = x }) . _TZ
128+
129+-- | The color used to represent the user in schedules.
130+makeLens "_utColor" ''UserTarget
131+
132+data Target
133+ = TSchedule ScheduleTarget
134+ | TUser UserTarget
135+ deriving (Eq, Show)
136+
137+makePrisms ''Target
138+
139+-- type: A representation of the type of the target.
140+-- Will be either schedule or user.
141+instance FromJSON Target where
142+ parseJSON = withObject "target" $ \o -> do
143+ t <- o .: "type"
144+ case t of
145+ "schedule" -> TSchedule <$> parseJSON (Object o)
146+ "user" -> TUser <$> parseJSON (Object o)
147+ _ -> fail $ "Unrecognised target type: " ++ Text.unpack t
148+
149+instance ToJSON Target where
150+ toJSON t = Object (Map.insert "type" (String k) o)
151+ where
152+ (k, Object o) = case t of
153+ TSchedule s -> ("schedule", toJSON s)
154+ TUser u -> ("user", toJSON u)
155+
156+data Rule = Rule
157+ { _rId :: RuleId
158+ , _rEscalationDelayInMinutes :: !Int
159+ , _rTargets :: [Target]
160+ } deriving (Eq, Show)
161+
162+deriveJSON ''Rule
163+
164+-- | The ID of the escalation rule.
165+makeLens "_rId" ''Rule
166+
167+-- | The amount of time before an incident escalates away from this rule.
168+makeLens "_rEscalationDelayInMinutes" ''Rule
169+
170+-- | A list of targets which an incident will be assigned to upon reaching this rule.
171+makeLens "_rTargets" ''Rule
172+
78173data Policy = Policy
79− { _pId :: EscalationPolicyId
174+ { _pId :: PolicyId
80175 , _pName :: Text
81176 , _pNumLoops :: !Int
82177 , _pRules :: [Rule]
@@ -107,7 +202,7 @@ newtype ListPolicies = ListPolicies
107202
108203instance Paginate ListPolicies
109204
110−queryRequest ''ListPolicies
205+deriveQuery ''ListPolicies
111206
112207-- | Filters the result, showing only the escalation policies
113208-- whose names match the query.
@@ -118,7 +213,7 @@ lpQuery = upd.lpQuery'
118213--
119214-- @GET \/escalation_policies@
120215--
121−-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/list>
216+-- See: <http://developer.pagerduty.com/documentation/rest/escalation_policies/list>
122217listPolicies :: Request ListPolicies s [Policy]
123218listPolicies =
124219 mk ListPolicies
@@ -126,17 +221,6 @@ listPolicies =
126221 } & path .~ policies
127222 & unwrap .~ key "escalation_policies"
128223
129−-- | List all the existing escalation policies with currently on-call users.
130−--
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]
138−listOnCallPolicies = listPolicies & path .~ policies % "on_call"
139−
140224data CreatePolicy = CreatePolicy
141225 { _cpName' :: Text
142226 , _cpRepeatEnabled' :: Bool'
@@ -144,7 +228,7 @@ data CreatePolicy = CreatePolicy
144228 , _cpEscalationRules' :: [Rule] -- ^ Should be List1
145229 } deriving (Eq, Show)
146230
147−jsonRequest ''CreatePolicy
231+deriveBody ''CreatePolicy
148232
149233-- | The name of the escalation policy.
150234cpName :: Lens' (Request CreatePolicy s b) Text
@@ -153,7 +237,7 @@ cpName = upd.cpName'
153237-- | Whether or not to allow this policy to repeat its escalation
154238-- rules after the last rule is finished.
155239--
156−-- /Default:/ false.
240+-- Defaults to false.
157241cpRepeatEnabled :: Lens' (Request CreatePolicy s b) Bool
158242cpRepeatEnabled = upd.cpRepeatEnabled'._B
159243
@@ -169,15 +253,15 @@ cpEscalationRules = upd.cpEscalationRules'
169253--
170254-- @POST \/escalation_policies@
171255--
172−-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/create>
173−createPolicy :: EscalationPolicyId
256+-- See: <http://developer.pagerduty.com/documentation/rest/escalation_policies/create>
257+createPolicy :: PolicyId
174258 -> Text -- ^ 'creName'
175259 -> [Rule] -- ^ 'creEscalationRules'
176260 -> Request CreatePolicy s Policy
177261createPolicy i n rs =
178262 mk CreatePolicy
179263 { _cpName' = n
180− , _cpRepeatEnabled' = F
264+ , _cpRepeatEnabled' = B False
181265 , _cpNumLoops' = Nothing
182266 , _cpEscalationRules' = rs
183267 } & meth .~ PUT
@@ -188,8 +272,8 @@ createPolicy i n rs =
188272--
189273-- @GET \/escalation_policies\/\:id@
190274--
191−-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/show>
192−getPolicy :: EscalationPolicyId -> Request Empty s Policy
275+-- See: <http://developer.pagerduty.com/documentation/rest/escalation_policies/show>
276+getPolicy :: PolicyId -> Request Empty s Policy
193277getPolicy i = empty & path .~ policies % i & unwrap .~ key "escalation_policy"
194278
195279data UpdatePolicy = UpdatePolicy
@@ -199,7 +283,7 @@ data UpdatePolicy = UpdatePolicy
199283 , _upEscalationRules' :: [Rule]
200284 } deriving (Eq, Show)
201285
202−jsonRequest ''UpdatePolicy
286+deriveBody ''UpdatePolicy
203287
204288-- | The name of the escalation policy.
205289upName :: Lens' (Request UpdatePolicy s b) (Maybe Text)
@@ -222,8 +306,8 @@ upEscalationRules = upd.upEscalationRules'
222306--
223307-- @PUT \/escalation_policies\/\:id@
224308--
225−-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/update>
226−updatePolicy :: EscalationPolicyId -> Request UpdatePolicy s Policy
309+-- See: <http://developer.pagerduty.com/documentation/rest/escalation_policies/update>
310+updatePolicy :: PolicyId -> Request UpdatePolicy s Policy
227311updatePolicy i =
228312 mk UpdatePolicy
229313 { _upName' = Nothing
@@ -239,6 +323,6 @@ updatePolicy i =
239323--
240324-- @DELETE \/escalation_policies\/\:id@
241325--
242−-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/delete>
243−deletePolicy :: EscalationPolicyId -> Request Empty s Empty
326+-- See: <http://developer.pagerduty.com/documentation/rest/escalation_policies/delete>
327+deletePolicy :: PolicyId -> Request Empty s Empty
244328deletePolicy 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 #-}
7−{-# LANGUAGE TemplateHaskell #-}
8−{-# LANGUAGE TypeFamilies #-}
9−
10−{-# OPTIONS_GHC -fno-warn-type-defaults #-}
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE TemplateHaskell #-}
113
124-- 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>
146-- License : This Source Code Form is subject to the terms of
157-- the Mozilla Public License, v. 2.0.
168-- A copy of the MPL can be found in the LICENSE file or
@@ -41,352 +33,18 @@
4133--
4234-- Incidents and Incident Counts from the last 30 days are returned by
4335-- 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.
4537--
4638-- Note: that to create an incident you need to trigger it through the
4739-- "Network.PagerDuty.Integration" API.
48−--
49−-- /See:/ <http://developer.pagerduty.com/documentation/rest/incidents>
5040module Network.PagerDuty.REST.Incidents
5141 (
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
12342
124− , Assignee
125− , aAt
126− , aObject
127−
128− , HasIncident (..)
129− , Incident
13043 ) where
13144
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−
15045incidents :: Path
15146incidents = "incidents"
15247
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−
39048-- | The PagerDuty incidents query API can be used to query current and
39149-- historical PagerDuty incidents over a date range, letting you build custom
39250-- dashboards or incident reports. The API allows for searching for incidents
@@ -395,95 +53,16 @@ lsSortBy = upd.lsSortBy'
39553--
39654-- @GET \/incidents@
39755--
398−-- /See:/ <http://developer.pagerduty.com/documentation/rest/incidents/list>
399−listIncidents :: Request ListIncidents s [Incident]
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
56+-- See: <http://developer.pagerduty.com/documentation/rest/incidents/list>
57+listIncidents = undefined
41258
41359-- | Get detailed information about an incident. Accepts either an incident id,
41460-- or an incident number.
41561--
41662-- @GET \/incidents\/\:id@
41763--
418−-- /See:/ <http://developer.pagerduty.com/documentation/rest/incidents/show>
419−getIncident :: IncidentId -> Request Empty s Incident
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"
64+-- See: <http://developer.pagerduty.com/documentation/rest/incidents/show>
65+getIncident = undefined
48766
48867-- | Use this query if you are simply looking for the count of incidents that
48968-- match a given query. This should be used if you don't need access to the
@@ -491,161 +70,33 @@ instance FromJSON Count where
49170--
49271-- @GET \/incidents\/count@
49372--
494−-- /See:/ <http://developer.pagerduty.com/documentation/rest/incidents/count>
495−countIncidents :: Request CountIncidents s Count
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'
73+-- See: <http://developer.pagerduty.com/documentation/rest/incidents/count>
74+countIncidents = undefined
55975
56076-- | Acknowledge, resolve, escalate or reassign one or more incidents.
56177--
56278-- @PUT \/incidents@
56379--
564−-- /See:/ <http://developer.pagerduty.com/documentation/rest/incidents/update>
565−updateIncidents :: RequesterId -> Request UpdateIncidents s [UpdatedIncidents]
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
80+-- See: <http://developer.pagerduty.com/documentation/rest/incidents/update>
81+updateIncidents = undefined
57682
57783-- | Resolve an incident.
57884--
57985-- @PUT \/incidents\/\:id\/resolve@
58086--
581−-- /See:/ <http://developer.pagerduty.com/documentation/rest/incidents/resolve>
582−resolveIncident :: IncidentId
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"
87+-- See: <http://developer.pagerduty.com/documentation/rest/incidents/resolve>
88+resolveIncident = undefined
59289
59390-- | Acknowledge an incident.
59491--
59592-- @PUT \/incidents\/\:id\/acknowledge@
59693--
597−-- /See:/ <http://developer.pagerduty.com/documentation/rest/incidents/acknowledge>
598−acknowledgeIncident :: IncidentId
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
94+-- See: <http://developer.pagerduty.com/documentation/rest/incidents/acknowledge>
95+acknowledgeIncident = undefined
63096
63197-- | Reassign an incident.
63298--
63399-- @PUT \/incidents\/\:id\/reassign@
634100--
635−-- /See:/ <http://developer.pagerduty.com/documentation/rest/incidents/reassign>
636−reassignIncident :: IncidentId
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"
101+-- See: <http://developer.pagerduty.com/documentation/rest/incidents/reassign>
102+reassignIncident = undefined
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+23−24
@@ -5,7 +5,7 @@
55{-# LANGUAGE TypeFamilies #-}
66
77-- Module : Network.PagerDuty.REST.LogEntries
8−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
8+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
99-- License : This Source Code Form is subject to the terms of
1010-- the Mozilla Public License, v. 2.0.
1111-- A copy of the MPL can be found in the LICENSE file or
@@ -20,11 +20,9 @@
2020-- incidents. Log entry data includes details about the event(s) that triggered
2121-- the incident, who was notified and when, how they were notified, and who
2222-- acknowledged or resolved it, amongst a few other things.
23−--
24−-- /See:/ <http://developer.pagerduty.com/documentation/rest/log_entries>
2523module Network.PagerDuty.REST.LogEntries
2624 (
27− -- * List Logs
25+ -- * List Log Entries
2826 ListLogs
2927 , listLogs
3028 , listUserLogs
@@ -34,7 +32,7 @@ module Network.PagerDuty.REST.LogEntries
3432 , llUntil
3533 , llIsOverview
3634
37− -- * Get Log
35+ -- * Get Log Entry
3836 , GetLog
3937 , getLog
4038 , glTimeZone
@@ -111,18 +109,19 @@ module Network.PagerDuty.REST.LogEntries
111109 , nAddress
112110 ) where
113111
114−import Control.Lens hiding (Empty)
112+import Control.Applicative
113+import Control.Lens
115114import Data.Aeson
116115import 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
116+import Data.Default
117+import qualified Data.HashMap.Strict as Map
118+import Data.Text (Text)
119+import qualified Data.Text as Text
121120import Data.Time
122121import Network.HTTP.Types
123−import Network.PagerDuty.Internal.TH
124−import Network.PagerDuty.Internal.Types
125−import Network.PagerDuty.REST.Users (User)
122+import Network.PagerDuty.REST.Users (User)
123+import Network.PagerDuty.TH
124+import Network.PagerDuty.Types
126125
127126logs :: Path
128127logs = "log_entries"
@@ -325,7 +324,7 @@ data LogEntry = LogEntry'
325324 } deriving (Eq, Show)
326325
327326instance FromJSON LogEntry where
328− parseJSON = withObject "log_entry" $ \o ->
327+ parseJSON = withObject "log_entry" $ \o -> do
329328 LogEntry' <$> o .: "id"
330329 <*> o .: "type"
331330 <*> o .: "created_at"
@@ -433,11 +432,11 @@ data ListLogs = ListLogs
433432
434433instance Paginate ListLogs
435434
436−queryRequest ''ListLogs
435+deriveQuery ''ListLogs
437436
438437-- | Time zone in which dates in the result will be rendered.
439438--
440−-- /Default:/ UTC.
439+-- Defaults to UTC.
441440llTimeZone :: Lens' (Request ListLogs s b) TimeZone
442441llTimeZone = upd.llTimeZone'._TZ
443442
@@ -451,7 +450,7 @@ llUntil = upd.llUntil'.mapping _D
451450
452451-- | If true, will only return log entries of type trigger, acknowlldge, or resolve.
453452--
454−-- /Default:/ false.
453+-- Defaults to false.
455454llIsOverview :: Lens' (Request ListLogs s b) Bool
456455llIsOverview = upd.llIsOverview'._B
457456
@@ -459,14 +458,14 @@ llIsOverview = upd.llIsOverview'._B
459458--
460459-- @GET \/log_entries@
461460--
462−-- /See:/ <http://developer.pagerduty.com/documentation/rest/log_entries/list>
461+-- See: <http://developer.pagerduty.com/documentation/rest/log_entries/list>
463462listLogs :: Request ListLogs s [LogEntry]
464463listLogs =
465464 mk ListLogs
466465 { _llTimeZone' = def
467466 , _llSince' = Nothing
468467 , _llUntil' = Nothing
469− , _llIsOverview' = F
468+ , _llIsOverview' = B False
470469 } & path .~ logs
471470 & query .~ includes
472471 & unwrap .~ key "log_entries"
@@ -475,7 +474,7 @@ listLogs =
475474--
476475-- @GET \/users\/\:user_id\/log_entries@
477476--
478−-- /See:/ <http://developer.pagerduty.com/documentation/rest/log_entries/user_log_entries>
477+-- See: <http://developer.pagerduty.com/documentation/rest/log_entries/user_log_entries>
479478listUserLogs :: UserId -> Request ListLogs s [LogEntry]
480479listUserLogs u = listLogs & path .~ "users" % u % logs
481480
@@ -483,7 +482,7 @@ listUserLogs u = listLogs & path .~ "users" % u % logs
483482--
484483-- @GET \/incidents\/\:incident_id\/log_entries@
485484--
486−-- /See:/ <http://developer.pagerduty.com/documentation/rest/log_entries/incident_log_entries>
485+-- See: <http://developer.pagerduty.com/documentation/rest/log_entries/incident_log_entries>
487486listIncidentLogs :: IncidentKey -> Request ListLogs s [LogEntry]
488487listIncidentLogs i = listLogs & path .~ "incidents" % i % logs
489488
@@ -491,11 +490,11 @@ newtype GetLog = GetLog
491490 { _glTimeZone' :: TZ
492491 } deriving (Eq, Show)
493492
494−queryRequest ''GetLog
493+deriveQuery ''GetLog
495494
496495-- | Time zone in which dates in the result will be rendered.
497496--
498−-- /Default:/ UTC.
497+-- Defaults to UTC.
499498glTimeZone :: Lens' (Request GetLog s b) TimeZone
500499glTimeZone = upd.glTimeZone'._TZ
501500
@@ -504,7 +503,7 @@ glTimeZone = upd.glTimeZone'._TZ
504503--
505504-- @GET \/log_entries\/\:id@
506505--
507−-- /See:/ <http://developer.pagerduty.com/documentation/rest/log_entries/show>
506+-- See: <http://developer.pagerduty.com/documentation/rest/log_entries/show>
508507getLog :: LogEntryId -> Request GetLog s LogEntry
509508getLog l =
510509 mk GetLog
src/Network/PagerDuty/REST/MaintenanceWindows.hs+19−21
@@ -4,7 +4,7 @@
44{-# LANGUAGE TypeFamilies #-}
55
66-- Module : Network.PagerDuty.REST.MaintenanceWindows
7−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
7+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
88-- License : This Source Code Form is subject to the terms of
99-- the Mozilla Public License, v. 2.0.
1010-- A copy of the MPL can be found in the LICENSE file or
@@ -15,8 +15,6 @@
1515
1616-- | Maintenance windows allow you to schedule service maintenance periods,
1717-- during which no incidents will be created.
18−--
19−-- /See:/ <http://developer.pagerduty.com/documentation/rest/maintenance_windows>
2018module Network.PagerDuty.REST.MaintenanceWindows
2119 (
2220 -- * List Windows
@@ -74,14 +72,14 @@ module Network.PagerDuty.REST.MaintenanceWindows
7472 , mwServices
7573 ) where
7674
77−import Control.Lens hiding (Empty)
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)
75+import Control.Lens
76+import Data.Monoid
77+import Data.Text (Text)
78+import Data.Time
79+import Network.HTTP.Types
80+import Network.PagerDuty.REST.Users (User)
81+import Network.PagerDuty.TH
82+import Network.PagerDuty.Types
8583
8684windows :: Path
8785windows = "maintenance_windows"
@@ -111,14 +109,14 @@ data ListWindows = ListWindows
111109 , _lwFilter' :: Maybe Text
112110 }
113111
114−queryRequest ''ListWindows
112+deriveQuery ''ListWindows
115113
116114-- | Filters the results, showing only the maintenance windows whose
117115-- descriptions contain the query.
118116lwQuery :: Lens' (Request ListWindows s b) (Maybe Text)
119117lwQuery = upd.lwQuery'
120118
121−-- | An list of service IDs, specifying services whose maintenance
119+-- | An array of service IDs, specifying services whose maintenance
122120-- windows shall be returned.
123121lwServiceIds :: Lens' (Request ListWindows s b) [ServiceId]
124122lwServiceIds = upd.lwServiceIds'._L
@@ -150,7 +148,7 @@ deriveRecord ''ListWindowsResponse
150148--
151149-- @GET \/maintenance_windows@
152150--
153−-- /See:/ <http://developer.pagerduty.com/documentation/rest/maintenance_windows/list>
151+-- See: <http://developer.pagerduty.com/documentation/rest/maintenance_windows/list>
154152listWindows :: Request ListWindows s ListWindowsResponse
155153listWindows =
156154 mk ListWindows
@@ -173,7 +171,7 @@ data CreateWindow = CreateWindow
173171 , _cwMaintenanceWindow' :: CreateWindow'
174172 } deriving (Eq, Show)
175173
176−jsonRequest ''CreateWindow
174+deriveBody ''CreateWindow
177175
178176-- | This maintenance window's start time. This is when the services will stop
179177-- creating incidents. If this date is in the past, it will be updated to be the
@@ -200,7 +198,7 @@ cwServiceIds = upd.cwMaintenanceWindow'.cwServiceIds'
200198--
201199-- @POST \/maintenance_windows@
202200--
203−-- /See:/ <http://developer.pagerduty.com/documentation/rest/maintenance_windows/create>
201+-- See: <http://developer.pagerduty.com/documentation/rest/maintenance_windows/create>
204202createWindow :: RequesterId
205203 -> UTCTime -- ^ 'cwStartTime'
206204 -> UTCTime -- ^ 'cwEndTime'
@@ -214,7 +212,7 @@ createWindow r s e xs =
214212createWindowBasic :: UTCTime -- ^ 'cwStartTime'
215213 -> UTCTime -- ^ 'cwEndTime'
216214 -> [ServiceId] -- ^ 'cwServiceIds'
217− -> Request CreateWindow 'Basic MaintenanceWindow
215+ -> Request CreateWindow Basic MaintenanceWindow
218216createWindowBasic s e xs =
219217 mk CreateWindow
220218 { _cwRequesterId' = Nothing
@@ -231,7 +229,7 @@ createWindowBasic s e xs =
231229--
232230-- @GET \/maintenance_windows\/\:id@
233231--
234−-- /See:/ <http://developer.pagerduty.com/documentation/rest/maintenance_windows/show>
232+-- See: <http://developer.pagerduty.com/documentation/rest/maintenance_windows/show>
235233getWindow :: WindowId -> Request Empty s MaintenanceWindow
236234getWindow w = empty & path .~ windows % w
237235
@@ -242,7 +240,7 @@ data UpdateWindow = UpdateWindow
242240 , _uwServiceIds' :: Maybe [ServiceId]
243241 } deriving (Eq, Show)
244242
245−jsonRequest ''UpdateWindow
243+deriveBody ''UpdateWindow
246244
247245-- | The maintenance window's start time. Can only be updated on future
248246-- maintenance windows. If the start_time is set to a date in the past, it will be
@@ -269,7 +267,7 @@ uwServiceIds = upd.uwServiceIds'
269267--
270268-- @PUT \/maintenance_windows\/\:id@
271269--
272−-- /See:/ <http://developer.pagerduty.com/documentation/rest/maintenance_windows/update>
270+-- See: <http://developer.pagerduty.com/documentation/rest/maintenance_windows/update>
273271updateWindow :: WindowId -> Request UpdateWindow s MaintenanceWindow
274272updateWindow w =
275273 mk UpdateWindow
@@ -284,6 +282,6 @@ updateWindow w =
284282--
285283-- @DELETE \/maintenance_windows\/\:id@
286284--
287−-- /See:/ <http://developer.pagerduty.com/documentation/rest/maintenance_windows/delete>
285+-- See: <http://developer.pagerduty.com/documentation/rest/maintenance_windows/delete>
288286deleteWindow :: WindowId -> Request Empty s Empty
289287deleteWindow w = empty & meth .~ DELETE & path .~ windows % w
src/Network/PagerDuty/REST/Reports.hs+19−20
@@ -1,13 +1,13 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE ExtendedDefaultRules #-}
3−{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE TemplateHaskell #-}
5−{-# LANGUAGE TypeFamilies #-}
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE ExtendedDefaultRules #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE TemplateHaskell #-}
5+{-# LANGUAGE TypeFamilies #-}
66
77{-# OPTIONS_GHC -fno-warn-type-defaults #-}
88
99-- Module : Network.PagerDuty.REST.Reports
10−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
10+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
1111-- License : This Source Code Form is subject to the terms of
1212-- the Mozilla Public License, v. 2.0.
1313-- A copy of the MPL can be found in the LICENSE file or
@@ -18,8 +18,6 @@
1818
1919-- | Access high level reports about alerts and incidents.
2020-- Useful for creating graphs.
21−--
22−-- /See:/ <http://developer.pagerduty.com/documentation/rest/reports>
2321module Network.PagerDuty.REST.Reports
2422 (
2523 -- * Alerts Per Time
@@ -28,12 +26,12 @@ module Network.PagerDuty.REST.Reports
2826 -- * Incidents Per Time
2927 , incidentsPerTime
3028
31− -- * Types
32− , Report
29+ -- * Lenses
3330 , rSince
3431 , rUntil
3532 , rRollup
3633
34+ -- * Types
3735 , Rollup (..)
3836
3937 , AlertReport
@@ -58,13 +56,14 @@ module Network.PagerDuty.REST.Reports
5856 , irNumberOfIncidents
5957 ) where
6058
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
59+import Control.Lens
60+import Data.Aeson.Lens
61+import Data.ByteString.Builder (Builder)
62+import Data.Time
63+import Network.PagerDuty.TH
64+import Network.PagerDuty.Types
6665
67−default (Path)
66+default (Builder)
6867
6968reports :: Path
7069reports = "reports"
@@ -83,7 +82,7 @@ data Report = Report
8382 , _rRollup' :: !Rollup
8483 } deriving (Eq, Show)
8584
86−queryRequest ''Report
85+deriveQuery ''Report
8786
8887-- | Start of the date range over which you want to search. The time element
8988-- is optional.
@@ -97,7 +96,7 @@ rUntil = upd.rUntil'._D
9796
9897-- | Specifies the bucket duration for each summation.
9998--
100−-- /Default:/ monthly.
99+-- Defaults to monthly.
101100--
102101-- Example: A time window of two years (based on since and until) with a
103102-- rollup of monthly will result in 24 sets of data points being returned
@@ -143,7 +142,7 @@ deriveRecord ''AlertTotals
143142--
144143-- @GET \/reports\/alerts_per_time@
145144--
146−-- /See:/ <http://developer.pagerduty.com/documentation/rest/reports/alerts_per_time>
145+-- See: <http://developer.pagerduty.com/documentation/rest/reports/alerts_per_time>
147146alertsPerTime :: UTCTime -- ^ 'rSince'
148147 -> UTCTime -- ^ 'rUntil'
149148 -> Request Report s AlertTotals
@@ -175,7 +174,7 @@ makeLens "_irNumberOfIncidents" ''IncidentReport
175174--
176175-- @GET \/reports\/incidents_per_time@
177176--
178−-- /See:/ <http://developer.pagerduty.com/documentation/rest/reports/incidents_per_time>
177+-- See: <http://developer.pagerduty.com/documentation/rest/reports/incidents_per_time>
179178incidentsPerTime :: UTCTime -- ^ 'rSince'
180179 -> UTCTime -- ^ 'rUntil'
181180 -> Request Report s [IncidentReport]
src/Network/PagerDuty/REST/Schedules.hs+3−617
@@ -1,13 +1,8 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE ExtendedDefaultRules #-}
3−{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE TemplateHaskell #-}
5−{-# LANGUAGE TypeFamilies #-}
6−
7−{-# OPTIONS_GHC -fno-warn-type-defaults #-}
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE TemplateHaskell #-}
83
94-- 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>
116-- License : This Source Code Form is subject to the terms of
127-- the Mozilla Public License, v. 2.0.
138-- A copy of the MPL can be found in the LICENSE file or
@@ -20,619 +15,10 @@
2015-- a user is on-call he is eligible to receive alerts from incidents.
2116--
2217-- This API allows users to manipulate on-call schedules.
23−--
24−-- /See:/ <http://developer.pagerduty.com/documentation/rest/schedules/overrides>
2518module Network.PagerDuty.REST.Schedules
2619 (
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
8120
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
11121 ) where
11222
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−
12423schedules :: Path
12524schedules = "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+111−46
@@ -1,13 +1,13 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE ExtendedDefaultRules #-}
3−{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE TemplateHaskell #-}
5−{-# LANGUAGE TypeFamilies #-}
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE ExtendedDefaultRules #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE TemplateHaskell #-}
5+{-# LANGUAGE TypeFamilies #-}
66
77{-# OPTIONS_GHC -fno-warn-type-defaults #-}
88
99-- Module : Network.PagerDuty.REST.Services
10−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
10+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
1111-- License : This Source Code Form is subject to the terms of
1212-- the Mozilla Public License, v. 2.0.
1313-- A copy of the MPL can be found in the LICENSE file or
@@ -24,7 +24,7 @@
2424-- When a service is shown inlined in other resources, a deleted service will
2525-- have its @html_url@ attribute set to 'Nothing'.
2626--
27−-- /See:/ <http://developer.pagerduty.com/documentation/rest/services>
27+-- See: <http://developer.pagerduty.com/documentation/rest/services>
2828module Network.PagerDuty.REST.Services
2929 (
3030 -- * List Services
@@ -72,6 +72,7 @@ module Network.PagerDuty.REST.Services
7272 -- * Types
7373 , EmailFilterMode (..)
7474 , EmailIncidentCreation (..)
75+ , MatchMode (..)
7576 , ServiceStatus (..)
7677 , ServiceType (..)
7778 , SeverityFilter (..)
@@ -82,6 +83,15 @@ module Network.PagerDuty.REST.Services
8283 , cntResolved
8384 , cntTotal
8485
86+ , EmailFilters (..)
87+ , efsId
88+ , efsSubjectMode
89+ , efsSubjectRegex
90+ , efsBodyMode
91+ , efsBodyRegex
92+ , efsFromEmailMode
93+ , efsFromEmailRegex
94+
8595 , PolicyInfo
8696 , pinfoId
8797 , pinfoName
@@ -106,16 +116,16 @@ module Network.PagerDuty.REST.Services
106116 , svcSeverityFilter
107117 ) where
108118
109−import Control.Lens hiding (Empty)
110−import Data.Aeson.Lens
111−import Data.Text (Text)
112−import Data.Time
113−import Network.HTTP.Types
114−import Network.PagerDuty.Internal.TH
115−import Network.PagerDuty.Internal.Types
116−import Network.PagerDuty.REST.Services.EmailFilters
119+import Control.Lens
120+import Data.Aeson.Lens
121+import Data.ByteString.Builder (Builder)
122+import Data.Text (Text)
123+import Data.Time
124+import Network.HTTP.Types
125+import Network.PagerDuty.TH
126+import Network.PagerDuty.Types
117127
118−default (Path)
128+default (Builder)
119129
120130services :: Path
121131services = "services"
@@ -187,12 +197,69 @@ data ServiceType
187197deriveNullary ''ServiceType
188198
189199data PolicyInfo = PolicyInfo
190− { _pinfoId :: EscalationPolicyId
200+ { _pinfoId :: PolicyId
191201 , _pinfoName :: Text
192202 } deriving (Eq, Show)
193203
194204deriveRecord ''PolicyInfo
195205
206+data MatchMode
207+ = Always
208+ | Match
209+ | NoMatch
210+ deriving (Eq, Show)
211+
212+deriveNullaryWith hyphenated ''MatchMode
213+
214+-- FIXME: Tighten up this type! Make the regex required for match/no-match.
215+data EmailFilters = EmailFilters
216+ { _efsId :: EmailFilterId
217+ , _efsSubjectMode :: Maybe MatchMode
218+ , _efsSubjectRegex :: Maybe Text
219+ , _efsBodyMode :: Maybe MatchMode
220+ , _efsBodyRegex :: Maybe Text
221+ , _efsFromEmailMode :: Maybe MatchMode
222+ , _efsFromEmailRegex :: Maybe Text
223+ } deriving (Eq, Show)
224+
225+deriveJSON ''EmailFilters
226+
227+-- | The email filter ID.
228+makeLens "_efsId" ''EmailFilters
229+
230+-- | One of always, match, no-match, which, respectively, means to not filter
231+-- the email trigger by subject, filter it if the email subject matches the
232+-- given regex, or filter if it doesn't match the given regex.
233+--
234+-- Defaults to always.
235+makeLens "_efsSubjectMode" ''EmailFilters
236+
237+-- | The regex to be used when subject_mode is match or no-match.
238+-- It is a required parameter on such cases.
239+makeLens "_efsSubjectRegex" ''EmailFilters
240+
241+-- | One of always, match, no-match, which, respectively, means to not filter
242+-- the email trigger by body, filter it if the body email matches the given regex,
243+-- or filter if it doesn't match the given regex.
244+--
245+-- Defaults to always.
246+makeLens "_efsBodyMode" ''EmailFilters
247+
248+-- | The regex to be used when body_mode is match or no-match.
249+-- It is a required parameter on such cases.
250+makeLens "_efsBodyRegex" ''EmailFilters
251+
252+-- | One of always, match, no-match, which, respectively, means to not filter
253+-- the email trigger by its from address, filter it if the email from address
254+-- matches the given regex, or filter if it doesn't match the given regex.
255+--
256+-- Defaults to always.
257+makeLens "_efsFromEmailMode" ''EmailFilters
258+
259+-- | The regex to be used when from_email_mode is match or no-match.
260+-- It is a required parameter on such cases.
261+makeLens "_efsFromEmailRegex" ''EmailFilters
262+
196263data SeverityFilter
197264 = SevCritical
198265 -- ^ Incidents are created when an alarm enters the Critical state.
@@ -223,8 +290,8 @@ data Service = Service
223290 , _svcIncidentCounts :: IncidentCounts
224291 , _svcEmailFilterMode :: EmailFilterMode
225292 , _svcType :: ServiceType
226− , _svcEscalationPolicy :: Maybe PolicyInfo -- FIXME: extract from inline.
227− , _svcEmailFilters :: Maybe [EmailFilterInfo] -- FIXME: extract from inline.
293+ , _svcEscalationPolicy :: Maybe PolicyInfo -- FIXME: extract from inline.
294+ , _svcEmailFilters :: Maybe EmailFilters -- FIXME: extract from inline.
228295 , _svcSeverityFilter :: Maybe SeverityFilter
229296 } deriving (Eq, Show)
230297
@@ -299,11 +366,11 @@ newtype ListServices = ListServices
299366
300367instance Paginate ListServices
301368
302−queryRequest ''ListServices
369+deriveQuery ''ListServices
303370
304371-- | Time zone in which dates in the result will be rendered.
305372--
306−-- /Default:/ account default time zone.
373+-- Defaults to account default time zone.
307374lsTimeZone :: Lens' (Request ListServices s r) (Maybe TimeZone)
308375lsTimeZone = upd.lsTimeZone'.mapping _TZ
309376
@@ -311,7 +378,7 @@ lsTimeZone = upd.lsTimeZone'.mapping _TZ
311378--
312379-- @GET \/services@
313380--
314−-- /See:/ <http://developer.pagerduty.com/documentation/rest/services/list>
381+-- See: <http://developer.pagerduty.com/documentation/rest/services/list>
315382listServices :: Request ListServices s [Service]
316383listServices =
317384 mk ListServices
@@ -322,7 +389,7 @@ listServices =
322389
323390data CreateService = CreateService
324391 { _csName' :: Text
325− , _csEscalationPolicyId' :: EscalationPolicyId
392+ , _csEscalationPolicyId' :: PolicyId
326393 , _csType' :: !ServiceType
327394 , _csVendorId' :: Maybe VendorId
328395 , _csDescription' :: Maybe Text
@@ -331,7 +398,7 @@ data CreateService = CreateService
331398 , _csSeverityFilter' :: Maybe SeverityFilter
332399 } deriving (Eq, Show)
333400
334−jsonRequest ''CreateService
401+deriveBody ''CreateService
335402
336403-- | The name of the service.
337404csName :: Lens' (Request CreateService s r) Text
@@ -351,19 +418,19 @@ csVendorId :: Lens' (Request CreateService s r) (Maybe VendorId)
351418csVendorId = upd.csVendorId'
352419
353420-- | The id of the escalation policy to be used by this service.
354−csEscalationPolicyId :: Lens' (Request CreateService s r) EscalationPolicyId
421+csEscalationPolicyId :: Lens' (Request CreateService s r) PolicyId
355422csEscalationPolicyId = upd.csEscalationPolicyId'
356423
357424-- | The duration in seconds before an incidents acknowledged in this service
358425-- become triggered again.
359426--
360−-- /Default:/ 30 minutes.
427+-- Defaults to 30 minutes.
361428csAcknowledgementTimeout :: Lens' (Request CreateService s r) (Maybe Int)
362429csAcknowledgementTimeout = upd.csAcknowledgementTimeout'
363430
364431-- | The duration in seconds before a triggered incident auto-resolves itself.
365432--
366−-- /Default:/ 4 hours.
433+-- Defaults to 4 hours.
367434csAutoResolveTimeout :: Lens' (Request CreateService s r) (Maybe Int)
368435csAutoResolveTimeout = upd.csAutoResolveTimeout'
369436
@@ -375,9 +442,9 @@ csSeverityFilter = upd.csSeverityFilter'
375442--
376443-- @POST \/services@
377444--
378−-- /See:/ <http://developer.pagerduty.com/documentation/rest/services/create>
445+-- See: <http://developer.pagerduty.com/documentation/rest/services/create>
379446createService :: Text
380− -> EscalationPolicyId
447+ -> PolicyId
381448 -> ServiceType
382449 -> Request CreateService s Service
383450createService n p t =
@@ -397,7 +464,7 @@ createService n p t =
397464--
398465-- @GET services\/\:id@
399466--
400−-- /See:/ <http://developer.pagerduty.com/documentation/rest/services/show>
467+-- See: <http://developer.pagerduty.com/documentation/rest/services/show>
401468getService :: ServiceId -> Request Empty s Service
402469getService i = empty
403470 & path .~ services % i
@@ -407,13 +474,13 @@ getService i = empty
407474data UpdateService = UpdateService
408475 { _usName' :: Maybe Text
409476 , _usDescription' :: Maybe Text
410− , _usEscalationPolicyId' :: Maybe EscalationPolicyId
477+ , _usEscalationPolicyId' :: Maybe PolicyId
411478 , _usAcknowledgementTimeout' :: Maybe Int
412479 , _usAutoResolveTimeout' :: Maybe Int
413480 , _usSeverityFilter' :: Maybe SeverityFilter
414481 } deriving (Eq, Show)
415482
416−jsonRequest ''UpdateService
483+deriveBody ''UpdateService
417484
418485-- | The name of the service.
419486usName :: Lens' (Request UpdateService s r) (Maybe Text)
@@ -424,19 +491,19 @@ usDescription :: Lens' (Request UpdateService s r) (Maybe Text)
424491usDescription = upd.usDescription'
425492
426493-- | The id of the escalation policy to be used by this service.
427−usEscalationPolicyId :: Lens' (Request UpdateService s r) (Maybe EscalationPolicyId)
494+usEscalationPolicyId :: Lens' (Request UpdateService s r) (Maybe PolicyId)
428495usEscalationPolicyId = upd.usEscalationPolicyId'
429496
430497-- | The duration in seconds before an incidents acknowledged in this service
431498-- become triggered again.
432499--
433−-- /Default:/ 30 minutes.
500+-- Defaults to 30 minutes.
434501usAcknowledgementTimeout :: Lens' (Request UpdateService s r) (Maybe Int)
435502usAcknowledgementTimeout = upd.usAcknowledgementTimeout'
436503
437504-- | The duration in seconds before a triggered incident auto-resolves itself.
438505--
439−-- /Default:/ 4 hours.
506+-- Defaults to 4 hours.
440507usAutoResolveTimeout :: Lens' (Request UpdateService s r) (Maybe Int)
441508usAutoResolveTimeout = upd.usAutoResolveTimeout'
442509
@@ -448,7 +515,7 @@ usSeverityFilter = upd.usSeverityFilter'
448515--
449516-- @PUT services\/\:id@
450517--
451−-- /See:/ <http://developer.pagerduty.com/documentation/rest/services/update>
518+-- See: <http://developer.pagerduty.com/documentation/rest/services/update>
452519updateService :: ServiceId -> Request UpdateService s Service
453520updateService i =
454521 mk UpdateService
@@ -468,7 +535,7 @@ updateService i =
468535--
469536-- @DELETE \/services/:id@
470537--
471−-- /See:/ <http://developer.pagerduty.com/documentation/rest/services/delete>
538+-- See: <http://developer.pagerduty.com/documentation/rest/services/delete>
472539deleteService :: ServiceId -> Request Empty s Empty
473540deleteService i = empty & meth .~ DELETE & path .~ services % i
474541
@@ -476,14 +543,13 @@ deleteService i = empty & meth .~ DELETE & path .~ services % i
476543--
477544-- @PUT services\/\:id\/enable@
478545--
479−-- /See:/ <http://developer.pagerduty.com/documentation/rest/services/enable>
546+-- See: <http://developer.pagerduty.com/documentation/rest/services/enable>
480547enableService :: RequesterId -> ServiceId -> Request Empty s Empty
481−enableService r i =
482− auth (enableServiceBasic i) & query .~ [("requester_id", r)]
548+enableService r i = auth (enableServiceBasic i) & query .~ [("requester_id", r)]
483549
484550-- | A version of 'enableService' which uses HTTP Basic authentication and
485551-- doesn't require a 'RequesterId'.
486−enableServiceBasic :: ServiceId -> Request Empty 'Basic Empty
552+enableServiceBasic :: ServiceId -> Request Empty Basic Empty
487553enableServiceBasic i = empty & meth .~ PUT & path .~ services % i % "enable"
488554
489555-- | Disable a service. Once a service is disabled, it will not be able to
@@ -491,14 +557,13 @@ enableServiceBasic i = empty & meth .~ PUT & path .~ services % i % "enable"
491557--
492558-- @PUT services\/\:id\/disable@
493559--
494−-- /See:/ <http://developer.pagerduty.com/documentation/rest/services/disable>
560+-- See: <http://developer.pagerduty.com/documentation/rest/services/disable>
495561disableService :: RequesterId -> ServiceId -> Request Empty s Empty
496−disableService r i =
497− auth (disableServiceBasic i) & query .~ [("requester_id", r)]
562+disableService r i = auth (disableServiceBasic i) & query .~ [("requester_id", r)]
498563
499564-- | A version of 'disableService' which uses HTTP Basic authentication and
500565-- doesn't require a 'RequesterId'.
501−disableServiceBasic :: ServiceId -> Request Empty 'Basic Empty
566+disableServiceBasic :: ServiceId -> Request Empty Basic Empty
502567disableServiceBasic i = empty & meth .~ PUT & path .~ services % i % "disable"
503568
504569-- | Regenerate a new service key for an existing service.
@@ -508,6 +573,6 @@ disableServiceBasic i = empty & meth .~ PUT & path .~ services % i % "disable"
508573--
509574-- @POST services\/\:id\/regenerate_key@
510575--
511−-- /See:/ <http://developer.pagerduty.com/documentation/rest/services/regenerate_key>
576+-- See: <http://developer.pagerduty.com/documentation/rest/services/regenerate_key>
512577regenerateKey :: ServiceId -> Request Empty s Service
513578regenerateKey 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+38−351
@@ -1,13 +1,8 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE ExtendedDefaultRules #-}
3−{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE TemplateHaskell #-}
5−{-# LANGUAGE TypeFamilies #-}
6−
7−{-# OPTIONS_GHC -fno-warn-type-defaults #-}
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE TemplateHaskell #-}
83
94-- 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>
116-- License : This Source Code Form is subject to the terms of
127-- the Mozilla Public License, v. 2.0.
138-- A copy of the MPL can be found in the LICENSE file or
@@ -19,366 +14,58 @@
1914-- | Access and manipulate user data for your PagerDuty account. When a user is
2015-- shown inlined in other resources, a deleted user will have its @html_url@ attribute
2116-- set to null.
22−--
23−-- /See:/ <http://developer.pagerduty.com/documentation/rest/users>
2417module Network.PagerDuty.REST.Users
2518 (
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
6019
6120 -- * Types
62− , PolicyInfo
63− , piId
64− , piName
65−
66− , OnCall
67− , ocLevel
68− , ocStart
69− , ocEnd
70− , ocEscalationPolicy
71−
72− , Role (..)
73−
74− , HasUserInfo (..)
75− , UserInfo
76− , User
21+ User
22+ , uId
23+ , uName
24+ , uEmail
25+ , uTimeZone
26+ , uColor
7727 , uRole
7828 , uAvatarUrl
79− , uUserUrl
29+ , uUrl
8030 , uInvitationSent
81− , uJobTitle
8231 ) where
8332
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)
33+import Control.Lens
34+import Data.Monoid
35+import Data.Text (Text)
36+import Data.Time
37+import Network.HTTP.Types
38+import Network.PagerDuty.TH
39+import Network.PagerDuty.Types
9640
9741users :: Path
9842users = "users"
9943
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−
17444data User = User
175− { _uInfo :: UserInfo
176− , _uRole :: !Role
177− , _uAvatarUrl :: Text
178− , _uUserUrl :: Text
179− , _uInvitationSent' :: !Bool'
180− , _uJobTitle :: Maybe Text
45+ { _uId :: UserId
46+ , _uName :: Text
47+ , _uEmail :: Address
48+ , _uTimeZone :: TZ
49+ , _uColor :: Text
50+ , _uRole :: Text
51+ , _uAvatarUrl :: Text
52+ , _uUrl :: Text
53+ , _uInvitationSent :: Bool'
18154 } deriving (Eq, Show)
18255
183− -- FIXME: add notification_rules, contact_methods, on_call
184−
185−makeLenses ''User
56+deriveJSON ''User
18657
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"
58+makeLens "_uId" ''User
59+makeLens "_uName" ''User
60+makeLens "_uEmail" ''User
61+makeLens "_uColor" ''User
62+makeLens "_uRole" ''User
63+makeLens "_uAvatarUrl" ''User
64+makeLens "_uUrl" ''User
19565
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
66+uTimeZone :: Lens' User TimeZone
67+uTimeZone = lens _uTimeZone (\u x -> u { _uTimeZone = x }) . _TZ
21068
21169uInvitationSent :: 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
70+uInvitationSent =
71+ lens _uInvitationSent (\u x -> u { _uInvitationSent = x }) . _B
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 #-}
21{-# LANGUAGE OverloadedStrings #-}
32{-# LANGUAGE TemplateHaskell #-}
43
54-- 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>
76-- License : This Source Code Form is subject to the terms of
87-- the Mozilla Public License, v. 2.0.
98-- A copy of the MPL can be found in the LICENSE file or
@@ -22,95 +21,10 @@
2221-- certain interesting changes to an incident's state will cause other types of
2322-- incident webhook messages to be sent: Generally, any change to the @status@ or
2423-- @assigned_to_user@ of an incident will cause an outgoing message to be sent.
25−--
26−-- /See:/ <http://developer.pagerduty.com/documentation/rest/webhooks>
2724module Network.PagerDuty.REST.Webhooks
28− ( WebhookType (..)
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)
25+ (
9126
92−instance ToJSON WebhookType 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
27+ ) where
11328
114−-- | The date/time when the incident changed state.
115−wCreatedOn :: Lens' Webhook UTCTime
116−wCreatedOn = lens _wCreatedOn (\i x -> i { _wCreatedOn = x }) . _D
29+-- Just create the types + fromJSON instances
30+decodeWebhook = undefined
src/Network/PagerDuty/Internal/TH.hs → src/Network/PagerDuty/TH.hsrenamed+27−30
@@ -1,7 +1,7 @@
11{-# LANGUAGE TemplateHaskell #-}
22
3−-- Module : Network.PagerDuty.Internal.TH
4−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
3+-- Module : Network.PagerDuty.TH
4+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
55-- License : This Source Code Form is subject to the terms of
66-- the Mozilla Public License, v. 2.0.
77-- A copy of the MPL can be found in the LICENSE file or
@@ -10,16 +10,14 @@
1010-- Stability : experimental
1111-- Portability : non-portable (GHC extensions)
1212
13−module Network.PagerDuty.Internal.TH
13+module Network.PagerDuty.TH
1414 (
15− -- * Requests
16− jsonRequest
17− , queryRequest
18−
1915 -- * Compound expressions
20− , deriveNullary
16+ deriveNullary
2117 , deriveNullaryWith
2218 , deriveRecord
19+ , deriveQuery
20+ , deriveBody
2321
2422 -- * JSON
2523 , deriveJSON
@@ -27,7 +25,6 @@ module Network.PagerDuty.Internal.TH
2725
2826 -- * Lenses
2927 , makeLens
30− , makeFields
3128
3229 -- * Re-exported generics
3330 , deriveGeneric
@@ -40,30 +37,15 @@ module Network.PagerDuty.Internal.TH
4037
4138import Control.Applicative
4239import Control.Lens
43−import qualified Data.Aeson.TH as Aeson
40+import qualified Data.Aeson.TH as Aeson
4441import Data.Aeson.Types
45−import Data.ByteString (ByteString)
46−import qualified Data.Text.Encoding as Text
42+import Data.ByteString (ByteString)
43+import qualified Data.Text.Encoding as Text
4744import Generics.SOP.TH
4845import Language.Haskell.TH
4946import 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− ]
47+import Network.PagerDuty.Query
48+import Network.PagerDuty.Options
6749
6850deriveNullary :: Name -> Q [Dec]
6951deriveNullary = deriveNullaryWith underscored
@@ -71,7 +53,7 @@ deriveNullary = deriveNullaryWith underscored
7153deriveNullaryWith :: Options -> Name -> Q [Dec]
7254deriveNullaryWith o n = concat <$> sequence
7355 [ deriveJSONWith o n
74− , [d|instance QueryValues $(conT n) where queryValues = value . toJSON|]
56+ , [d|instance ToQuery $(conT n) where queryValues = value . toJSON|]
7557 ]
7658
7759deriveRecord :: Name -> Q [Dec]
@@ -80,6 +62,21 @@ deriveRecord n = concat <$> sequence
8062 , makeLenses n
8163 ]
8264
65+deriveBody :: Name -> Q [Dec]
66+deriveBody n = concat <$> sequence
67+ [ makeLenses n
68+ , deriveJSON n
69+ , [d|instance QueryLike $(conT n) where toQuery = const []|]
70+ ]
71+
72+deriveQuery :: Name -> Q [Dec]
73+deriveQuery n = concat <$> sequence
74+ [ deriveGeneric n
75+ , makeLenses n
76+ , [d|instance ToJSON $(conT n) where toJSON = const (toJSON (object []))|]
77+ , [d|instance QueryLike $(conT n) where toQuery = gquery|]
78+ ]
79+
8380deriveJSON :: Name -> Q [Dec]
8481deriveJSON = deriveJSONWith underscored
8582
src/Network/PagerDuty/Types.hs+406−84
@@ -1,5 +1,18 @@
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 TupleSections #-}
12+{-# LANGUAGE ViewPatterns #-}
13+
114-- Module : Network.PagerDuty.Types
2−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
15+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
316-- License : This Source Code Form is subject to the terms of
417-- the Mozilla Public License, v. 2.0.
518-- A copy of the MPL can be found in the LICENSE file or
@@ -8,86 +21,395 @@
821-- Stability : experimental
922-- Portability : non-portable (GHC extensions)
1023
11−module Network.PagerDuty.Types
12− (
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
27− , Paginate
28− , Request
29−
30− -- ** Errors
31− , Error
32− , _Internal
33− , _Integration
34− , _REST
35− -- *** Messages
36− , HasMessage (..)
37− -- *** Fields
38− , HasErrors (..)
39− -- *** Integration
40− , IntegrationError
41− , status
42− -- *** REST
43− , RESTError
44− , Code
45− , code
46− , description
47−
48− -- ** Authentication
49− , Security (..)
50− , Auth (..)
51−
52− -- ** Keys
53− , Key
54− , mkKey
55− -- *** Aliases
56− , ServiceKey
57− , IncidentKey
58−
59− -- ** Identifiers
60− , Id
61− , mkId
62− -- *** Aliases
63− , AlertId
64− , ContactId
65− , EmailFilterId
66− , EscalationPolicyId
67− , EscalationRuleId
68− , IncidentId
69− , LogEntryId
70− , NoteId
71− , NotificationRuleId
72− , OverrideId
73− , RequesterId
74− , ScheduleId
75− , ServiceId
76− , UserId
77− , VendorId
78− , WebhookId
79− , WindowId
80−
81− -- ** SubDomain
82− , SubDomain
83− , mkSubDomain
84−
85− -- ** Address
86− , Address
87− , mkAddress
88−
89− -- ** Miscellaneous
90− , Empty (..)
91− ) where
92−
93−import Network.PagerDuty.Internal.Types
24+module Network.PagerDuty.Types where
25+ -- (
26+ -- -- * Requests
27+ -- Auth (..)
28+ -- , Cred (..)
29+ -- , Domain (..)
30+
31+ -- , Request (..)
32+ -- , Request'
33+
34+ -- , Paginate (..)
35+
36+ -- -- * Errors
37+ -- , Code (..)
38+ -- , message
39+ -- , RestError (..)
40+ -- , Error (..)
41+
42+ -- -- * Primitives
43+ -- , Key (..)
44+ -- , ServiceKey
45+ -- , IncidentKey
46+
47+ -- , Id (..)
48+ -- , ServiceId
49+ -- , RequesterId
50+
51+ -- , Empty (..)
52+ -- ) where
53+
54+import Control.Applicative
55+import Control.Lens hiding ((.=))
56+import Data.Aeson hiding (Error)
57+import Data.Aeson.Types (Parser)
58+import Data.ByteString (ByteString)
59+import qualified Data.ByteString.Char8 as BS
60+import Data.ByteString.Conversion hiding (List)
61+import Data.Default
62+import Data.Function (on)
63+import qualified Data.HashMap.Strict as Map
64+import Data.List (deleteBy)
65+import Data.Monoid
66+import Data.String
67+import Data.Text (Text)
68+import qualified Data.Text.Encoding as Text
69+import Data.Time
70+import GHC.TypeLits
71+import Network.HTTP.Types
72+import Network.HTTP.Types.QueryLike
73+import Network.PagerDuty.Query
74+import Network.PagerDuty.TH
75+import System.Locale
76+
77+-- FIXME: Verify IncidentId/IncidentKey .. *Id/*Key are actually different or needed
78+
79+newtype List a = L [a]
80+ deriving (Eq, Show, Monoid)
81+
82+deriveJSON ''List
83+makePrisms ''List
84+
85+instance ToQuery a => ToQuery (List a) where
86+ queryValues (L xs) = concatMap queryValues xs
87+
88+newtype Bool' = B Bool
89+ deriving (Eq, Show)
90+
91+deriveJSON ''Bool'
92+makePrisms ''Bool'
93+
94+instance ToByteString Bool' where
95+ builder (B True) = "true"
96+ builder (B False) = "false"
97+
98+instance ToQuery Bool'
99+
100+newtype Date = D UTCTime
101+ deriving (Eq, Ord, Show)
102+
103+makePrisms ''Date
104+
105+instance FromJSON Date where
106+ parseJSON = fmap D . parseJSON
107+
108+instance ToJSON Date where
109+ toJSON (D d) = toJSON d
110+
111+instance ToByteString Date where
112+ builder (D d) = builder
113+ (formatTime defaultTimeLocale (iso8601DateFormat $ Just "%XZ") d)
114+
115+instance ToQuery Date
116+
117+newtype TZ = TZ TimeZone
118+ deriving (Eq, Show)
119+
120+makePrisms ''TZ
121+
122+instance FromJSON TZ where
123+ parseJSON = undefined
124+
125+instance ToJSON TZ where
126+ toJSON = toJSON . Text.decodeUtf8 . toByteString'
127+
128+instance ToByteString TZ where
129+ builder (TZ tz) = builder (timeZoneName tz)
130+
131+instance ToQuery TZ
132+
133+instance Default TZ where
134+ def = TZ utc
135+
136+data Security = Basic | Token
137+ deriving (Eq, Show)
138+
139+data Auth (a :: Security) where
140+ AuthBasic :: ByteString -> ByteString -> Auth Basic
141+ AuthToken :: ByteString -> Auth Token
142+
143+deriving instance Eq (Auth a)
144+deriving instance Show (Auth a)
145+
146+newtype SubDomain = SubDomain ByteString
147+ deriving (Eq, Show, IsString)
148+
149+domain :: SubDomain -> ByteString
150+domain (SubDomain s)
151+ | base `BS.isSuffixOf` s = s
152+ | otherwise = s <> base
153+ where
154+ base = ".pagerduty.com"
155+
156+newtype Code = Code Integer
157+ deriving (Eq, Show)
158+
159+deriveJSON ''Code
160+
161+description :: Code -> Text
162+description (Code c) =
163+ case c of
164+ 2000 -> "Internal Error"
165+ 2001 -> "Invalid Input Provided"
166+ 2002 -> "Arguments Caused Error"
167+ 2003 -> "Missing Arguments"
168+ 2004 -> "Invalid 'since' or 'until' Parameter Values"
169+ 2005 -> "Invalid Query Date Range"
170+ 2006 -> "Authentication Failed"
171+ 2007 -> "Account Not Found"
172+ 2008 -> "Account Locked"
173+ 2009 -> "Only HTTPS Allowed For This Call"
174+ 2010 -> "Access Denied"
175+ 2011 -> "The action requires a 'requester_id' to be specified"
176+ 2012 -> "Your account is expired and cannot use the API"
177+ _ -> "Unrecognised error code"
178+
179+data IntegrationError = IntegrationError
180+ { _ieStatus :: Text
181+ , _ieMessage :: Text
182+ , _ieErrors :: [Text]
183+ } deriving (Eq, Show)
184+
185+deriveRecord ''IntegrationError
186+
187+data RestError = RestError
188+ { _reCode :: Code
189+ , _reMessage :: Text
190+ , _reErrors :: [Text]
191+ } deriving (Eq, Show)
192+
193+deriveRecord ''RestError
194+
195+data Error
196+ = Internal String
197+ | Integration IntegrationError
198+ | Rest RestError
199+ deriving (Eq, Show)
200+
201+instance FromJSON Error where
202+ parseJSON o = (Rest <$> parseJSON o)
203+ <|> (Integration <$> parseJSON o)
204+
205+makePrisms ''Error
206+
207+data Pager = Pager
208+ { _pgOffset :: !Int
209+ -- ^ The offset used in the execution of the query.
210+ , _pgLimit :: !Int
211+ -- ^ The limit used in the execution of the query.
212+ , _pgTotal :: !Int
213+ -- ^ The total number of records available.
214+ , _pgQuery :: Maybe Text
215+ -- ^ An optional query= value to be added to the query string.
216+ } deriving (Eq, Show)
217+
218+makeLenses ''Pager
219+
220+instance FromJSON a => FromJSON (a, Maybe Pager) where
221+ parseJSON = withObject "paginated" $ \o -> (,)
222+ <$> parseJSON (Object o)
223+ <*> optional (parse o)
224+ where
225+ parse o = Pager
226+ -- The offset of the first record returned.
227+ -- Default is 0.
228+ <$> o .: "offset" .!= 0
229+ -- The number of records returned.
230+ -- Default (and max limit) is 100 for most APIs.
231+ <*> o .: "limit" .!= 100
232+ <*> o .: "total"
233+ <*> o .:? "query"
234+
235+instance ToJSON Pager where
236+ toJSON p = object
237+ [ "offset" .= _pgOffset p
238+ , "limit" .= _pgLimit p
239+ ]
240+
241+-- | A path segment.
242+data Path where
243+ Path :: Path
244+ Seg :: ToByteString a => a -> Path
245+
246+instance Monoid Path where
247+ mempty = Path
248+ mappend x Path = x
249+ mappend Path y = y
250+ mappend (Seg x) (Seg y) = Seg (builder x <> "/" <> builder y)
251+
252+instance IsString Path where
253+ fromString = Seg
254+
255+instance ToByteString Path where
256+ builder Path = mempty
257+ builder (Seg x) = builder x
258+
259+(%) :: ToByteString a => Path -> a -> Path
260+a % b = a <> Seg b
261+
262+renderPath :: Path -> ByteString
263+renderPath = toByteString' . mappend v1
264+ where
265+ v1 :: Path
266+ v1 = "/api/v1"
267+
268+data Request a (s :: Security) b where
269+ Request :: (QueryLike a, ToJSON a)
270+ => { _rqMeth :: !StdMethod
271+ , _rqPath :: Path
272+ , _rqQuery :: Query
273+ , _rqBody :: a
274+ , _rqPager :: Maybe Pager
275+ , _rqUnwrap :: Value -> Parser Value
276+ }
277+ -> Request a s b
278+
279+instance ToJSON (Request a s b) where
280+ -- Manually unwrapped to ensure GADT constraint holds.
281+ toJSON (Request _ _ _ b p _) = Object $
282+ let Object x = toJSON b
283+ in case toJSON p of
284+ (Object y) -> x <> y
285+ _ -> x
286+
287+type Unwrap = Getting (First Value) Value Value
288+
289+-- | Create a defaulted request from the payload type.
290+mk :: (QueryLike a, ToJSON a) => a -> Request a s b
291+mk x = Request GET mempty mempty x Nothing pure
292+
293+empty :: Request Empty s r
294+empty = mk Empty
295+
296+-- | Lens into the body of a request.
297+upd :: (QueryLike a, ToJSON a) => Lens' (Request a s b) a
298+upd = lens _rqBody (\(Request m p q _ g u) x -> Request m p q x g u)
299+
300+-- | Drop the security constraint.
301+auth :: Request a s b -> Request a t b
302+auth (Request x m p q g u) = Request x m p q g u
303+
304+meth :: Lens' (Request a s b) StdMethod
305+meth = lens _rqMeth (\r x -> r { _rqMeth = x })
306+
307+path :: Lens' (Request a s b) Path
308+path = lens _rqPath (\r x -> r { _rqPath = x })
309+
310+query :: QueryValueLike v
311+ => Lens (Request a s b) (Request a s b) Query [(ByteString, v)]
312+query = lens _rqQuery (\r x -> r { _rqQuery = toQuery x })
313+
314+pager :: Lens' (Request a s b) (Maybe Pager)
315+pager = lens _rqPager (\r x -> r { _rqPager = x })
316+
317+unwrap :: Setter (Request a s b) (Request a s b) (Value -> Parser Value) Unwrap
318+unwrap f r = f (_rqUnwrap r) <&> \k -> r { _rqUnwrap = g k }
319+ where
320+ g k x = maybe (fail "Failed to extract nested keys.") return (x ^? k)
321+
322+-- | Exists primarily to obtain a constraint for the 'paginate' function.
323+class Paginate a where
324+ next :: Request a s b -> Maybe Pager -> Maybe (Request a s b)
325+ next rq = maybe Nothing go
326+ where
327+ go x | x^.pgTotal == 0 = Nothing
328+ | otherwise = Just $
329+ rq & pager ?~ (x & pgOffset +~ x^.pgTotal)
330+ & query %~ (add . clear)
331+ where
332+ add :: Query -> Query
333+ add = maybe id ((:) . (k,) . Just . Text.encodeUtf8) (x^.pgQuery)
334+
335+ clear :: Query -> Query
336+ clear = deleteBy ((==) `on` fst) (k, Nothing)
337+
338+ k :: ByteString
339+ k = "query"
340+
341+newtype Key (a :: Symbol) = Key Text
342+ deriving (Eq, Show, IsString)
343+
344+instance FromJSON (Key a) where
345+ parseJSON = withText "key" (return . Key)
346+
347+instance ToJSON (Key a) where
348+ toJSON (Key k) = toJSON k
349+
350+instance ToByteString (Key a) where
351+ builder (Key k) = builder k
352+
353+instance ToQuery (Key a)
354+
355+instance QueryValueLike (Key a) where
356+ toQueryValue = Just . toByteString'
357+
358+type ServiceKey = Key "service"
359+type IncidentKey = Key "incident"
360+
361+newtype Id (a :: Symbol) = Id Text
362+ deriving (Eq, Show, IsString)
363+
364+instance FromJSON (Id a) where
365+ parseJSON = withText "id" (return . Id)
366+
367+instance ToJSON (Id a) where
368+ toJSON (Id i) = toJSON i
369+
370+instance ToByteString (Id a) where
371+ builder (Id i) = builder i
372+
373+instance ToQuery (Id a)
374+
375+instance QueryValueLike (Id a) where
376+ toQueryValue = Just . toByteString'
377+
378+type AlertId = Id "alert"
379+type EmailFilterId = Id "email-filter"
380+type LogEntryId = Id "log-entry"
381+type PolicyId = Id "policy"
382+type RequesterId = Id "requester"
383+type RuleId = Id "rule"
384+type ScheduleId = Id "schedule"
385+type ServiceId = Id "service"
386+type TargetId = Id "target"
387+type UserId = Id "user"
388+type VendorId = Id "vendor"
389+type WindowId = Id "maintenance-window"
390+
391+data Empty = Empty
392+
393+instance ToJSON Empty where
394+ toJSON = const (object [])
395+
396+instance FromJSON Empty where
397+ parseJSON = withObject "empty" f
398+ where
399+ f !o | Map.null o = pure Empty
400+ | otherwise = fail "Unexpected non-empty JSON object."
401+
402+instance QueryLike Empty where
403+ toQuery = const []
404+
405+newtype Address = Address Text
406+ deriving (Eq, Show)
407+
408+deriveJSON ''Address
409+makePrisms ''Address
410+
411+instance ToByteString Address where
412+ builder (Address a) = builder a
413+
414+instance ToQuery Address
415+
stack.yamldeleted−7
@@ -1,7 +0,0 @@
1−resolver: lts-19.23
2−
3−packages:
4−- .
5−
6−nix:
7− packages: [zlib]