git.iko.soy/typeable/pagerduty
on 74afffe help sign in
.gitignore−1
since splitsnapshots
unifiedsplit
@@ -9,7 +9,6 @@
9cabal.sandbox.config
9cabal.sandbox.config
10
10
11# Dirs
11# Dirs
12−.stack-work
13cabal-dev
12cabal-dev
14bin
13bin
15dist
14dist
.travis.ymldeleted−30
@@ -1,30 +0,0 @@
1−sudo: false
2−
3−cache:
4− apt: true
5− directories:
6− - ~/.stack
7−
8−branches:
9− only:
10− - master
11− - develop
12−
13−before_install:
14− - export PATH=/opt/ghc/$GHCVER/bin:$PATH
15− - export PATH=~/.local/bin:$PATH
16− - ./script/travis-lifecycle-before_install
17−
18−install:
19− - ./script/travis-lifecycle-install
20−
21−script:
22− - ./script/travis-lifecycle-script
23−
24−matrix:
25− fast_finish: true
26− include:
27− - env: GHCVER=8.0.1
28− addons: { apt: { packages: [ghc-8.0.1], sources: [hvr-ghc] } }
29− - env: GHCVER=7.10.3
30− addons: { apt: { packages: [ghc-7.10.3], sources: [hvr-ghc] } }
Makefilenew file+20
@@ -0,0 +1,20 @@
1+FLAGS := -j --disable-documentation --disable-library-coverage
2+
3+build:
4+ cabal build $(addprefix -,$(findstring j,$(MAKEFLAGS)))
5+
6+all:
7+ make clean; make install && make build
8+
9+install: cabal.sandbox.config
10+ cabal install $(FLAGS) --only-dependencies
11+
12+clean:
13+ cabal clean
14+ rm -rf cabal.sandbox.config .cabal-sandbox
15+
16+doc:
17+ cabal haddock
18+
19+cabal.sandbox.config:
20+ 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+46−56
@@ -1,32 +1,21 @@
1name: pagerduty
1name: pagerduty
2−version: 0.0.8
2+version: 0.1.0
3−synopsis: Client library for PagerDuty Integration and REST APIs.
3+synopsis: Pager Duty API Client
4homepage: http://github.com/brendanhay/pagerduty
4homepage: http://github.com/brendanhay/pagerduty
5license: OtherLicense
5license: OtherLicense
6license-file: LICENSE
6license-file: LICENSE
7−author: Brendan Hay
7+author: Brendan Hay, Kim Altintop
8−maintainer: Brendan Hay <brendan.g.hay@gmail.com>
8+maintainer: Brendan Hay <brendan.g.hay@gmail.com>, Kim Altintop <kim.altintop@gmail.com>
9−copyright: Copyright (c) 2013-2015 Brendan Hay, 2014 Kim Altintop
9+copyright: Copyright (c) 2013-2014 Brendan Hay, 2014 Kim Altintop
10−category: Network, PagerDuty, Monitoring
10+category: Network, Monitoring
11build-type: Simple
11build-type: Simple
12cabal-version: >= 1.10
12cabal-version: >= 1.10
13
13
14description:
14description:
15− PagerDuty is an alerting system for IT professionals. PagerDuty connects
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:
15+ Client library for the the PagerDuty REST APIs documented here:
21 .
16 .
22 * Integration API - <http://developer.pagerduty.com/documentation/integration>
17 * Integration API - <http://developer.pagerduty.com/documentation/integration>
23− .
24 * REST API - <http://developer.pagerduty.com/documentation/rest>
18 * REST API - <http://developer.pagerduty.com/documentation/rest>
25− .
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>.
30
19
31extra-source-files:
20extra-source-files:
32 README.md
21 README.md
@@ -43,55 +32,56 @@ library
43
32
44 exposed-modules:
33 exposed-modules:
45 Control.Monad.Trans.PagerDuty
34 Control.Monad.Trans.PagerDuty
46− , Network.PagerDuty.Integration
35+ -- , Network.PagerDuty.Integration
47− , Network.PagerDuty.REST
36+ -- , Network.PagerDuty.REST
48− , Network.PagerDuty.REST.Alerts
37+ -- , Network.PagerDuty.REST.Alerts
49− , Network.PagerDuty.REST.EscalationPolicies
38+ -- , Network.PagerDuty.REST.EscalationPolicies
50− , Network.PagerDuty.REST.EscalationPolicies.EscalationRules
39+-- , Network.PagerDuty.REST.EscalationPolicies.EscalationRules
51− , Network.PagerDuty.REST.Incidents
40+ -- , Network.PagerDuty.REST.Incidents
52− , Network.PagerDuty.REST.Incidents.Notes
41+ -- , Network.PagerDuty.REST.Incidents.Notes
53− , Network.PagerDuty.REST.LogEntries
42+ -- , Network.PagerDuty.REST.LogEntries
54− , Network.PagerDuty.REST.MaintenanceWindows
43+ -- , Network.PagerDuty.REST.MaintenanceWindows
55− , Network.PagerDuty.REST.Reports
44+ -- , Network.PagerDuty.REST.Reports
56− , Network.PagerDuty.REST.Schedules
45+ -- , Network.PagerDuty.REST.Schedules
57− , Network.PagerDuty.REST.Schedules.Overrides
46+-- , Network.PagerDuty.REST.Schedules.Overrides
58− , Network.PagerDuty.REST.Services
47+ -- , Network.PagerDuty.REST.Services
59− , Network.PagerDuty.REST.Services.EmailFilters
48+-- , Network.PagerDuty.REST.Services.EmailFilters
60− , Network.PagerDuty.REST.Users
49+-- , Network.PagerDuty.REST.Users
61 , Network.PagerDuty.REST.Users.ContactMethods
50 , Network.PagerDuty.REST.Users.ContactMethods
62 , Network.PagerDuty.REST.Users.NotificationRules
51 , Network.PagerDuty.REST.Users.NotificationRules
63 , Network.PagerDuty.REST.Webhooks
52 , Network.PagerDuty.REST.Webhooks
64
53
65 other-modules:
54 other-modules:
66− Network.PagerDuty.Internal.IO
55+ Network.PagerDuty.IO
67− , Network.PagerDuty.Internal.Options
56+ , Network.PagerDuty.Options
68− , Network.PagerDuty.Internal.Query
57+ , Network.PagerDuty.Query
69− , Network.PagerDuty.Internal.TH
58+ , Network.PagerDuty.TH
70− , Network.PagerDuty.Internal.Types
71 , Network.PagerDuty.Types
59 , Network.PagerDuty.Types
72
60
73 build-depends:
61 build-depends:
74− aeson >= 2.0
62+ aeson > 0.7 && <= 0.8
75− , base >= 4.7 && < 5
63+ , base >= 4.5 && < 5.0
64+-- , base64-bytestring >= 1.0 && < 1.1
76− , bifunctors >= 4.1
65+ , bifunctors
66+
77 , bytestring >= 0.9
67 , bytestring >= 0.9
78 , bytestring-conversion >= 0.2.1
68 , bytestring-conversion >= 0.2.1
79− , conduit > 1.1
69+ , conduit >= 0.5.5
80− , data-default-class >= 0.0.1
70+ , data-default-class
81 , exceptions >= 0.6
71 , exceptions >= 0.6
82− , generics-sop >= 0.5.0.0
83− , http-client >= 0.5 && < 1
72+ , http-client >= 0.3.6
84 , http-types >= 0.8
73 , http-types >= 0.8
85− , lens >= 4.4
74+ , lens >= 4.0
86− , lens-aeson >= 1
75+ , lens-aeson >= 1.0
87− , mmorph >= 1
76+ , mmorph >= 1.0
88− , monad-control >= 1
89− , mtl >= 2.1.3.1
77+ , mtl >= 2.2.1
90− , template-haskell >= 2.2
78+ , old-locale
91 , text >= 1.1
79 , text >= 1.1
92− , time >= 1.2
80+ , time == 1.4.*
93− , time-locale-compat >= 0.1.0.1
94− , transformers >= 0.2
81+ , transformers >= 0.4.1
95− , transformers-compat >= 0.3
96− , transformers-base >= 0.4.2
97 , unordered-containers >= 0.2.3
82 , unordered-containers >= 0.2.3
83+
84+ , generics-sop
85+ , monad-control
86+ , template-haskell
87+ , 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 @@
2{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+{-# LANGUAGE KindSignatures #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE RecordWildCards #-}
8+{-# LANGUAGE TemplateHaskell #-}
6{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE UndecidableInstances #-}
10{-# LANGUAGE UndecidableInstances #-}
8
11
9-- Module : Control.Monad.Trans.PagerDuty
12-- Module : Control.Monad.Trans.PagerDuty
10−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
13+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
11-- License : This Source Code Form is subject to the terms of
14-- License : This Source Code Form is subject to the terms of
12-- the Mozilla Public License, v. 2.0.
15-- the Mozilla Public License, v. 2.0.
13-- A copy of the MPL can be found in the LICENSE file or
16-- A copy of the MPL can be found in the LICENSE file or
@@ -19,50 +22,57 @@
19module Control.Monad.Trans.PagerDuty
22module Control.Monad.Trans.PagerDuty
20 (
23 (
21 -- * Transformer
24 -- * Transformer
22− PagerDuty
25+ PD
23− , PagerDutyT
26+ , PDT
24
27
25− -- * Running
28+ -- * Run
26− , runPagerDutyT
29+ , runPDT
27
30
31+ -- * Environment
32+ , Env
33+ , envDomain
34+ , envAuth
35+ , envManager
36+-- , envLogging
37+
28− -- * Integration events
38+ -- * Integration API
29 , submit
39 , submit
30− , submitCatch
31
40
32− -- * REST requests
41+ -- * REST API
33 , send
42 , send
34− , sendCatch
35 , paginate
43 , paginate
36− , paginateCatch
37−
38− -- ** Lifting errors
39− , hoistError
40−
41− , module Network.PagerDuty.Types
42 ) where
44 ) where
43
45
44import Control.Applicative
46import Control.Applicative
45−import Control.Monad
47+import Control.Lens
46import Control.Monad.Base
48import Control.Monad.Base
47import Control.Monad.Catch
49import Control.Monad.Catch
48−import Control.Monad.Except (MonadError (..))
50+import Control.Monad.Except
49import Control.Monad.Morph
51import Control.Monad.Morph
50import Control.Monad.Reader
52import Control.Monad.Reader
51import Control.Monad.Trans.Control
53import Control.Monad.Trans.Control
52−import Control.Monad.Trans.Except
53import Data.Aeson
54import Data.Aeson
54import Data.Conduit
55import Data.Conduit
56+import Network.HTTP.Client (Manager)
55−import Network.PagerDuty.Integration (Event, Response)
57+import Network.PagerDuty.Integration (Event, Response)
56−import qualified Network.PagerDuty.Integration as Int
58+import qualified Network.PagerDuty.Integration as Int
57−import Network.PagerDuty.Internal.Types
58−import qualified Network.PagerDuty.REST as REST
59+import qualified Network.PagerDuty.REST as REST
59import Network.PagerDuty.Types
60import Network.PagerDuty.Types
60
61
62+data Env (s :: Security) = Env
63+ { _envDomain :: SubDomain
64+ , _envAuth :: Auth s
65+ , _envManager :: Manager
66+-- , _envLogging ::
67+ }
68+
69+makeLenses ''Env
70+
61−-- | A convenient alias for 'PagerDutyT' 'IO'.
71+-- | A convenient alias for 'PDT' 'IO'.
62−type PagerDuty s = PagerDutyT s IO
72+type PD s = PDT s IO
63
73
64−newtype PagerDutyT s m a = PagerDutyT
74+newtype PDT s m a = PDT
65− { unPagerDutyT :: ReaderT (Env s) (ExceptT Error m) a
75+ { unPDT :: ReaderT (Env s) (ExceptT Error m) a
66 } deriving
76 } deriving
67 ( Functor
77 ( Functor
68 , Applicative
78 , Applicative
@@ -74,48 +84,50 @@ newtype PagerDutyT s m a = PagerDutyT
74 , MonadError Error
84 , MonadError Error
75 )
85 )
76
86
77−instance MonadTrans (PagerDutyT s) where
87+instance MonadTrans (PDT s) where
78− lift = PagerDutyT . lift . lift
88+ lift = PDT . lift . lift
79 {-# INLINE lift #-}
89 {-# INLINE lift #-}
80
90
81−instance MonadBase b m => MonadBase b (PagerDutyT s m) where
91+instance MonadBase b m => MonadBase b (PDT s m) where
82 liftBase = liftBaseDefault
92 liftBase = liftBaseDefault
83 {-# INLINE liftBase #-}
93 {-# INLINE liftBase #-}
84
94
85−instance MonadTransControl (PagerDutyT s) where
95+instance MonadTransControl (PDT s) where
96+ newtype StT (PDT s) a = StTAWS
86− type StT (PagerDutyT s) a = StT (ExceptT Error) (StT (ReaderT (Env s)) a)
97+ { unStTAWS :: StT (ExceptT Error) (StT (ReaderT (Env s)) a)
98+ }
87
99
88− liftWith f = PagerDutyT $
100+ liftWith f = PDT $
89 liftWith $ \g ->
101 liftWith $ \g ->
90− liftWith $ \h ->
102+ liftWith $ \h ->
91− f (h . g . unPagerDutyT)
103+ f (liftM StTAWS . h . g . unPDT)
92 {-# INLINE liftWith #-}
104 {-# INLINE liftWith #-}
93
105
94− restoreT = PagerDutyT . restoreT . restoreT
106+ restoreT = PDT . restoreT . restoreT . liftM unStTAWS
95 {-# INLINE restoreT #-}
107 {-# INLINE restoreT #-}
96
108
97−instance MonadBaseControl b m => MonadBaseControl b (PagerDutyT s m) where
109+instance MonadBaseControl b m => MonadBaseControl b (PDT s m) where
98− type StM (PagerDutyT s m) a = ComposeSt (PagerDutyT s) m a
110+ newtype StM (PDT s m) a = StMPDT { unStMPDT :: ComposeSt (PDT s) m a }
99
111
100− liftBaseWith = defaultLiftBaseWith
112+ liftBaseWith = defaultLiftBaseWith StMPDT
101 {-# INLINE liftBaseWith #-}
113 {-# INLINE liftBaseWith #-}
102
114
103− restoreM = defaultRestoreM
115+ restoreM = defaultRestoreM unStMPDT
104 {-# INLINE restoreM #-}
116 {-# INLINE restoreM #-}
105
117
106−instance MFunctor (PagerDutyT s) where
118+instance MFunctor (PDT s) where
107− hoist nat m = PagerDutyT (ReaderT (ExceptT . nat . runPagerDutyT m))
119+ hoist nat m = PDT (ReaderT (ExceptT . nat . runPDT m))
108 {-# INLINE hoist #-}
120 {-# INLINE hoist #-}
109
121
110−instance MMonad (PagerDutyT s) where
122+instance MMonad (PDT s) where
111− embed f m = ask >>= f . runPagerDutyT m >>= either throwError return
123+ embed f m = ask >>= f . runPDT m >>= either throwError return
112 {-# INLINE embed #-}
124 {-# INLINE embed #-}
113
125
114−runPagerDutyT :: PagerDutyT s m a -> Env s -> m (Either Error a)
126+runPDT :: PDT s m a -> Env s -> m (Either Error a)
115−runPagerDutyT (PagerDutyT k) = runExceptT . runReaderT k
127+runPDT (PDT k) = runExceptT . runReaderT k
116
128
117−hoistError :: (MonadError Error m) => Either Error a -> m a
129+hoistEither :: (MonadError Error m) => Either Error a -> m a
118−hoistError = either throwError return
130+hoistEither = either throwError return
119
131
120scoped :: MonadReader (Env s) m => (Env s -> m a) -> m a
132scoped :: MonadReader (Env s) m => (Env s -> m a) -> m a
121scoped f = ask >>= f
133scoped f = ask >>= f
@@ -123,17 +135,20 @@ scoped f = ask >>= f
123submit :: ( MonadIO m
135submit :: ( MonadIO m
124 , MonadReader (Env s) m
136 , MonadReader (Env s) m
125 , MonadError Error m
137 , MonadError Error m
138+ , Event a
126 )
139 )
127− => Event
140+ => a
128 -> m Response
141 -> m Response
129−submit = submitCatch >=> hoistError
142+submit = submitCatch >=> hoistEither
130
143
131submitCatch :: ( MonadIO m
144submitCatch :: ( MonadIO m
132 , MonadReader (Env s) m
145 , MonadReader (Env s) m
146+ , Event a
133 )
147 )
134− => Event
148+ => a
135 -> m (Either Error Response)
149 -> m (Either Error Response)
136−submitCatch x = scoped $ \e -> Int.submitWith (_envManager e) (_envLogger e) x
150+submitCatch x = scoped $ \e ->
151+ Int.submit (_envManager e) x
137
152
138send :: ( MonadIO m
153send :: ( MonadIO m
139 , MonadReader (Env s) m
154 , MonadReader (Env s) m
@@ -142,7 +157,7 @@ send :: ( MonadIO m
142 )
157 )
143 => Request a s b
158 => Request a s b
144 -> m b
159 -> m b
145−send = sendCatch >=> hoistError
160+send = sendCatch >=> hoistEither
146
161
147sendCatch :: ( MonadIO m
162sendCatch :: ( MonadIO m
148 , MonadReader (Env s) m
163 , MonadReader (Env s) m
@@ -150,7 +165,8 @@ sendCatch :: ( MonadIO m
150 )
165 )
151 => Request a s b
166 => Request a s b
152 -> m (Either Error b)
167 -> m (Either Error b)
153−sendCatch x = scoped (`REST.sendWith` x)
168+sendCatch x = scoped $ \Env{..} ->
169+ REST.send _envAuth _envDomain _envManager x
154
170
155paginate :: ( MonadIO m
171paginate :: ( MonadIO m
156 , MonadReader (Env s) m
172 , MonadReader (Env s) m
@@ -160,7 +176,7 @@ paginate :: ( MonadIO m
160 )
176 )
161 => Request a s b
177 => Request a s b
162 -> Source m b
178 -> Source m b
163−paginate x = paginateCatch x $= awaitForever (hoistError >=> yield)
179+paginate x = paginateCatch x $= awaitForever (hoistEither >=> yield)
164
180
165paginateCatch :: ( MonadIO m
181paginateCatch :: ( MonadIO m
166 , MonadReader (Env s) m
182 , MonadReader (Env s) m
@@ -169,4 +185,5 @@ paginateCatch :: ( MonadIO m
169 )
185 )
170 => Request a s b
186 => Request a s b
171 -> Source m (Either Error b)
187 -> Source m (Either Error b)
172−paginateCatch x = scoped (`REST.paginateWith` x)
188+paginateCatch x = scoped $ \Env{..} ->
189+ REST.paginate _envAuth _envDomain _envManager x
src/Network/PagerDuty/API/Integration.hsnew file+77
@@ -0,0 +1,77 @@
1+{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+
5+-- Module : Network.PagerDuty.Integration
6+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
7+-- License : This Source Code Form is subject to the terms of
8+-- the Mozilla Public License, v. 2.0.
9+-- A copy of the MPL can be found in the LICENSE file or
10+-- you can obtain it at http://mozilla.org/MPL/2.0/.
11+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
12+-- Stability : experimental
13+-- Portability : non-portable (GHC extensions)
14+
15+-- | The "Integration API"
16+--
17+-- <http://developer.pagerduty.com/documentation/integration/events>
18+--
19+module Network.PagerDuty.API.Integration
20+ ( Event (..)
21+ , submitEvent
22+
23+ -- * Re-exported
24+ , ServiceKey
25+ , IncidentKey
26+ ) where
27+
28+import Control.Applicative
29+import Data.Aeson
30+import Data.Maybe (catMaybes)
31+import Data.Text (Text)
32+import GHC.Generics
33+import Network.PagerDuty.IO
34+import Network.PagerDuty.Types
35+
36+submitEvent :: Event -> PagerDuty a (Either Error IncidentKey)
37+submitEvent = fmap (fmap incident_key) . request defaultRequest
38+ { method = methodPost
39+ , host = "events.pagerduty.com"
40+ , path = "/generic/2010-04-15/create_event.json"
41+ }
42+
43+data Event
44+ = Trigger !ServiceKey !(Maybe IncidentKey) !Text !(Maybe Object)
45+ | Acknowledge !ServiceKey !IncidentKey !(Maybe Text) !(Maybe Object)
46+ | Resolve !ServiceKey !IncidentKey !(Maybe Text) !(Maybe Object)
47+ deriving (Eq, Show)
48+
49+instance ToJSON Event where
50+ toJSON (Trigger svc minc desc mdets) =
51+ jsonEvent "trigger" svc minc (Just desc) mdets
52+ toJSON (Acknowledge svc inc mdesc mdets) =
53+ jsonEvent "acknowledge" svc (Just inc) mdesc mdets
54+ toJSON (Resolve svc inc mdesc mdets) =
55+ jsonEvent "resolve" svc (Just inc) mdesc mdets
56+
57+jsonEvent :: Text
58+ -> ServiceKey
59+ -> Maybe IncidentKey
60+ -> Maybe Text
61+ -> Maybe Object
62+ -> Value
63+jsonEvent typ skey ikey desc dets = object $ catMaybes
64+ [ Just $ "event_type" .= typ
65+ , Just $ "service_key" .= skey
66+ , ("incident_key" .=) <$> ikey
67+ , ("description" .=) <$> desc
68+ , ("details" .=) <$> dets
69+ ]
70+
71+data EventResponse = ER
72+ { status :: !Text
73+ , incident_key :: !IncidentKey
74+ , message :: !Text
75+ } deriving (Show, Generic)
76+
77+instance FromJSON EventResponse
src/Network/PagerDuty/API/LogEntries.hsnew file+28
@@ -0,0 +1,28 @@
1+{-# LANGUAGE DeriveGeneric #-}
2+
3+-- Module : Network.PagerDuty.API.LogEntries
4+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
5+-- License : This Source Code Form is subject to the terms of
6+-- the Mozilla Public License, v. 2.0.
7+-- A copy of the MPL can be found in the LICENSE file or
8+-- you can obtain it at http://mozilla.org/MPL/2.0/.
9+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
10+-- Stability : experimental
11+-- Portability : non-portable (GHC extensions)
12+
13+module Network.PagerDuty.API.LogEntries where
14+
15+import Data.Aeson
16+import GHC.Generics
17+import Network.PagerDuty.Types
18+
19+data LogEntries = LogEntries
20+ { lesTotal :: !Int
21+ , leslogEntries :: [LogEntry]
22+ } deriving (Eq, Show, Generic)
23+
24+instance FromJSON LogEntries
25+instance ToJSON LogEntries
26+
27+logEntries :: PagerDuty Authenticated (Either Error LogEntries)
28+logEntries = undefined
src/Network/PagerDuty/API/MaintenanceWindows.hsnew file+232
@@ -0,0 +1,232 @@
1+{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+
4+-- Module : Network.PagerDuty.API.MaintenanceWindows
5+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
6+-- License : This Source Code Form is subject to the terms of
7+-- the Mozilla Public License, v. 2.0.
8+-- A copy of the MPL can be found in the LICENSE file or
9+-- you can obtain it at http://mozilla.org/MPL/2.0/.
10+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
11+-- Stability : experimental
12+-- Portability : non-portable (GHC extensions)
13+
14+module Network.PagerDuty.API.MaintenanceWindows
15+ ( CreateMaintenanceWindow (..)
16+ , MaintenanceWindowCounts (..)
17+ , MaintenanceWindowCreatorDetails (..)
18+ , MaintenanceWindowCreatorId
19+ , MaintenanceWindowDetails (..)
20+ , MaintenanceWindowFilter (..)
21+ , MaintenanceWindowId
22+ , ServiceInfo (..)
23+ , UpdateMaintenanceWindow (..)
24+
25+ , createMaintenanceWindow
26+ , createMaintenanceWindow'
27+ , updateMaintenanceWindow
28+ , listMaintenanceWindows
29+ , getMaintenanceWindow
30+ , deleteMaintenaceWindow
31+ ) where
32+
33+import Control.Applicative
34+import Data.Aeson
35+import Data.ByteString (ByteString)
36+import Data.Maybe
37+import Data.Monoid
38+import Data.Text (Text)
39+import qualified Data.Text as T
40+import Data.Text.Encoding
41+import Data.Time (UTCTime)
42+import GHC.Generics
43+import Network.PagerDuty.Internal
44+import Network.PagerDuty.IO
45+import Network.PagerDuty.Types
46+
47+type A a = Authenticated a
48+
49+bASE_PATH :: ByteString
50+bASE_PATH = "/api/v1/maintenance_windows/"
51+
52+createMaintenanceWindow :: CreateMaintenanceWindow
53+ -> RequesterId
54+ -> PagerDuty (A Token) (Either Error MaintenanceWindowDetails)
55+createMaintenanceWindow mw rid =
56+ fmap (fmap dr_maintenance_window)
57+ . request defaultRequest
58+ { method = methodPost
59+ , path = bASE_PATH
60+ }
61+ $ CreateMaintenanceWindowRequest
62+ { cmwr_maintenance_window = mw
63+ , cmwr_requester_id = Just rid
64+ }
65+
66+createMaintenanceWindow' :: CreateMaintenanceWindow
67+ -> PagerDuty (A BasicAuth) (Either Error MaintenanceWindowDetails)
68+createMaintenanceWindow' mw =
69+ fmap (fmap dr_maintenance_window)
70+ . request defaultRequest
71+ { method = methodPost
72+ , path = bASE_PATH
73+ }
74+ $ CreateMaintenanceWindowRequest
75+ { cmwr_maintenance_window = mw
76+ , cmwr_requester_id = Nothing
77+ }
78+
79+updateMaintenanceWindow :: MaintenanceWindowId
80+ -> UpdateMaintenanceWindow
81+ -> PagerDuty (A a) (Either Error MaintenanceWindowDetails)
82+updateMaintenanceWindow (Id mwid) =
83+ fmap (fmap dr_maintenance_window)
84+ . request defaultRequest
85+ { method = methodPut
86+ , path = bASE_PATH <> encodeUtf8 mwid
87+ }
88+
89+listMaintenanceWindows :: Maybe Text
90+ -> [ServiceId]
91+ -> Maybe MaintenanceWindowFilter
92+ -> PagerDuty (A a) (Either Error (MaintenanceWindowCounts, [MaintenanceWindowDetails]))
93+listMaintenanceWindows qry sids filt =
94+ fmap (fmap (liftA2 (,) lr_counts lr_maintenance_windows))
95+ . request defaultRequest
96+ { method = methodGet
97+ , path = bASE_PATH
98+ , queryString = renderSimpleQuery True mkQuery
99+ }
100+ $ T.empty
101+ where
102+ mkQuery :: [(ByteString, ByteString)]
103+ mkQuery = (catMaybes [ fmap ((,) "query" . encodeUtf8) qry
104+ , fmap ((,) "filter" . filterToBS) filt
105+ ])
106+ ++ map (\ (Id sid) -> ("service_ids[]", encodeUtf8 sid)) sids
107+
108+getMaintenanceWindow :: MaintenanceWindowId
109+ -> PagerDuty (A a) (Either Error MaintenanceWindowDetails)
110+getMaintenanceWindow (Id mwid) =
111+ fmap (fmap dr_maintenance_window)
112+ . request defaultRequest
113+ { method = methodGet
114+ , path = bASE_PATH <> encodeUtf8 mwid
115+ }
116+ $ T.empty
117+
118+deleteMaintenaceWindow :: MaintenanceWindowId
119+ -> PagerDuty (A a) (Either Error Empty)
120+deleteMaintenaceWindow (Id mwid) = request defaultRequest
121+ { method = methodDelete
122+ , path = bASE_PATH <> encodeUtf8 mwid
123+ } $ T.empty
124+
125+data MaintenanceWindow
126+data MaintenanceWindowCreator
127+
128+type MaintenanceWindowId = Id MaintenanceWindow
129+type MaintenanceWindowCreatorId = Id MaintenanceWindowCreator
130+
131+data CreateMaintenanceWindow = CreateMaintenanceWindow
132+ { cmw_start_time :: !UTCTime
133+ , cmw_end_time :: !UTCTime
134+ , cmw_description :: Maybe Text
135+ , cmw_service_ids :: [ServiceId]
136+ } deriving (Show, Generic)
137+
138+instance ToJSON CreateMaintenanceWindow where
139+ toJSON = gToJson "cmw_"
140+
141+data UpdateMaintenanceWindow = UpdateMaintenanceWindow
142+ { umw_start_time :: Maybe UTCTime
143+ , umw_end_time :: Maybe UTCTime
144+ , umw_description :: Maybe Text
145+ , umw_service_ids :: [ServiceId]
146+ } deriving (Show, Generic)
147+
148+instance ToJSON UpdateMaintenanceWindow where
149+ toJSON = gToJson "umw_"
150+
151+data CreateMaintenanceWindowRequest = CreateMaintenanceWindowRequest
152+ { cmwr_maintenance_window :: !CreateMaintenanceWindow
153+ , cmwr_requester_id :: Maybe RequesterId
154+ } deriving (Show, Generic)
155+
156+instance ToJSON CreateMaintenanceWindowRequest where
157+ toJSON = gToJson "cmwr_"
158+
159+data MaintenanceWindowDetails = MaintenanceWindowDetails
160+ { mwd_id :: !MaintenanceWindowId
161+ , mwd_sequence_number :: !Int
162+ , mwd_start_time :: !UTCTime
163+ , mwd_end_time :: !UTCTime
164+ , mwd_description :: Maybe Text
165+ , mwd_created_by :: !MaintenanceWindowCreatorDetails
166+ , mwd_services :: [ServiceInfo]
167+ } deriving (Show, Generic)
168+
169+instance FromJSON MaintenanceWindowDetails where
170+ parseJSON = gFromJson "mwd_"
171+
172+-- possibly used elsewhere (UserDetails or somesuch)
173+data MaintenanceWindowCreatorDetails = MaintenanceWindowCreatorDetails
174+ { mwcd_id :: !MaintenanceWindowCreatorId
175+ , mwcd_name :: !Text
176+ , mwcd_email :: !Text
177+ , mwcd_time_zone :: !Text
178+ , mwcd_color :: !Text -- wtf?
179+ , mwcd_role :: !Text
180+ , mwcd_avatar_url :: !Text
181+ , mwcd_user_url :: !Text
182+ , mwcd_invitation_sent :: !Bool
183+ } deriving (Show, Generic)
184+
185+instance FromJSON MaintenanceWindowCreatorDetails where
186+ parseJSON = gFromJson "mwcd_"
187+
188+data ServiceInfo = ServiceInfo
189+ { si_name :: !Text
190+ , si_url :: !Text
191+ , si_id :: !ServiceId
192+ } deriving (Show, Generic)
193+
194+instance FromJSON ServiceInfo where
195+ parseJSON = gFromJson "si_"
196+
197+data ListResponse = ListResponse
198+ { lr_maintenance_windows :: [MaintenanceWindowDetails]
199+ , lr_query :: Maybe Text
200+ , lr_counts :: !MaintenanceWindowCounts
201+ } deriving (Show, Generic)
202+
203+instance FromJSON ListResponse where
204+ parseJSON = gFromJson "lr_"
205+
206+data MaintenanceWindowCounts = MaintenanceWindowCounts
207+ { mwc_ongoing :: !Int
208+ , mwc_future :: !Int
209+ , mwc_past :: !Int
210+ , mwc_all :: !Int
211+ } deriving (Show, Generic)
212+
213+instance FromJSON MaintenanceWindowCounts where
214+ parseJSON = gFromJson "mwc_"
215+
216+newtype DetailsResponse = DetailsResponse
217+ { dr_maintenance_window :: MaintenanceWindowDetails
218+ } deriving (Show, Generic)
219+
220+instance FromJSON DetailsResponse where
221+ parseJSON = gFromJson "dr_"
222+
223+data MaintenanceWindowFilter
224+ = Past
225+ | Future
226+ | Ongoing
227+ deriving Show
228+
229+filterToBS :: MaintenanceWindowFilter -> ByteString
230+filterToBS Past = "past"
231+filterToBS Future = "future"
232+filterToBS Ongoing = "ongoing"
src/Network/PagerDuty/API/Services.hsnew file+292
@@ -0,0 +1,292 @@
1+{-# LANGUAGE DeriveGeneric #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+
5+-- Module : Network.PagerDuty.API.Services
6+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
7+-- License : This Source Code Form is subject to the terms of
8+-- the Mozilla Public License, v. 2.0.
9+-- A copy of the MPL can be found in the LICENSE file or
10+-- you can obtain it at http://mozilla.org/MPL/2.0/.
11+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
12+-- Stability : experimental
13+-- Portability : non-portable (GHC extensions)
14+
15+module Network.PagerDuty.API.Services
16+ ( ServiceDetails (..)
17+ , CreateService (..)
18+ , UpdateService (..)
19+ , ServiceStatus (..)
20+ , ServiceType (..)
21+ , EmailFilterMode (..)
22+ , IncidentCounts (..)
23+ , EmailIncidentCreation (..)
24+
25+ , createService
26+ , updateService
27+ , listServices
28+ , getService
29+ , deleteService
30+ , disableService
31+ , disableService'
32+ , enableService
33+ , enableService'
34+ , regenerateServiceKey
35+ ) where
36+
37+import Control.Applicative
38+import Control.Monad
39+import Data.Aeson
40+import Data.ByteString (ByteString)
41+import Data.Monoid
42+import Data.Text (Text)
43+import qualified Data.Text as T
44+import Data.Text.Encoding
45+import Data.Time
46+import GHC.Generics
47+import Network.PagerDuty.Internal
48+import Network.PagerDuty.IO
49+import Network.PagerDuty.Types
50+
51+type A a = Authenticated a
52+
53+bASE_PATH :: ByteString
54+bASE_PATH = "/api/v1/services/"
55+
56+createService :: CreateService -> PagerDuty (A a) (Either Error ServiceDetails)
57+createService = fmap (fmap service) . request defaultRequest
58+ { method = methodPost
59+ , path = bASE_PATH
60+ }
61+ . CreateServiceRequest
62+
63+updateService :: ServiceId
64+ -> UpdateService
65+ -> PagerDuty (A a) (Either Error ServiceDetails)
66+updateService (Id sid) = fmap (fmap service) . request defaultRequest
67+ { method = methodPut
68+ , path = bASE_PATH <> encodeUtf8 sid
69+ }
70+ . UpdateServiceRequest
71+
72+listServices :: PagerDuty (A a) (Either Error [ServiceDetails])
73+listServices = fmap (fmap services) . request defaultRequest
74+ { method = methodGet
75+ , path = bASE_PATH
76+ , queryString = "?include[]=escalation_policy&include[]=email_filters"
77+ } $ T.empty
78+
79+getService :: ServiceId -> PagerDuty (A a) (Either Error ServiceDetails)
80+getService (Id sid) = fmap (fmap service) . request defaultRequest
81+ { method = methodGet
82+ , path = bASE_PATH <> encodeUtf8 sid
83+ , queryString = "?include[]=escalation_policy&include[]=email_filters"
84+ } $ T.empty
85+
86+deleteService :: ServiceId -> PagerDuty (A a) (Either Error Empty)
87+deleteService (Id sid) = request defaultRequest
88+ { method = methodDelete
89+ , path = bASE_PATH <> encodeUtf8 sid
90+ } $ T.empty
91+
92+disableService :: ServiceId
93+ -> RequesterId
94+ -> PagerDuty (A Token) (Either Error Empty)
95+disableService (Id sid) (Id rid) = request defaultRequest
96+ { method = methodPut
97+ , path = bASE_PATH <> encodeUtf8 sid <> "/disable"
98+ , queryString = "?requester_id=" <> encodeUtf8 rid
99+ } $ T.empty
100+
101+disableService' :: ServiceId -> PagerDuty (A BasicAuth) (Either Error Empty)
102+disableService' (Id sid) = request defaultRequest
103+ { method = methodPut
104+ , path = bASE_PATH <> encodeUtf8 sid <> "/disable"
105+ } $ T.empty
106+
107+enableService :: ServiceId
108+ -> RequesterId
109+ -> PagerDuty (A Token) (Either Error Empty)
110+enableService (Id sid) (Id rid) = request defaultRequest
111+ { method = methodPut
112+ , path = bASE_PATH <> encodeUtf8 sid <> "/enable"
113+ , queryString = "?requester_id=" <> encodeUtf8 rid
114+ } $ T.empty
115+
116+enableService' :: ServiceId -> PagerDuty (A BasicAuth) (Either Error Empty)
117+enableService' (Id sid) = request defaultRequest
118+ { method = methodPut
119+ , path = bASE_PATH <> encodeUtf8 sid <> "/enable"
120+ } $ T.empty
121+
122+regenerateServiceKey :: ServiceId -> PagerDuty (A a) (Either Error ServiceKey)
123+regenerateServiceKey (Id sid) = fmap (fmap (sd_service_key . service)) . request defaultRequest
124+ { method = methodPost
125+ , path = bASE_PATH <> encodeUtf8 sid <> "/regenerate_key"
126+ } $ T.empty
127+
128+newtype CreateServiceRequest = CreateServiceRequest
129+ { csr_service :: CreateService
130+ } deriving (Show, Generic)
131+
132+instance ToJSON CreateServiceRequest where
133+ toJSON = gToJson "csr_"
134+
135+newtype UpdateServiceRequest = UpdateServiceRequest
136+ { usr_service :: UpdateService
137+ } deriving (Show, Generic)
138+
139+instance ToJSON UpdateServiceRequest where
140+ toJSON = gToJson "usr_"
141+
142+newtype DetailsListResponse = DLR { services :: [ServiceDetails] }
143+ deriving (Show, Generic)
144+
145+instance FromJSON DetailsListResponse
146+
147+newtype DetailsResponse = DR { service :: ServiceDetails }
148+ deriving (Show, Generic)
149+
150+instance FromJSON DetailsResponse
151+
152+data CreateService = CreateService
153+ { cs_name :: !Text
154+ , cs_escalation_policy_id :: !Text
155+ , cs_type :: !ServiceType
156+ , cs_description :: Maybe Text
157+ , cs_acknowledgement_timeout :: Maybe Int
158+ , cs_auto_resolve_timeout :: Maybe Int
159+ , cs_severity_filter :: Maybe Text
160+ } deriving (Show, Generic)
161+
162+instance ToJSON CreateService where toJSON = gToJson "cs_"
163+
164+data UpdateService = UpdateService
165+ { us_name :: Maybe Text
166+ , us_escalation_policy_id :: Maybe Text
167+ , us_type :: Maybe ServiceType
168+ , us_description :: Maybe Text
169+ , us_acknowledgement_timeout :: Maybe Int
170+ , us_auto_resolve_timeout :: Maybe Int
171+ , us_severity_filter :: Maybe Text
172+ } deriving (Show, Generic)
173+
174+instance ToJSON UpdateService where toJSON = gToJson "us_"
175+
176+data ServiceDetails = ServiceDetails
177+ { sd_id :: !ServiceId
178+ , sd_name :: !Text
179+ , sd_description :: !Text
180+ , sd_service_url :: !Text
181+ , sd_service_key :: !ServiceKey
182+ , sd_auto_resolve_timeout :: !Int
183+ , sd_acknowledgement_timeout :: !Int
184+ , sd_created_at :: !ZonedTime
185+ , sd_deleted_at :: Maybe ZonedTime
186+ , sd_status :: !ServiceStatus
187+ , sd_last_incident_timestamp :: Maybe ZonedTime
188+ , sd_email_incident_creation :: Maybe EmailIncidentCreation
189+ , sd_incident_counts :: !IncidentCounts
190+ , sd_email_filter_mode :: !EmailFilterMode
191+ , sd_type :: !ServiceType
192+ , sd_escalation_policy :: Maybe Object -- todo
193+ , sd_email_filters :: Maybe Object -- todo
194+ , sd_severity_filter :: Maybe Text -- todo?
195+ } deriving (Show, Generic)
196+
197+instance FromJSON ServiceDetails where
198+ parseJSON = gFromJson "sd_"
199+
200+data ServiceStatus
201+ = Active
202+ | Warning
203+ | Critical
204+ | Maintenance
205+ | Disabled
206+ deriving (Eq, Show)
207+
208+instance FromJSON ServiceStatus where
209+ parseJSON (String s) = case s of
210+ "active" -> pure Active
211+ "warning" -> pure Warning
212+ "critical" -> pure Critical
213+ "maintenance" -> pure Maintenance
214+ "disabled" -> pure Disabled
215+ _ -> mzero
216+
217+ parseJSON _ = mzero
218+
219+data IncidentCounts = IncidentCounts
220+ { triggered :: !Int
221+ , acknowledged :: !Int
222+ , resolved :: !Int
223+ , total :: !Int
224+ } deriving (Show, Generic)
225+
226+instance FromJSON IncidentCounts
227+
228+data EmailIncidentCreation
229+ = OnNewEmail
230+ | OnNewEmailSubject
231+ | OnlyIfNoOpenIncidents
232+ deriving (Eq, Show)
233+
234+instance FromJSON EmailIncidentCreation where
235+ parseJSON (String s) = case s of
236+ "on_new_email" -> pure OnNewEmail
237+ "on_new_email_subject" -> pure OnNewEmailSubject
238+ "only_if_no_open_incidents" -> pure OnlyIfNoOpenIncidents
239+ _ -> mzero
240+
241+ parseJSON _ = mzero
242+
243+data EmailFilterMode
244+ = AllEmail
245+ | OrRulesEmail
246+ | AndRulesEmail
247+ deriving (Eq, Show)
248+
249+instance FromJSON EmailFilterMode where
250+ parseJSON (String s) = case s of
251+ "all-email" -> pure AllEmail
252+ "or-rules-email" -> pure OrRulesEmail
253+ "and-rules-email" -> pure AndRulesEmail
254+ _ -> mzero
255+
256+ parseJSON _ = mzero
257+
258+data ServiceType
259+ = CloudKick
260+ | GenericEmail
261+ | GenericEventsApi
262+ | Keynote
263+ | Nagios
264+ | Pingdom
265+ | ServerDensity
266+ | SqlMonitor
267+ deriving (Eq, Show)
268+
269+instance FromJSON ServiceType where
270+ parseJSON (String s) = case s of
271+ "cloudkick" -> pure CloudKick
272+ "generic_email" -> pure GenericEmail
273+ "generic_events_api" -> pure GenericEventsApi
274+ "keynote" -> pure Keynote
275+ "nagios" -> pure Nagios
276+ "pingdom" -> pure Pingdom
277+ "server_density" -> pure ServerDensity
278+ "sql_monitor" -> pure SqlMonitor
279+ _ -> mzero
280+
281+ parseJSON _ = mzero
282+
283+instance ToJSON ServiceType where
284+ toJSON st = String $ case st of
285+ CloudKick -> "cloudkick"
286+ GenericEmail -> "generic_email"
287+ GenericEventsApi -> "generic_events_api"
288+ Keynote -> "keynote"
289+ Nagios -> "nagios"
290+ Pingdom -> "pingdom"
291+ ServerDensity -> "server_density"
292+ SqlMonitor -> "sql_monitor"
src/Network/PagerDuty/IO.hsnew file+66
@@ -0,0 +1,66 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+-- Module : Network.PagerDuty.IO
4+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
5+-- License : This Source Code Form is subject to the terms of
6+-- the Mozilla Public License, v. 2.0.
7+-- A copy of the MPL can be found in the LICENSE file or
8+-- you can obtain it at http://mozilla.org/MPL/2.0/.
9+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
10+-- Stability : experimental
11+-- Portability : non-portable (GHC extensions)
12+
13+module Network.PagerDuty.IO where
14+
15+import Control.Monad
16+import Control.Monad.IO.Class
17+import Data.Aeson hiding (Error)
18+import qualified Data.ByteString.Lazy as LBS
19+import Network.HTTP.Client (Manager, httpLbs)
20+import qualified Network.HTTP.Client as Client
21+import Network.HTTP.Types
22+import Network.PagerDuty.Types
23+
24+request :: (MonadIO m, ToJSON a, FromJSON b)
25+ => Manager
26+ -> a
27+ -> Client.Request
28+ -> m (Either Error b)
29+request m x rq = liftIO (httpLbs raw m) >>= response
30+ where
31+ raw = rq
32+ { Client.secure = True
33+ , Client.port = 443
34+ , Client.requestHeaders = headers
35+ , Client.requestBody = Client.RequestBodyLBS (encode x)
36+ }
37+
38+ headers =
39+ [ ("Content-Type", "application/json")
40+ , ("Accept", "application/json")
41+ ]
42+
43+response :: (Monad m, FromJSON b)
44+ => Client.Response LBS.ByteString
45+ -> m (Either Error b)
46+response rs = case statusCode (Client.responseStatus rs) of
47+ 200 -> success
48+ 201 -> success
49+ 400 -> failure
50+ 500 -> failure
51+ n -> return . Left $ unhandled n
52+ where
53+ success = maybe (Left unknown) Right `liftM` parse
54+ failure = maybe (Left unknown) Left `liftM` parse
55+
56+ unhandled n = Internal
57+ $ "PagerDuty returned unhandled status code: " ++ show n
58+
59+ unknown = Internal
60+ $ "Unable to parse response into a PagerDuty API compatible type: "
61+ ++ show body
62+
63+ parse :: (Monad m, FromJSON a) => m (Maybe a)
64+ parse = return (decode body)
65+
66+ body = Client.responseBody rs
src/Network/PagerDuty/Integration.hs+150−190
@@ -1,12 +1,10 @@
1−{-# LANGUAGE FlexibleInstances #-}
1+{-# LANGUAGE GADTs #-}
2−{-# LANGUAGE FunctionalDependencies #-}
2+{-# LANGUAGE DefaultSignatures #-}
3−{-# LANGUAGE LambdaCase #-}
4−{-# LANGUAGE MultiParamTypeClasses #-}
5−{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE OverloadedStrings #-}
6−{-# LANGUAGE TemplateHaskell #-}
4+{-# LANGUAGE TemplateHaskell #-}
7
5
8-- Module : Network.PagerDuty.Integration
6-- Module : Network.PagerDuty.Integration
9−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
7+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
10-- License : This Source Code Form is subject to the terms of
8-- License : This Source Code Form is subject to the terms of
11-- the Mozilla Public License, v. 2.0.
9-- the Mozilla Public License, v. 2.0.
12-- A copy of the MPL can be found in the LICENSE file or
10-- A copy of the MPL can be found in the LICENSE file or
@@ -38,57 +36,52 @@
38-- /See:/ <http://developer.pagerduty.com/documentation/integration/events>
36-- /See:/ <http://developer.pagerduty.com/documentation/integration/events>
39module Network.PagerDuty.Integration
37module Network.PagerDuty.Integration
40 (
38 (
41− -- * Sending events
39+ -- * Events
42 submit
40 submit
43− , submitWith
44
41
45 -- ** Trigger
42 -- ** Trigger
46 , Trigger
43 , Trigger
47 , trigger
44 , trigger
48− , client
45+ , tDescription
49− , clientUrl
46+ , tIncidentKey
47+ , tClient
48+ , tClientUrl
49+ , tDetails
50
50
51 -- ** Acknowledge
51 -- ** Acknowledge
52 , Acknowledge
52 , Acknowledge
53 , acknowledge
53 , acknowledge
54+ , aDescription
55+ , aDetails
54
56
55 -- ** Resolve
57 -- ** Resolve
56 , Resolve
58 , Resolve
57 , resolve
59 , resolve
58−
60+ , rDescription
59− -- * Fields
61+ , rDetails
60− , HasServiceKey (..)
61− , HasIncidentKey (..)
62− , HasDescription (..)
63− , HasDetails (..)
64
62
65 -- * Types
63 -- * Types
66− , Event (..)
64+ , Event
67− , _Trigger
65+ , AnyEvent (..)
68− , _Acknowledge
69− , _Resolve
70
66
71 , Response
67 , Response
72 , rsStatus
68 , rsStatus
73 , rsMessage
69 , rsMessage
74 , rsIncidentKey
70 , rsIncidentKey
75−
76− , Generic
77−
78− , module Network.PagerDuty.Types
79 ) where
71 ) where
80
72
81import Control.Lens
73import Control.Lens
82import Control.Monad.IO.Class
74import Control.Monad.IO.Class
83import Data.Aeson
75import Data.Aeson
76+import Data.Default.Class
84−import qualified Data.Aeson.KeyMap as Map
77+import qualified Data.HashMap.Strict as Map
85−import Data.Text (Text)
78+import Data.Monoid
79+import Data.Text (Text)
86−import Network.HTTP.Client (Manager)
80+import Network.HTTP.Client (Manager)
87−import qualified Network.HTTP.Client as Client
81+import qualified Network.HTTP.Client as Client
88−import Network.PagerDuty.Internal.IO
82+import Network.PagerDuty.IO
89−import Network.PagerDuty.Internal.TH
83+import Network.PagerDuty.TH
90−import Network.PagerDuty.Internal.Types
84+import Network.PagerDuty.Types
91−import Network.PagerDuty.Types hiding (description, message)
92
85
93data Response = Response
86data Response = Response
94 { _rsStatus :: Text
87 { _rsStatus :: Text
@@ -107,161 +100,128 @@ makeLens "_rsMessage" ''Response
107-- | The key of the incident that will be affected by the request.
100-- | The key of the incident that will be affected by the request.
108makeLens "_rsIncidentKey" ''Response
101makeLens "_rsIncidentKey" ''Response
109
102
110−class HasServiceKey s a | s -> a where
103+class Event a where
111− -- | The GUID of one of your "Generic API" services. This is the "service key"
104+ eventType :: a -> Text
112− -- listed on a Generic API's service detail page.
105+ eventPayload :: a -> Object
113− serviceKey :: Lens' s a
114−
115−class HasIncidentKey s a | s -> a where
116− -- | Identifies the incident to which this trigger event should be applied.
117− -- If there's no open (i.e. unresolved) incident with this key, a new one
118− -- will be created. If there's already an open incident with a matching key,
119− -- this event will be appended to that incident's log. The event key provides
120− -- an easy way to "de-dup" problem reports. If this field isn't provided,
121− -- PagerDuty will automatically open a new incident with a unique key.
122− incidentKey :: Lens' s a
123−
124−class HasDescription s a | s -> a where
125− -- | A short description of the problem that led to this trigger.
126− -- This field (or a truncated version) will be used when generating phone
127− -- calls, SMS messages and alert emails. It will also appear on the incidents
128− -- tables in the PagerDuty UI. The maximum length is 1024 characters.
129− description :: Lens' s a
130−
131−class HasDetails s a | s -> a where
132− -- | An arbitrary JSON object containing any data you'd like included
133− -- in the incident log.
134− details :: Lens' s a
135−
136−data Trigger = Trigger'
137− { _tServiceKey' :: ServiceKey
138− , _tIncidentKey' :: IncidentKey
139− , _tDescription' :: Text
140− , _tDetails' :: Maybe Object
141− , _tClient' :: Maybe Text
142− , _tClientUrl' :: Maybe Text
143− } deriving (Eq, Show)
144
106
145−deriveRecord ''Trigger
107+ default eventPayload :: ToJSON a => a -> Object
108+ eventPayload x = let Object o = toJSON x in o
146
109
147−instance HasServiceKey Trigger ServiceKey where serviceKey = tServiceKey'
110+data AnyEvent where
148−instance HasIncidentKey Trigger IncidentKey where incidentKey = tIncidentKey'
111+ Event :: Event a => a -> AnyEvent
149−instance HasDescription Trigger Text where description = tDescription'
150−instance HasDetails Trigger (Maybe Object) where details = tDetails'
151
112
152−-- | The name of the monitoring client that is triggering this event.
113+instance Event AnyEvent where
153−client :: Lens' Trigger (Maybe Text)
114+ eventType (Event x) = eventType x
154−client = tClient'
115+ eventPayload (Event x) = eventPayload x
155
116
156−-- | The URL of the monitoring client that is triggering this event.
157−clientUrl :: Lens' Trigger (Maybe Text)
158−clientUrl = tClientUrl'
159−
160−data Generic = Generic'
117+data Generic = Generic
161− { _gServiceKey' :: ServiceKey
118+ { _gServiceKey :: ServiceKey
119+ , _gDescription :: Maybe Text
162− , _gIncidentKey' :: IncidentKey
120+ , _gIncidentKey :: IncidentKey
163− , _gDescription' :: Maybe Text
164− , _gDetails' :: Maybe Object
121+ , _gDetails :: Object
165 } deriving (Eq, Show)
122 } deriving (Eq, Show)
166
123
167−deriveRecord ''Generic
124+deriveJSON ''Generic
168−
125+
169−instance HasServiceKey Generic ServiceKey where serviceKey = gServiceKey'
126+makeLens "_gDescription" ''Generic
170−instance HasIncidentKey Generic IncidentKey where incidentKey = gIncidentKey'
127+makeLens "_gDetails" ''Generic
171−instance HasDescription Generic (Maybe Text) where description = gDescription'
128+
172−instance HasDetails Generic (Maybe Object) where details = gDetails'
129+data Trigger = Trigger
173−
130+ { _tServiceKey :: ServiceKey
174−type Resolve = Generic
131+ , _tDescription :: Text
175−type Acknowledge = Generic
132+ , _tIncidentKey :: Maybe IncidentKey
176−
133+ , _tClient :: Maybe Text
177−data Event
134+ , _tClientUrl :: Maybe Text
178− = Trigger Trigger -- ^ /See:/ 'trigger'
135+ , _tDetails :: Object
179− | Acknowledge Generic -- ^ /See:/ 'acknowledge'
180− | Resolve Generic -- ^ /See:/ 'resolve'
181− deriving (Eq, Show)
136+ } deriving (Eq, Show)
182−
137+
183−makePrisms ''Event
138+deriveJSON ''Trigger
184−
139+
185−instance HasServiceKey Event ServiceKey where
140+instance Event Trigger where
186− serviceKey = lens f g
141+ eventType = const "trigger"
187− where
188− f (Trigger s) = _tServiceKey' s
189− f (Acknowledge s) = _gServiceKey' s
190− f (Resolve s) = _gServiceKey' s
191−
192− g (Trigger s) x = Trigger $ s { _tServiceKey' = x }
193− g (Acknowledge s) x = Acknowledge $ s { _gServiceKey' = x }
194− g (Resolve s) x = Resolve $ s { _gServiceKey' = x }
195−
196−instance HasIncidentKey Event IncidentKey where
197− incidentKey = lens f g
198− where
199− f (Trigger s) = _tIncidentKey' s
200− f (Acknowledge s) = _gIncidentKey' s
201− f (Resolve s) = _gIncidentKey' s
202−
203− g (Trigger s) x = Trigger $ s { _tIncidentKey' = x }
204− g (Acknowledge s) x = Acknowledge $ s { _gIncidentKey' = x }
205− g (Resolve s) x = Resolve $ s { _gIncidentKey' = x }
206−
207−instance HasDetails Event (Maybe Object) where
208− details = lens f g
209− where
210− f (Trigger s) = _tDetails' s
211− f (Acknowledge s) = _gDetails' s
212− f (Resolve s) = _gDetails' s
213−
214− g (Trigger s) x = Trigger $ s { _tDetails' = x }
215− g (Acknowledge s) x = Acknowledge $ s { _gDetails' = x }
216− g (Resolve s) x = Resolve $ s { _gDetails' = x }
217−
218−instance ToJSON Event where
219− toJSON = \case
220− Trigger x -> event "trigger" x
221− Acknowledge x -> event "acknowledge" x
222− Resolve x -> event "resolve" x
223− where
224− event k x =
225− case toJSON x of
226− Object o -> Object (Map.insert "event_type" (String k) o)
227− v -> v
228
142
229-- | Your monitoring tools should send PagerDuty a trigger event to report a new
143-- | Your monitoring tools should send PagerDuty a trigger event to report a new
230-- or ongoing problem. When PagerDuty receives a trigger event, it will either open
144-- or ongoing problem. When PagerDuty receives a trigger event, it will either open
231-- a new incident, or add a new trigger log entry to an existing incident,
145-- a new incident, or add a new trigger log entry to an existing incident,
232-- depending on the provided incident_key.
146-- depending on the provided incident_key.
233−trigger :: ServiceKey -- ^ 'serviceKey'
147+trigger :: ServiceKey
234− -> IncidentKey -- ^ 'incidentKey'
148+ -> Text -- ^ 'tDescription'
235− -> Text -- ^ 'description'
149+ -> Trigger
236− -> Event
237−trigger k i d =
150+trigger k d =
238− Trigger Trigger'
151+ Trigger
239− { _tServiceKey' = k
152+ { _tServiceKey = k
240− , _tDescription' = d
153+ , _tDescription = d
241− , _tIncidentKey' = i
154+ , _tIncidentKey = Nothing
242− , _tClient' = Nothing
155+ , _tClient = Nothing
243− , _tClientUrl' = Nothing
156+ , _tClientUrl = Nothing
244− , _tDetails' = Nothing
157+ , _tDetails = mempty
245 }
158 }
246
159
160+-- | A short description of the problem that led to this trigger.
161+-- This field (or a truncated version) will be used when generating phone
162+-- calls, SMS messages and alert emails. It will also appear on the incidents
163+-- tables in the PagerDuty UI. The maximum length is 1024 characters.
164+makeLens "_tDescription" ''Trigger
165+
166+-- | Identifies the incident to which this trigger event should be applied.
167+-- If there's no open (i.e. unresolved) incident with this key, a new one
168+-- will be created. If there's already an open incident with a matching key,
169+-- this event will be appended to that incident's log. The event key provides
170+-- an easy way to "de-dup" problem reports. If this field isn't provided,
171+-- PagerDuty will automatically open a new incident with a unique key.
172+makeLens "_tIncidentKey" ''Trigger
173+
174+-- | The name of the monitoring client that is triggering this event.
175+makeLens "_tClient" ''Trigger
176+
177+-- | The URL of the monitoring client that is triggering this event.
178+makeLens "_tClientUrl" ''Trigger
179+
180+-- | An arbitrary JSON object containing any data you'd like included
181+-- in the incident log.
182+makeLens "_tDetails" ''Trigger
183+
184+newtype Acknowledge = Acknowledge Generic
185+
186+deriveJSON ''Acknowledge
187+makePrisms ''Acknowledge
188+
189+instance Event Acknowledge where
190+ eventType = const "acknowledge"
191+
247-- | Acknowledge events cause the referenced incident to enter the acknowledged
192-- | Acknowledge events cause the referenced incident to enter the acknowledged
248-- state.
193-- state.
249--
194--
250-- While an incident is acknowledged, it won't generate any additional
195-- While an incident is acknowledged, it won't generate any additional
251-- notifications, even if it receives new trigger events. Your monitoring tools
196-- notifications, even if it receives new trigger events. Your monitoring tools
252−-- should send PagerDuty an acknowledge event when they know someone is
197+-- should send PagerDuty an acknowledge event when they know someone is presently
253−-- presently working on the problem.
198+-- working on the problem.
254−acknowledge :: ServiceKey -- ^ 'serviceKey'
199+acknowledge :: ServiceKey -> IncidentKey -> Acknowledge
255− -> IncidentKey -- ^ 'incidentKey'
256− -> Event
257acknowledge k i =
200acknowledge k i =
258− Acknowledge Generic'
201+ Acknowledge Generic
259− { _gServiceKey' = k
202+ { _gServiceKey = k
203+ , _gDescription = Nothing
260− , _gIncidentKey' = i
204+ , _gIncidentKey = i
261− , _gDescription' = Nothing
262− , _gDetails' = Nothing
205+ , _gDetails = mempty
263 }
206 }
264
207
208+-- | Text that will appear in the incident's log associated with this event.
209+aDescription :: Lens' Acknowledge (Maybe Text)
210+aDescription = _Acknowledge.gDescription
211+
212+-- | An arbitrary JSON object containing any data you'd like included
213+-- in the incident log.
214+aDetails :: Lens' Acknowledge Object
215+aDetails = _Acknowledge.gDetails
216+
217+newtype Resolve = Resolve Generic
218+
219+deriveJSON ''Resolve
220+makePrisms ''Resolve
221+
222+instance Event Resolve where
223+ eventType = const "acknowledge"
224+
265-- | Resolve events cause the referenced incident to enter the resolved state.
225-- | Resolve events cause the referenced incident to enter the resolved state.
266--
226--
267-- Once an incident is resolved, it won't generate any additional
227-- Once an incident is resolved, it won't generate any additional
@@ -269,30 +229,30 @@ acknowledge k i =
269-- incident won't re-open the incident. Instead, a new incident will be
229-- incident won't re-open the incident. Instead, a new incident will be
270-- created. Your monitoring tools should send PagerDuty a resolve event when the
230-- created. Your monitoring tools should send PagerDuty a resolve event when the
271-- problem that caused the initial trigger event has been fixed.
231-- problem that caused the initial trigger event has been fixed.
272−resolve :: ServiceKey -- ^ 'serviceKey'
232+resolve :: ServiceKey -> IncidentKey -> Resolve
273− -> IncidentKey -- ^ 'incidentKey'
274− -> Event
275resolve k i =
233resolve k i =
276− Resolve Generic'
234+ Resolve Generic
277− { _gServiceKey' = k
235+ { _gServiceKey = k
236+ , _gDescription = Nothing
278− , _gIncidentKey' = i
237+ , _gIncidentKey = i
279− , _gDescription' = Nothing
280− , _gDetails' = Nothing
238+ , _gDetails = mempty
281 }
239 }
282
240
241+-- | Text that will appear in the incident's log associated with this event.
242+rDescription :: Lens' Resolve (Maybe Text)
243+rDescription = _Resolve.gDescription
244+
245+-- | An arbitrary JSON object containing any data youd like included
246+-- in the incident log.
247+rDetails :: Lens' Resolve Object
248+rDetails = _Resolve.gDetails
249+
283-- | Send an event to the integration API.
250-- | Send an event to the integration API.
284−submit :: MonadIO m => Manager -> Event -> m (Either Error Response)
285−submit m = submitWith m None
286−
287−-- | /See:/ 'submit'
288−submitWith :: MonadIO m
289− => Manager
290− -> Logger
291− -> Event
292− -> m (Either Error Response)
251+submit :: (MonadIO m, Event a) => Manager -> a -> m (Either Error Response)
293−submitWith m l e = request m l e $
252+submit m x = request m payload $ def
294− Client.defaultRequest
295− { Client.host = "events.pagerduty.com"
253+ { Client.host = "events.pagerduty.com"
296− , Client.path = "/generic/2010-04-15/create_event.json"
254+ , Client.path = "/generic/2010-04-15/create_event.json"
297− , Client.method = "POST"
298− }
255+ }
256+ where
257+ payload = Object $
258+ Map.insert "event_type" (String (eventType x)) (eventPayload x)
src/Network/PagerDuty/Internal/IO.hsdeleted−76
@@ -1,76 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−{-# LANGUAGE ScopedTypeVariables #-}
3−
4−-- Module : Network.PagerDuty.Internal.IO
5−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
6−-- License : This Source Code Form is subject to the terms of
7−-- the Mozilla Public License, v. 2.0.
8−-- A copy of the MPL can be found in the LICENSE file or
9−-- you can obtain it at http://mozilla.org/MPL/2.0/.
10−-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
11−-- Stability : experimental
12−-- Portability : non-portable (GHC extensions)
13−
14−module Network.PagerDuty.Internal.IO where
15−
16−import Control.Monad
17−import Control.Monad.IO.Class
18−import Data.Aeson hiding (Error)
19−import qualified Data.ByteString.Lazy as LBS
20−import Data.Monoid
21−import qualified Data.Text as Text
22−import Network.HTTP.Client (Manager, httpLbs)
23−import qualified Network.HTTP.Client as Client
24−import Network.HTTP.Types
25−import Network.PagerDuty.Internal.Types
26−
27−request :: (MonadIO m, ToJSON a, FromJSON b)
28− => Manager
29− -> Logger
30− -> a
31− -> Client.Request
32− -> m (Either Error b)
33−request m l x rq = msg >> liftIO (httpLbs raw m) >>= response l
34− where
35− msg = debug l ("[Raw Request]\n" <> Text.pack (show raw))
36−
37− raw = rq
38− { Client.secure = True
39− , Client.port = 443
40− , Client.requestHeaders = headers
41− , Client.requestBody = Client.RequestBodyLBS (encode x)
42− }
43−
44− headers =
45− [ ("Content-Type", "application/json")
46− , ("Accept", "application/json")
47− ]
48−
49−response :: forall m b. (MonadIO m, FromJSON b)
50− => Logger
51− -> Client.Response LBS.ByteString
52− -> m (Either Error b)
53−response l rs = case statusCode (Client.responseStatus rs) of
54− 200 -> success
55− 201 -> success
56− 400 -> failure
57− 500 -> failure
58− n -> return . Left $ unhandled n
59− where
60− success = maybe (Left unknown) Right `liftM` parse
61− failure = maybe (Left unknown) Left `liftM` parse
62−
63− unhandled n = Internal $
64− "PagerDuty returned unhandled status code: "
65− <> Text.pack (show n)
66−
67− unknown = Internal $
68− "Unable to parse response into a PagerDuty API compatible type: "
69− <> Text.pack (show body)
70−
71− parse :: FromJSON a => m (Maybe a)
72− parse = msg >> return (decode body)
73−
74− msg = debug l ("[Raw Response]\n" <> Text.pack (show rs))
75−
76− body = Client.responseBody rs
src/Network/PagerDuty/Internal/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
1+-- Module : Network.PagerDuty.Options
2−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
2+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
3-- License : This Source Code Form is subject to the terms of
3-- License : This Source Code Form is subject to the terms of
4-- the Mozilla Public License, v. 2.0.
4-- the Mozilla Public License, v. 2.0.
5-- A copy of the MPL can be found in the LICENSE file or
5-- A copy of the MPL can be found in the LICENSE file or
@@ -8,15 +8,15 @@
8-- Stability : experimental
8-- Stability : experimental
9-- Portability : non-portable (GHC extensions)
9-- Portability : non-portable (GHC extensions)
10
10
11−module Network.PagerDuty.Internal.Options
11+module Network.PagerDuty.Options
12 ( dropped
12 ( dropped
13 , hyphenated
13 , hyphenated
14 , underscored
14 , underscored
15 ) where
15 ) where
16
16
17−import Data.Aeson.Types
17+import Data.Aeson.Types
18−import Data.Char
18+import Data.Char
19−import Data.List
19+import Data.List
20
20
21dropped :: Int -> Options -> Options
21dropped :: Int -> Options -> Options
22dropped n o = o
22dropped n o = o
src/Network/PagerDuty/Internal/Query.hs → src/Network/PagerDuty/Query.hsrenamed+19−21
@@ -1,13 +1,12 @@
1{-# LANGUAGE ConstraintKinds #-}
1{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE DefaultSignatures #-}
2{-# LANGUAGE DefaultSignatures #-}
3−{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE GADTs #-}
3{-# LANGUAGE GADTs #-}
5{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE TupleSections #-}
6{-# LANGUAGE TupleSections #-}
8
7
9−-- Module : Network.PagerDuty.Internal.Query
8+-- Module : Network.PagerDuty.Query
10−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
9+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
11-- License : This Source Code Form is subject to the terms of
10-- License : This Source Code Form is subject to the terms of
12-- the Mozilla Public License, v. 2.0.
11-- the Mozilla Public License, v. 2.0.
13-- A copy of the MPL can be found in the LICENSE file or
12-- A copy of the MPL can be found in the LICENSE file or
@@ -16,7 +15,7 @@
16-- Stability : experimental
15-- Stability : experimental
17-- Portability : non-portable (GHC extensions)
16-- Portability : non-portable (GHC extensions)
18
17
19−module Network.PagerDuty.Internal.Query
18+module Network.PagerDuty.Query
20 ( QueryValues (..)
19 ( QueryValues (..)
21 , gquery
20 , gquery
22 , gqueryWith
21 , gqueryWith
@@ -24,17 +23,17 @@ module Network.PagerDuty.Internal.Query
24
23
25import Data.Aeson.Types
24import Data.Aeson.Types
26import Data.Bifunctor
25import Data.Bifunctor
27−import Data.ByteString (ByteString)
26+import Data.ByteString (ByteString)
28−import qualified Data.ByteString.Char8 as BS
27+import qualified Data.ByteString.Char8 as BS
29import Data.ByteString.Conversion
28import Data.ByteString.Conversion
30−import Data.Function (on)
29+import Data.Function (on)
31−import Data.List (groupBy)
30+import Data.List (groupBy)
32−import Data.Monoid ((<>))
31+import Data.Monoid ((<>))
33−import Data.Text (Text)
32+import Data.Text (Text)
34−import qualified Data.Text.Encoding as Text
33+import qualified Data.Text.Encoding as Text
35import Generics.SOP
34import Generics.SOP
36import Network.HTTP.Types
35import Network.HTTP.Types
37−import Network.PagerDuty.Internal.Options
36+import Network.PagerDuty.Options
38
37
39class QueryValues a where
38class QueryValues a where
40 queryValues :: a -> [ByteString]
39 queryValues :: a -> [ByteString]
@@ -59,15 +58,14 @@ gqueryWith :: forall a. (Generic a, HasDatatypeInfo a, All2 QueryValues (Code a)
59 -> a
58 -> a
60 -> Query
59 -> Query
61gqueryWith o a = case datatypeInfo (Proxy :: Proxy a) of
60gqueryWith o a = case datatypeInfo (Proxy :: Proxy a) of
62− ADT _ _ cs _ -> go cs (from a)
61+ ADT _ _ cs -> go cs (from a)
63− Newtype _ _ c -> go (c :* Nil) (from a)
62+ Newtype _ _ c -> go (c :* Nil) (from a)
64 where
63 where
65− go :: (All2 QueryValues xss, SListI xss)
64+ go :: (All2 QueryValues xss, SingI xss)
66 => NP ConstructorInfo xss
65 => NP ConstructorInfo xss
67 -> SOP I xss
66 -> SOP I xss
68 -> Query
67 -> 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
71
69
72 group :: [(ByteString, ByteString)] -> Query
70 group :: [(ByteString, ByteString)] -> Query
73 group = concatMap f . groupBy ((==) `on` fst)
71 group = concatMap f . groupBy ((==) `on` fst)
@@ -84,7 +82,7 @@ gctor :: All QueryValues xs
84gctor o (Constructor n) args =
82gctor o (Constructor n) args =
85 K . concat . hcollapse $ hcliftA p (K . map (k,) . queryValues . unI) args
83 K . concat . hcollapse $ hcliftA p (K . map (k,) . queryValues . unI) args
86 where
84 where
87− k = BS.pack (constructorTagModifier o n)
85+ k = BS.pack $ (constructorTagModifier o) n
88
86
89gctor o (Record _ ns) args =
87gctor o (Record _ ns) args =
90 K . concat . hcollapse $ hcliftA2 p (gfield o) ns args
88 K . concat . hcollapse $ hcliftA2 p (gfield o) ns args
@@ -92,9 +90,9 @@ gctor o (Record _ ns) args =
92gctor o (Infix n _ _) (x :* y :* Nil) =
90gctor o (Infix n _ _) (x :* y :* Nil) =
93 K $ map (k,) (queryValues (unI x) ++ queryValues (unI y))
91 K $ map (k,) (queryValues (unI x) ++ queryValues (unI y))
94 where
92 where
95− k = BS.pack (constructorTagModifier o n)
93+ k = BS.pack $ (constructorTagModifier o) n
96
94
97−gctor _ Infix{} _ =
95+gctor _ (Infix _ _ _) _ =
98 error "Network.PagerDuty.Generics.inaccessible"
96 error "Network.PagerDuty.Generics.inaccessible"
99
97
100gfield :: QueryValues a
98gfield :: QueryValues a
@@ -105,7 +103,7 @@ gfield :: QueryValues a
105gfield o (FieldInfo f) (I a) =
103gfield o (FieldInfo f) (I a) =
106 K $ map (k,) (queryValues a)
104 K $ map (k,) (queryValues a)
107 where
105 where
108− k = BS.pack (fieldLabelModifier o f)
106+ k = BS.pack $ (fieldLabelModifier o) f
109
107
110p :: Proxy QueryValues
108p :: Proxy QueryValues
111p = Proxy
109p = Proxy
src/Network/PagerDuty/REST.hs+30−42
@@ -2,7 +2,7 @@
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3
3
4-- Module : Network.PagerDuty.REST
4-- Module : Network.PagerDuty.REST
5−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
5+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
6-- License : This Source Code Form is subject to the terms of
6-- License : This Source Code Form is subject to the terms of
7-- the Mozilla Public License, v. 2.0.
7-- the Mozilla Public License, v. 2.0.
8-- A copy of the MPL can be found in the LICENSE file or
8-- A copy of the MPL can be found in the LICENSE file or
@@ -15,11 +15,7 @@ module Network.PagerDuty.REST
15 (
15 (
16 -- * Sending requests
16 -- * Sending requests
17 send
17 send
18− , sendWith
19 , paginate
18 , paginate
20− , paginateWith
21−
22− , module Network.PagerDuty.Types
23 ) where
19 ) where
24
20
25import Control.Applicative
21import Control.Applicative
@@ -27,69 +23,61 @@ import Control.Lens
27import Control.Monad
23import Control.Monad
28import Control.Monad.IO.Class
24import Control.Monad.IO.Class
29import Control.Monad.Trans
25import Control.Monad.Trans
30−import Data.Aeson (FromJSON)
26+import Data.Aeson (FromJSON)
31import Data.Conduit
27import Data.Conduit
28+import Data.Default.Class
32import Data.Monoid
29import Data.Monoid
33−import Network.HTTP.Client (Manager)
30+import Network.HTTP.Client (Manager)
34−import qualified Network.HTTP.Client as Client
31+import qualified Network.HTTP.Client as Client
35import Network.HTTP.Types
32import Network.HTTP.Types
36−import Network.PagerDuty.Internal.IO
33+import Network.PagerDuty.IO
37−import Network.PagerDuty.Internal.Types
38import Network.PagerDuty.Types
34import Network.PagerDuty.Types
39
35
36+-- Make the type names consistent, for example:
37+-- Suffix with *Details or *Info for results
38+-- No suffix for requests if necessary
39+
40-- FIXME: verify correct actions are all paginated
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
41
44−-- | /See:/ 'sendWith'
42+-- FIXME: Ensure requesterid parameter is always first
43+
45send :: (MonadIO m, FromJSON b)
44send :: (MonadIO m, FromJSON b)
46− => SubDomain
45+ => Auth s
47− -> Auth s
46+ -> SubDomain
48 -> Manager
47 -> Manager
49 -> Request a s b
48 -> Request a s b
50 -> m (Either Error b)
49 -> m (Either Error b)
51−send d a m = sendWith (prod d a m)
50+send a s m = liftM (fmap fst) . http a s m
52
51
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
58−
59−-- | /See:/ 'paginateWith'
60paginate :: (MonadIO m, Paginate a, FromJSON b)
52paginate :: (MonadIO m, Paginate a, FromJSON b)
61− => SubDomain
53+ => Auth s
62− -> Auth s
54+ -> SubDomain
63 -> Manager
55 -> Manager
64 -> Request a s b
56 -> Request a s b
65 -> Source m (Either Error b)
57 -> Source m (Either Error b)
66−paginate d a m = paginateWith (prod d a m)
58+paginate a d m = go
67−
68−paginateWith :: (MonadIO m, Paginate a, FromJSON b)
69− => Env s
70− -> Request a s b
71− -> Source m (Either Error b)
72−paginateWith e = go
73 where
59 where
74 go rq = do
60 go rq = do
75− rs <- lift (http e rq)
61+ rs <- lift (http a d m rq)
76− yield (_pgItem <$> rs)
62+ yield (fst <$> rs)
77 either (const (return ()))
63 either (const (return ()))
78− (maybe (return ()) go . next rq . _pgPager)
64+ (maybe (return ()) go . next rq . snd)
79 rs
65 rs
80
66
81http :: (MonadIO m, FromJSON b)
67http :: (MonadIO m, FromJSON b)
82− => Env s
68+ => Auth s
69+ -> SubDomain
70+ -> Manager
83 -> Request a s b
71 -> Request a s b
84− -> m (Either Error (Page b))
72+ -> m (Either Error (b, Maybe Pager))
85−http e rq = request (e ^. envManager) (e ^. envLogger) rq $ raw
73+http a (SubDomain h) m rq = request m rq $ raw
86− { Client.host = domain (e ^. envDomain)
74+ { Client.host = h
87 , Client.path = renderPath (rq ^. path)
75 , Client.path = renderPath (rq ^. path)
88 , Client.queryString = renderQuery False (rq ^. query)
76 , Client.queryString = renderQuery False (rq ^. query)
89 }
77 }
90 where
78 where
91− raw = case e ^. envAuth of
79+ raw = case a of
92− AuthBasic u p -> Client.applyBasicAuth u p Client.defaultRequest
80+ AuthBasic u p -> Client.applyBasicAuth u p def
93− AuthToken t -> Client.defaultRequest
81+ AuthToken t -> def
94 { Client.requestHeaders = [("Authorization", "Token token=" <> t)]
82 { Client.requestHeaders = [("Authorization", "Token token=" <> t)]
95 }
83 }
src/Network/PagerDuty/REST/Alerts.hs+25−25
@@ -4,7 +4,7 @@
4{-# LANGUAGE TypeFamilies #-}
4{-# LANGUAGE TypeFamilies #-}
5
5
6-- Module : Network.PagerDuty.REST.Alerts
6-- 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>
8-- License : This Source Code Form is subject to the terms of
8-- License : This Source Code Form is subject to the terms of
9-- the Mozilla Public License, v. 2.0.
9-- the Mozilla Public License, v. 2.0.
10-- A copy of the MPL can be found in the LICENSE file or
10-- A copy of the MPL can be found in the LICENSE file or
@@ -43,12 +43,12 @@ module Network.PagerDuty.REST.Alerts
43 , alertAddress
43 , alertAddress
44 ) where
44 ) where
45
45
46−import Control.Lens hiding (Empty)
46+import Control.Lens
47−import Data.Aeson.Lens
47+import Data.Aeson.Lens
48−import Data.Time
48+import Data.Time
49−import Network.PagerDuty.Internal.TH
50−import Network.PagerDuty.Internal.Types
51−import Network.PagerDuty.REST.Users (User)
49+import Network.PagerDuty.REST.Users (User)
50+import Network.PagerDuty.TH
51+import Network.PagerDuty.Types
52
52
53alerts :: Path
53alerts :: Path
54alerts = "alerts"
54alerts = "alerts"
@@ -83,6 +83,24 @@ instance Paginate ListAlerts
83
83
84queryRequest ''ListAlerts
84queryRequest ''ListAlerts
85
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"
103+
86-- | The start of the date range over which you want to search.
104-- | The start of the date range over which you want to search.
87laSince :: Lens' (Request ListAlerts s b) UTCTime
105laSince :: Lens' (Request ListAlerts s b) UTCTime
88laSince = upd.laSince'._D
106laSince = upd.laSince'._D
@@ -103,21 +121,3 @@ laFilter = upd.laFilter'
103-- /Default:/ account time zone.
121-- /Default:/ account time zone.
104laTimeZone :: Lens' (Request ListAlerts s b) (Maybe TimeZone)
122laTimeZone :: Lens' (Request ListAlerts s b) (Maybe TimeZone)
105laTimeZone = upd.laTimeZone'.mapping _TZ
123laTimeZone = 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+21−21
@@ -1,13 +1,10 @@
1−{-# LANGUAGE DataKinds #-}
1+{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE ExtendedDefaultRules #-}
3−{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE TemplateHaskell #-}
3+{-# LANGUAGE TemplateHaskell #-}
5−{-# LANGUAGE TypeFamilies #-}
4+{-# LANGUAGE TypeFamilies #-}
6−
7−{-# OPTIONS_GHC -fno-warn-type-defaults #-}
8
5
9-- Module : Network.PagerDuty.REST.EscalationPolicies
6-- 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>
11-- License : This Source Code Form is subject to the terms of
8-- License : This Source Code Form is subject to the terms of
12-- the Mozilla Public License, v. 2.0.
9-- the Mozilla Public License, v. 2.0.
13-- A copy of the MPL can be found in the LICENSE file or
10-- A copy of the MPL can be found in the LICENSE file or
@@ -60,23 +57,26 @@ module Network.PagerDuty.REST.EscalationPolicies
60 , pServices
57 , pServices
61 ) where
58 ) where
62
59
63−import Control.Lens hiding (Empty)
60+import Control.Applicative ((<$>))
61+import Control.Lens
62+import Data.Aeson
64import Data.Aeson.Lens
63import Data.Aeson.Lens
64+import qualified Data.HashMap.Strict as Map
65−import Data.Text (Text)
65+import Data.Text (Text)
66+import qualified Data.Text as Text
66import Network.HTTP.Types
67import Network.HTTP.Types
67−import Network.PagerDuty.Internal.TH
68+import Network.PagerDuty.REST.Services (Service)
68−import Network.PagerDuty.Internal.Types
69−import Network.PagerDuty.REST.Services (Service)
70−
71−import Network.PagerDuty.REST.EscalationPolicies.EscalationRules
69+import Network.PagerDuty.REST.Users
70+import Network.PagerDuty.TH
71+import Network.PagerDuty.Types
72
72
73−default (Path)
73+import Network.PagerDuty.REST.EscalationPolicies.EscalationRules
74
74
75policies :: Path
75policies :: Path
76policies = "escalation_policies"
76policies = "escalation_policies"
77
77
78data Policy = Policy
78data Policy = Policy
79− { _pId :: EscalationPolicyId
79+ { _pId :: PolicyId
80 , _pName :: Text
80 , _pName :: Text
81 , _pNumLoops :: !Int
81 , _pNumLoops :: !Int
82 , _pRules :: [Rule]
82 , _pRules :: [Rule]
@@ -170,7 +170,7 @@ cpEscalationRules = upd.cpEscalationRules'
170-- @POST \/escalation_policies@
170-- @POST \/escalation_policies@
171--
171--
172-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/create>
172-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/create>
173−createPolicy :: EscalationPolicyId
173+createPolicy :: PolicyId
174 -> Text -- ^ 'creName'
174 -> Text -- ^ 'creName'
175 -> [Rule] -- ^ 'creEscalationRules'
175 -> [Rule] -- ^ 'creEscalationRules'
176 -> Request CreatePolicy s Policy
176 -> Request CreatePolicy s Policy
@@ -189,7 +189,7 @@ createPolicy i n rs =
189-- @GET \/escalation_policies\/\:id@
189-- @GET \/escalation_policies\/\:id@
190--
190--
191-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/show>
191-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/show>
192−getPolicy :: EscalationPolicyId -> Request Empty s Policy
192+getPolicy :: PolicyId -> Request Empty s Policy
193getPolicy i = empty & path .~ policies % i & unwrap .~ key "escalation_policy"
193getPolicy i = empty & path .~ policies % i & unwrap .~ key "escalation_policy"
194
194
195data UpdatePolicy = UpdatePolicy
195data UpdatePolicy = UpdatePolicy
@@ -223,7 +223,7 @@ upEscalationRules = upd.upEscalationRules'
223-- @PUT \/escalation_policies\/\:id@
223-- @PUT \/escalation_policies\/\:id@
224--
224--
225-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/update>
225-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/update>
226−updatePolicy :: EscalationPolicyId -> Request UpdatePolicy s Policy
226+updatePolicy :: PolicyId -> Request UpdatePolicy s Policy
227updatePolicy i =
227updatePolicy i =
228 mk UpdatePolicy
228 mk UpdatePolicy
229 { _upName' = Nothing
229 { _upName' = Nothing
@@ -240,5 +240,5 @@ updatePolicy i =
240-- @DELETE \/escalation_policies\/\:id@
240-- @DELETE \/escalation_policies\/\:id@
241--
241--
242-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/delete>
242-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/delete>
243−deletePolicy :: EscalationPolicyId -> Request Empty s Empty
243+deletePolicy :: PolicyId -> Request Empty s Empty
244deletePolicy i = empty & meth .~ DELETE & path .~ policies % i
244deletePolicy i = empty & meth .~ DELETE & path .~ policies % i
src/Network/PagerDuty/REST/EscalationPolicies/EscalationRules.hs+20−21
@@ -1,12 +1,12 @@
1−{-# LANGUAGE ExtendedDefaultRules #-}
1+{-# LANGUAGE ExtendedDefaultRules #-}
2−{-# LANGUAGE FlexibleInstances #-}
2+{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE TemplateHaskell #-}
4+{-# LANGUAGE TemplateHaskell #-}
5
5
6{-# OPTIONS_GHC -fno-warn-type-defaults #-}
6{-# OPTIONS_GHC -fno-warn-type-defaults #-}
7
7
8-- Module : Network.PagerDuty.REST.EscalationPolicies.EscalationRules
8-- Module : Network.PagerDuty.REST.EscalationPolicies.EscalationRules
9−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
9+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
10-- License : This Source Code Form is subject to the terms of
10-- License : This Source Code Form is subject to the terms of
11-- the Mozilla Public License, v. 2.0.
11-- the Mozilla Public License, v. 2.0.
12-- A copy of the MPL can be found in the LICENSE file or
12-- A copy of the MPL can be found in the LICENSE file or
@@ -64,21 +64,20 @@ module Network.PagerDuty.REST.EscalationPolicies.EscalationRules
64 , rTargets
64 , rTargets
65 ) where
65 ) where
66
66
67−import Control.Applicative ((<$>))
67+import Control.Applicative ((<$>))
68−import Control.Lens hiding ((.=))
68+import Control.Lens hiding ((.=))
69import Data.Aeson
69import Data.Aeson
70+import Data.ByteString.Builder (Builder)
70−import qualified Data.Aeson.KeyMap as Map
71+import qualified Data.HashMap.Strict as Map
71−import Data.Text (Text)
72+import Data.Text (Text)
72import Network.HTTP.Types
73import Network.HTTP.Types
73−import Network.PagerDuty.Internal.TH
74−import Network.PagerDuty.Internal.Types
75import Network.PagerDuty.REST.Users
74import Network.PagerDuty.REST.Users
75+import Network.PagerDuty.TH
76+import Network.PagerDuty.Types
76
77
77default (Path)
78default (Path)
78
79
79−-- FIXME: The lenses here need to operate over (Request x s b) using upd
80−
81−rules :: EscalationPolicyId -> Path
80+rules :: PolicyId -> Path
82rules p = "escalation_policies" % p % "escalation_rules"
81rules p = "escalation_policies" % p % "escalation_rules"
83
82
84data TargetType
83data TargetType
@@ -138,7 +137,7 @@ instance ToJSON Target where
138 TUser u -> ("user", toJSON u)
137 TUser u -> ("user", toJSON u)
139
138
140data Rule = Rule
139data Rule = Rule
141− { _rId :: EscalationRuleId
140+ { _rId :: RuleId
142 , _rEscalationDelayInMinutes :: !Int
141 , _rEscalationDelayInMinutes :: !Int
143 , _rTargets :: [Target]
142 , _rTargets :: [Target]
144 } deriving (Eq, Show)
143 } deriving (Eq, Show)
@@ -159,7 +158,7 @@ makeLens "_rTargets" ''Rule
159-- @GET \/escalation_policies\/\:escalation_policy_id\/escalation_rules@
158-- @GET \/escalation_policies\/\:escalation_policy_id\/escalation_rules@
160--
159--
161-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/escalation_rules/list>
160-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/escalation_rules/list>
162−listRules :: EscalationPolicyId -> Request Empty s [Rule]
161+listRules :: PolicyId -> Request Empty s [Rule]
163listRules p = empty & path .~ rules p
162listRules p = empty & path .~ rules p
164
163
165-- | Show the escalation rule for an existing escalation policy.
164-- | Show the escalation rule for an existing escalation policy.
@@ -167,7 +166,7 @@ listRules p = empty & path .~ rules p
167-- @GET \/escalation_policies\/:escalation_policy_id\/escalation_rules\/\:id@
166-- @GET \/escalation_policies\/:escalation_policy_id\/escalation_rules\/\:id@
168--
167--
169-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/escalation_rules/show>
168-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/escalation_rules/show>
170−getRule :: EscalationPolicyId -> EscalationRuleId -> Request Empty s Rule
169+getRule :: PolicyId -> RuleId -> Request Empty s Rule
171getRule p r = empty & path .~ rules p % r
170getRule p r = empty & path .~ rules p % r
172
171
173data CreateRule = CreateRule
172data CreateRule = CreateRule
@@ -195,7 +194,7 @@ makeLens "_crTargets" ''CreateRule
195-- @POST \/escalation_policies\/\:escalation_policy_id\/escalation_rules@
194-- @POST \/escalation_policies\/\:escalation_policy_id\/escalation_rules@
196--
195--
197-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/escalation_rules/create>
196-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/escalation_rules/create>
198−createRule :: EscalationPolicyId
197+createRule :: PolicyId
199 -> Int -- ^ 'crEscalationDelayInMinutes'
198 -> Int -- ^ 'crEscalationDelayInMinutes'
200 -> [TargetId] -- ^ 'crTargets'
199 -> [TargetId] -- ^ 'crTargets'
201 -> Request CreateRule s Rule
200 -> Request CreateRule s Rule
@@ -226,7 +225,7 @@ makeLens "_urEscalationRules" ''UpdateRules
226-- @PUT \/escalation_policies\/\:escalation_policy_id\/escalation_rules@
225-- @PUT \/escalation_policies\/\:escalation_policy_id\/escalation_rules@
227--
226--
228-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/escalation_rules/multi_update>
227-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/escalation_rules/multi_update>
229−updateRules :: EscalationPolicyId
228+updateRules :: PolicyId
230 -> [TargetId] -- ^ 'urEscalationRules'
229 -> [TargetId] -- ^ 'urEscalationRules'
231 -> Request UpdateRules s [Rule]
230 -> Request UpdateRules s [Rule]
232updateRules p rs =
231updateRules p rs =
@@ -259,7 +258,7 @@ makeLens "_urTargets" ''UpdateRule
259-- @PUT \/escalation_policies\/\:escalation_policy_id\/escalation_rules\/\:id@
258-- @PUT \/escalation_policies\/\:escalation_policy_id\/escalation_rules\/\:id@
260--
259--
261-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/escalation_rules/update>
260-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/escalation_rules/update>
262−updateRule :: EscalationPolicyId -> EscalationRuleId -> Request UpdateRule s Rule
261+updateRule :: PolicyId -> RuleId -> Request UpdateRule s Rule
263updateRule p r =
262updateRule p r =
264 mk UpdateRule
263 mk UpdateRule
265 { _urEscalationDelayInMinutes = Nothing
264 { _urEscalationDelayInMinutes = Nothing
@@ -273,5 +272,5 @@ updateRule p r =
273-- @DELETE \/escalation_policies\/\:escalation_policy_id\/escalation_rules\/\:id@
272-- @DELETE \/escalation_policies\/\:escalation_policy_id\/escalation_rules\/\:id@
274--
273--
275-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/escalation_rules/delete>
274-- /See:/ <http://developer.pagerduty.com/documentation/rest/escalation_policies/escalation_rules/delete>
276−deleteRule :: EscalationPolicyId -> EscalationRuleId -> Request Empty s Empty
275+deleteRule :: PolicyId -> RuleId -> Request Empty s Empty
277deleteRule p r = empty & meth .~ DELETE & path .~ rules p % r
276deleteRule p r = empty & meth .~ DELETE & path .~ rules p % r
src/Network/PagerDuty/REST/Incidents.hs+122−135
@@ -2,7 +2,6 @@
2{-# LANGUAGE ExtendedDefaultRules #-}
2{-# LANGUAGE ExtendedDefaultRules #-}
3{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5−{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE OverloadedStrings #-}
7{-# LANGUAGE TemplateHaskell #-}
6{-# LANGUAGE TemplateHaskell #-}
8{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE TypeFamilies #-}
@@ -10,7 +9,7 @@
10{-# OPTIONS_GHC -fno-warn-type-defaults #-}
9{-# OPTIONS_GHC -fno-warn-type-defaults #-}
11
10
12-- Module : Network.PagerDuty.REST.Incidents
11-- Module : Network.PagerDuty.REST.Incidents
13−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
12+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
14-- License : This Source Code Form is subject to the terms of
13-- License : This Source Code Form is subject to the terms of
15-- the Mozilla Public License, v. 2.0.
14-- the Mozilla Public License, v. 2.0.
16-- A copy of the MPL can be found in the LICENSE file or
15-- A copy of the MPL can be found in the LICENSE file or
@@ -125,25 +124,35 @@ module Network.PagerDuty.REST.Incidents
125 , aAt
124 , aAt
126 , aObject
125 , aObject
127
126
128− , HasIncident (..)
129 , Incident
127 , Incident
128+ , iIncidentNumber
129+ , iStatus
130+ , iCreatedOn
131+ , iHtmlUrl
132+ , iIncidentKey
133+ , iService
134+ , iEscalationPolicy
135+ , iAssignedTo
136+ , iAcknowledgers
137+ , iLastStatusChangeBy
138+ , iLastStatusChangeOn
139+ , iTriggerSummaryData
140+ , iTriggerDetailsHtmlUrl
130 ) where
141 ) where
131
142
132−import Control.Applicative hiding (empty)
143+import Control.Applicative hiding (empty)
133−import Control.Lens hiding (Empty)
144+import Control.Lens
134import Data.Aeson
145import Data.Aeson
135−import Data.ByteString.Conversion (ToByteString (..),
146+import Data.ByteString.Conversion (ToByteString(..), toByteString')
136− toByteString')
137−import Data.Default.Class
147+import Data.Default
138−import Data.Maybe
139−import Data.Monoid hiding (All)
148+import Data.Monoid hiding (All)
140−import Data.Text (Text)
149+import Data.Text (Text)
141−import qualified Data.Text.Encoding as Text
150+import qualified Data.Text.Encoding as Text
142import Data.Time
151import Data.Time
143import Network.HTTP.Types
152import Network.HTTP.Types
144−import Network.PagerDuty.Internal.Query
153+import Network.PagerDuty.Query
145−import Network.PagerDuty.Internal.TH
154+import Network.PagerDuty.TH
146−import Network.PagerDuty.Internal.Types
155+import Network.PagerDuty.Types
147
156
148default (Path)
157default (Path)
149
158
@@ -189,18 +198,18 @@ data IncidentStatus
189 deriving (Eq, Show)
198 deriving (Eq, Show)
190
199
191instance ToByteString IncidentStatus where
200instance ToByteString IncidentStatus where
192− builder = \case
193− ITriggered -> "triggered"
201+ builder ITriggered = "triggered"
194− IAcknowledged -> "acknowledged"
202+ builder IAcknowledged = "acknowledged"
195− IResolved -> "resolved"
203+ builder IResolved = "resolved"
196− IOther t -> builder t
204+ builder (IOther t) = builder t
197
205
198instance FromJSON IncidentStatus where
206instance FromJSON IncidentStatus where
199− parseJSON = withText "status" $ pure . \case
207+ parseJSON = withText "status" $ \t ->
208+ return $ case t of
200− "triggered" -> ITriggered
209+ "triggered" -> ITriggered
201− "acknowledged" -> IAcknowledged
210+ "acknowledged" -> IAcknowledged
202− "resolved" -> IResolved
211+ "resolved" -> IResolved
203− t -> IOther t
212+ _ -> IOther t
204
213
205instance ToJSON IncidentStatus where
214instance ToJSON IncidentStatus where
206 toJSON = String . Text.decodeUtf8 . toByteString'
215 toJSON = String . Text.decodeUtf8 . toByteString'
@@ -213,104 +222,76 @@ data Assignee = Assignee
213deriveRecord ''Assignee
222deriveRecord ''Assignee
214
223
215data Incident = Incident
224data Incident = Incident
216− { _iIncidentNumber' :: !Int
225+ { _iIncidentNumber :: !Int
217− , _iStatus' :: !IncidentStatus
226+ , _iStatus :: !IncidentStatus
218− , _iCreatedOn' :: Date
227+ , _iCreatedOn :: Date
219− , _iHtmlUrl' :: Text
228+ , _iHtmlUrl :: Text
220− , _iIncidentKey' :: Maybe IncidentKey
229+ , _iIncidentKey :: Maybe IncidentKey
221− , _iService' :: Object
230+ , _iService :: Object
222− , _iEscalationPolicy' :: Maybe Object
231+ , _iEscalationPolicy :: Maybe Object
223− , _iAssignedTo' :: [Assignee]
232+ , _iAssignedTo :: [Assignee]
224− , _iAcknowledgers' :: [Assignee]
233+ , _iAcknowledgers :: [Assignee]
225− , _iLastStatusChangeBy' :: Maybe Assignee
234+ , _iLastStatusChangeBy :: Maybe Assignee
226− , _iLastStatusChangeOn' :: Maybe Date
235+ , _iLastStatusChangeOn :: Maybe Date
227− , _iTriggerSummaryData' :: Object
236+ , _iTriggerSummaryData :: Object
228− , _iTriggerDetailsHtmlUrl' :: Text
237+ , _iTriggerDetailsHtmlUrl :: Text
229 } deriving (Eq, Show)
238 } deriving (Eq, Show)
230
239
231−deriveRecord ''Incident
240+deriveJSON ''Incident
232−
241+
233−class HasIncident a where
234− incident :: Lens' a Incident
235−
236− -- | The number of the incident. This is unique across your account.
242+-- | The number of the incident. This is unique across your account.
237− iIncidentNumber :: Lens' a Int
243+makeLens "_iIncidentNumber" ''Incident
238−
244+
239− -- | The current status of the incident. Valid statuses are:
245+-- | The current status of the incident. Valid statuses are:
240− iStatus :: Lens' a IncidentStatus
246+makeLens "_iStatus" ''Incident
241−
247+
242− -- | The date/time the incident was triggered.
248+-- | The date/time the incident was triggered.
243− iCreatedOn :: Lens' a UTCTime
249+iCreatedOn :: Lens' Incident UTCTime
244−
250+iCreatedOn = lens _iCreatedOn (\i x -> i { _iCreatedOn = x }) . _D
251+
245− -- | The PagerDuty website URL where the incident can be viewed and further
252+-- | The PagerDuty website URL where the incident can be viewed and further
246− -- actions taken. This is not the resource URL.
253+-- actions taken. This is not the resource URL.
247− iHtmlUrl :: Lens' a Text
254+makeLens "_iHtmlUrl" ''Incident
248−
255+
249− -- | The incident's de-duplication key. See the PagerDuty Integration API
256+-- | The incident's de-duplication key. See the PagerDuty Integration API docs
250− -- docs for further details.
257+-- for further details.
251− iIncidentKey :: Lens' a (Maybe IncidentKey)
258+makeLens "_iIncidentKey" ''Incident
252−
259+
253− -- | The PagerDuty service that the incident belongs to. The service will
260+-- | The PagerDuty service that the incident belongs to. The service will
254− -- contain fields of its own.
261+-- contain fields of its own.
255− iService :: Lens' a Object
262+makeLens "_iService" ''Incident
256−
263+
257− -- | The escalation policy that the incident belongs to. The policy will
264+-- | The escalation policy that the incident belongs to. The policy will
258− -- contain fields of its own.
265+-- contain fields of its own.
259− iEscalationPolicy :: Lens' a (Maybe Object)
266+makeLens "_iEscalationPolicy" ''Incident
260−
267+
261− -- | The list of assignments of the incident. An assignment is an object
268+-- | 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
269+-- containing the assigned user as well as the date/time the incident was assigned
263− -- assigned to that user. The user will contain fields of its own.
270+-- to that user. The user will contain fields of its own. This list is empty if
264− -- This list is empty if the status of the incident is resolved.
271+-- the status of the incident is resolved.
265− iAssignedTo :: Lens' a [Assignee]
272+makeLens "_iAssignedTo" ''Incident
266−
273+
267− -- | The list of acknowledgements of the incident. An acknowledgement is an
274+-- | The list of acknowledgements of the incident. An acknowledgement is an
268− -- object containing the acknowleding object (either a user or the
275+-- object containing the acknowleding object (either a user or the integration
269− -- integration API) as well as the date/time the incident was acknowledged.
276+-- API) as well as the date/time the incident was acknowledged. This field is only
270− -- This field is only present if the status of the incident is acknowledged.
277+-- present if the status of the incident is acknowledged. This field is sorted in
271− -- This field is sorted in ascending order by acknowledgement time.
278+-- ascending order by acknowledgement time.
272− iAcknowledgers :: Lens' a [Assignee]
279+makeLens "_iAcknowledgers" ''Incident
273−
280+
274− -- | The user who is responsible for the incident's last status change. If
281+-- | The user who is responsible for the incident's last status change. If the incident is in the acknowledged or resolved status, this will be the user that took the first acknowledged or resolved action. If the incident was automatically resolved (say through the Event Integration API), or if the incident is in the triggered state, this will be null. User fields are the same as in the assignedToUser field above.
275− -- the incident is in the acknowledged or resolved status, this will be the user
282+makeLens "_iLastStatusChangeBy" ''Incident
276− -- that took the first acknowledged or resolved action. If the incident was
283+
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.
284+-- | The date/time the incident's status last changed.
283− iLastStatusChangeOn :: Lens' a (Maybe UTCTime)
285+iLastStatusChangeOn :: Lens' Incident (Maybe UTCTime)
284−
286+iLastStatusChangeOn =
285− -- | Some condensed information regarding the initial event that triggered
287+ lens _iLastStatusChangeOn (\i x -> i { _iLastStatusChangeOn = x })
286− -- this incident. This data will be a set of key/value pairs that vary depending
288+ . mapping _D
287− -- on what sort of event triggered the incident (email, Event API request,
289+
288− -- etc). For instance, if an email triggered the incident, then the
290+-- | Some condensed information regarding the initial event that triggered this incident. This data will be a set of key/value pairs that vary depending on what sort of event triggered the incident (email, Event API request, etc). For instance, if an email triggered the incident, then the triggerSummaryData will likely contain a subject. There are no guarantees on the full presence of this data for every incident.
289− -- triggerSummaryData will likely contain a subject. There are no guarantees
291+makeLens "_iTriggerSummaryData" ''Incident
290− -- o nthe full presence of this data for every incident.
292+
291− iTriggerSummaryData :: Lens' a Object
292−
293− -- | The PagerDuty website URL where the full details regarding the initial
293+-- | The PagerDuty website URL where the full details regarding the initial event that triggered this incident can be found. (This is not the resource URL.)
294− -- event that triggered this incident can be found. (This is not the resource
294+makeLens "_iTriggerDetailsHtmlUrl" ''Incident
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
295
315data ListIncidents = ListIncidents
296data ListIncidents = ListIncidents
316 { _lsSince' :: Maybe Date
297 { _lsSince' :: Maybe Date
@@ -347,10 +328,13 @@ lsUntil = upd.lsUntil'.mapping _D
347-- | When set, the since and until parameters and defaults are
328-- | When set, the since and until parameters and defaults are
348-- ignored. Use this to get all incidents since the account was created.
329-- ignored. Use this to get all incidents since the account was created.
349lsDateRange :: Lens' (Request ListIncidents s b) Bool
330lsDateRange :: Lens' (Request ListIncidents s b) Bool
350−lsDateRange = upd.lens get_ (flip set_)
331+lsDateRange = upd . lens get' set'
351 where
332 where
352− get_ = (Just All ==) . view lsDateRange'
333+ get' x
353− set_ x = lsDateRange' .~ listToMaybe [All | x]
334+ | Just All <- _lsDateRange' x = True
335+ | otherwise = False
336+
337+ set' l x = l { _lsDateRange' = if x then Just All else Nothing }
354
338
355-- | Returns only the incidents currently in the passed status(es).
339-- | Returns only the incidents currently in the passed status(es).
356lsStatus :: Lens' (Request ListIncidents s b) (Maybe [IncidentStatus])
340lsStatus :: Lens' (Request ListIncidents s b) (Maybe [IncidentStatus])
@@ -437,12 +421,12 @@ cSince = upd.cSince'.mapping _D
437
421
438-- | The end of the date range over which you want to search.
422-- | The end of the date range over which you want to search.
439--
423--
440−-- /Note:/ If you leave off either since or until, a 30 day default range is
424+-- /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
425-- 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,
426+-- the date range to until - 30 days. Likewise, if you leave off until,
443−-- it is set to since @+30@ days.
427+-- it is set to since + 30 days.
444--
428--
445−-- /Default:/ The last 30 days if you leave off both. The size of the date
429+-- Defaults to the last 30 days if you leave off both. The size of the date
446-- range must be less than 180 days.
430-- range must be less than 180 days.
447cUntil :: Lens' (Request CountIncidents s b) (Maybe UTCTime)
431cUntil :: Lens' (Request CountIncidents s b) (Maybe UTCTime)
448cUntil = upd.cUntil'.mapping _D
432cUntil = upd.cUntil'.mapping _D
@@ -450,10 +434,13 @@ cUntil = upd.cUntil'.mapping _D
450-- | When set, the since and until parameters and defaults are
434-- | When set, the since and until parameters and defaults are
451-- ignored. Use this to get all counts since the account was created.
435-- ignored. Use this to get all counts since the account was created.
452cDateRange :: Lens' (Request CountIncidents s b) Bool
436cDateRange :: Lens' (Request CountIncidents s b) Bool
453−cDateRange = upd.lens get_ (flip set_)
437+cDateRange = upd . lens get' set'
454 where
438 where
455− get_ = (Just All ==) . view cDateRange'
439+ get' x
456− set_ x = cDateRange' .~ listToMaybe [All | x]
440+ | Just All <- _cDateRange' x = True
441+ | otherwise = False
442+
443+ set' l x = l { _cDateRange' = if x then Just All else Nothing }
457
444
458-- | Only counts the incidents currently in the passed status(es).
445-- | Only counts the incidents currently in the passed status(es).
459cStatus :: Lens' (Request CountIncidents s b) (Maybe [IncidentStatus])
446cStatus :: Lens' (Request CountIncidents s b) (Maybe [IncidentStatus])
@@ -516,7 +503,7 @@ data UpdateIncident = UpdateIncident
516 { _iiId :: IncidentId
503 { _iiId :: IncidentId
517 , _iiStatus :: Maybe UpdateStatus
504 , _iiStatus :: Maybe UpdateStatus
518 , _iiEscalationLevel :: Maybe Int
505 , _iiEscalationLevel :: Maybe Int
519− , _iiEscalationPolicy :: Maybe EscalationPolicyId
506+ , _iiEscalationPolicy :: Maybe PolicyId
520 , _iiAssignedToUser :: Maybe (CSV UserId)
507 , _iiAssignedToUser :: Maybe (CSV UserId)
521 } deriving (Eq, Show)
508 } deriving (Eq, Show)
522
509
@@ -567,7 +554,7 @@ updateIncidents r = auth updateIncidentsBasic & query .~ [("requester_id", r)]
567
554
568-- | A version of 'updateIncidents' which uses HTTP Basic authentication and
555-- | A version of 'updateIncidents' which uses HTTP Basic authentication and
569-- doesn't require a 'RequesterId'.
556-- doesn't require a 'RequesterId'.
570−updateIncidentsBasic :: Request UpdateIncidents 'Basic [UpdatedIncidents]
557+updateIncidentsBasic :: Request UpdateIncidents Basic [UpdatedIncidents]
571updateIncidentsBasic =
558updateIncidentsBasic =
572 mk UpdateIncidents
559 mk UpdateIncidents
573 { _uiIncidents' = []
560 { _uiIncidents' = []
@@ -608,7 +595,7 @@ acknowledgeIncidentBasic i =
608 empty & meth .~ PUT & path .~ incidents % i % "acknowledge"
595 empty & meth .~ PUT & path .~ incidents % i % "acknowledge"
609
596
610data ReassignIncident = ReassignIncident
597data ReassignIncident = ReassignIncident
611− { _riEscalationPolicy' :: Maybe EscalationPolicyId
598+ { _riEscalationPolicy' :: Maybe PolicyId
612 , _riEscalationLevel' :: Maybe Int
599 , _riEscalationLevel' :: Maybe Int
613 , _riAssignedToUser' :: Maybe (CSV UserId)
600 , _riAssignedToUser' :: Maybe (CSV UserId)
614 } deriving (Eq, Show)
601 } deriving (Eq, Show)
@@ -617,7 +604,7 @@ jsonRequest ''ReassignIncident
617
604
618-- | The ID of an escalation policy. Delegate the incident to this escalation
605-- | The ID of an escalation policy. Delegate the incident to this escalation
619-- policy.
606-- policy.
620−riEscalationPolicy :: Lens' (Request ReassignIncident s b) (Maybe EscalationPolicyId)
607+riEscalationPolicy :: Lens' (Request ReassignIncident s b) (Maybe PolicyId)
621riEscalationPolicy = upd.riEscalationPolicy'
608riEscalationPolicy = upd.riEscalationPolicy'
622
609
623-- | Escalate incident to this level in the escalation policy.
610-- | Escalate incident to this level in the escalation policy.
src/Network/PagerDuty/REST/Incidents/Notes.hs+12−12
@@ -1,11 +1,11 @@
1−{-# LANGUAGE ExtendedDefaultRules #-}
1+{-# LANGUAGE ExtendedDefaultRules #-}
2−{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE TemplateHaskell #-}
3+{-# LANGUAGE TemplateHaskell #-}
4
4
5{-# OPTIONS_GHC -fno-warn-type-defaults #-}
5{-# OPTIONS_GHC -fno-warn-type-defaults #-}
6
6
7-- Module : Network.PagerDuty.REST.Incidents.Notes
7-- Module : Network.PagerDuty.REST.Incidents.Notes
8−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
8+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
9-- License : This Source Code Form is subject to the terms of
9-- License : This Source Code Form is subject to the terms of
10-- the Mozilla Public License, v. 2.0.
10-- the Mozilla Public License, v. 2.0.
11-- A copy of the MPL can be found in the LICENSE file or
11-- A copy of the MPL can be found in the LICENSE file or
@@ -36,14 +36,14 @@ module Network.PagerDuty.REST.Incidents.Notes
36 , nContent
36 , nContent
37 ) where
37 ) where
38
38
39−import Control.Lens hiding ((.=))
39+import Control.Lens hiding ((.=))
40−import Data.Aeson
40+import Data.Aeson
41−import Data.Text (Text)
41+import Data.Text (Text)
42−import Data.Time
42+import Data.Time
43−import Network.HTTP.Types
43+import Network.HTTP.Types
44−import Network.PagerDuty.Internal.TH
45−import Network.PagerDuty.Internal.Types
46−import Network.PagerDuty.REST.Users
44+import Network.PagerDuty.REST.Users
45+import Network.PagerDuty.TH
46+import Network.PagerDuty.Types
47
47
48default (Path)
48default (Path)
49
49
src/Network/PagerDuty/REST/LogEntries.hs+11−10
@@ -5,7 +5,7 @@
5{-# LANGUAGE TypeFamilies #-}
5{-# LANGUAGE TypeFamilies #-}
6
6
7-- Module : Network.PagerDuty.REST.LogEntries
7-- 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>
9-- License : This Source Code Form is subject to the terms of
9-- License : This Source Code Form is subject to the terms of
10-- the Mozilla Public License, v. 2.0.
10-- the Mozilla Public License, v. 2.0.
11-- A copy of the MPL can be found in the LICENSE file or
11-- A copy of the MPL can be found in the LICENSE file or
@@ -111,18 +111,19 @@ module Network.PagerDuty.REST.LogEntries
111 , nAddress
111 , nAddress
112 ) where
112 ) where
113
113
114−import Control.Lens hiding (Empty)
114+import Control.Applicative
115+import Control.Lens
115import Data.Aeson
116import Data.Aeson
116import Data.Aeson.Lens
117import Data.Aeson.Lens
117−import qualified Data.Aeson.KeyMap as Map
118−import Data.Default.Class
118+import Data.Default
119+import qualified Data.HashMap.Strict as Map
119−import Data.Text (Text)
120+import Data.Text (Text)
120−import qualified Data.Text as Text
121+import qualified Data.Text as Text
121import Data.Time
122import Data.Time
122import Network.HTTP.Types
123import Network.HTTP.Types
123−import Network.PagerDuty.Internal.TH
124+import Network.PagerDuty.REST.Users (User)
124−import Network.PagerDuty.Internal.Types
125+import Network.PagerDuty.TH
125−import Network.PagerDuty.REST.Users (User)
126+import Network.PagerDuty.Types
126
127
127logs :: Path
128logs :: Path
128logs = "log_entries"
129logs = "log_entries"
@@ -325,7 +326,7 @@ data LogEntry = LogEntry'
325 } deriving (Eq, Show)
326 } deriving (Eq, Show)
326
327
327instance FromJSON LogEntry where
328instance FromJSON LogEntry where
328− parseJSON = withObject "log_entry" $ \o ->
329+ parseJSON = withObject "log_entry" $ \o -> do
329 LogEntry' <$> o .: "id"
330 LogEntry' <$> o .: "id"
330 <*> o .: "type"
331 <*> o .: "type"
331 <*> o .: "created_at"
332 <*> o .: "created_at"
src/Network/PagerDuty/REST/MaintenanceWindows.hs+10−10
@@ -4,7 +4,7 @@
4{-# LANGUAGE TypeFamilies #-}
4{-# LANGUAGE TypeFamilies #-}
5
5
6-- Module : Network.PagerDuty.REST.MaintenanceWindows
6-- 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>
8-- License : This Source Code Form is subject to the terms of
8-- License : This Source Code Form is subject to the terms of
9-- the Mozilla Public License, v. 2.0.
9-- the Mozilla Public License, v. 2.0.
10-- A copy of the MPL can be found in the LICENSE file or
10-- A copy of the MPL can be found in the LICENSE file or
@@ -74,14 +74,14 @@ module Network.PagerDuty.REST.MaintenanceWindows
74 , mwServices
74 , mwServices
75 ) where
75 ) where
76
76
77−import Control.Lens hiding (Empty)
77+import Control.Lens
78−import Data.Monoid
78+import Data.Monoid
79−import Data.Text (Text)
79+import Data.Text (Text)
80−import Data.Time
80+import Data.Time
81−import Network.HTTP.Types
81+import Network.HTTP.Types
82−import Network.PagerDuty.Internal.TH
83−import Network.PagerDuty.Internal.Types
84−import Network.PagerDuty.REST.Users (User)
82+import Network.PagerDuty.REST.Users (User)
83+import Network.PagerDuty.TH
84+import Network.PagerDuty.Types
85
85
86windows :: Path
86windows :: Path
87windows = "maintenance_windows"
87windows = "maintenance_windows"
@@ -214,7 +214,7 @@ createWindow r s e xs =
214createWindowBasic :: UTCTime -- ^ 'cwStartTime'
214createWindowBasic :: UTCTime -- ^ 'cwStartTime'
215 -> UTCTime -- ^ 'cwEndTime'
215 -> UTCTime -- ^ 'cwEndTime'
216 -> [ServiceId] -- ^ 'cwServiceIds'
216 -> [ServiceId] -- ^ 'cwServiceIds'
217− -> Request CreateWindow 'Basic MaintenanceWindow
217+ -> Request CreateWindow Basic MaintenanceWindow
218createWindowBasic s e xs =
218createWindowBasic s e xs =
219 mk CreateWindow
219 mk CreateWindow
220 { _cwRequesterId' = Nothing
220 { _cwRequesterId' = Nothing
src/Network/PagerDuty/REST/Reports.hs+12−11
@@ -1,13 +1,13 @@
1−{-# LANGUAGE DataKinds #-}
1+{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE ExtendedDefaultRules #-}
2+{-# LANGUAGE ExtendedDefaultRules #-}
3−{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE TemplateHaskell #-}
4+{-# LANGUAGE TemplateHaskell #-}
5−{-# LANGUAGE TypeFamilies #-}
5+{-# LANGUAGE TypeFamilies #-}
6
6
7{-# OPTIONS_GHC -fno-warn-type-defaults #-}
7{-# OPTIONS_GHC -fno-warn-type-defaults #-}
8
8
9-- Module : Network.PagerDuty.REST.Reports
9-- 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>
11-- License : This Source Code Form is subject to the terms of
11-- License : This Source Code Form is subject to the terms of
12-- the Mozilla Public License, v. 2.0.
12-- the Mozilla Public License, v. 2.0.
13-- A copy of the MPL can be found in the LICENSE file or
13-- A copy of the MPL can be found in the LICENSE file or
@@ -58,11 +58,12 @@ module Network.PagerDuty.REST.Reports
58 , irNumberOfIncidents
58 , irNumberOfIncidents
59 ) where
59 ) where
60
60
61−import Control.Lens hiding (Empty)
61+import Control.Lens
62−import Data.Aeson.Lens
62+import Data.Aeson.Lens
63+import Data.ByteString.Builder (Builder)
63−import Data.Time
64+import Data.Time
64−import Network.PagerDuty.Internal.TH
65+import Network.PagerDuty.TH
65−import Network.PagerDuty.Internal.Types
66+import Network.PagerDuty.Types
66
67
67default (Path)
68default (Path)
68
69
src/Network/PagerDuty/REST/Schedules.hs+17−16
@@ -1,13 +1,13 @@
1−{-# LANGUAGE DataKinds #-}
1+{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE ExtendedDefaultRules #-}
2+{-# LANGUAGE ExtendedDefaultRules #-}
3−{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE TemplateHaskell #-}
4+{-# LANGUAGE TemplateHaskell #-}
5−{-# LANGUAGE TypeFamilies #-}
5+{-# LANGUAGE TypeFamilies #-}
6
6
7{-# OPTIONS_GHC -fno-warn-type-defaults #-}
7{-# OPTIONS_GHC -fno-warn-type-defaults #-}
8
8
9-- Module : Network.PagerDuty.REST.Schedules
9-- Module : Network.PagerDuty.REST.Schedules
10−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
10+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
11-- License : This Source Code Form is subject to the terms of
11-- License : This Source Code Form is subject to the terms of
12-- the Mozilla Public License, v. 2.0.
12-- the Mozilla Public License, v. 2.0.
13-- A copy of the MPL can be found in the LICENSE file or
13-- A copy of the MPL can be found in the LICENSE file or
@@ -110,14 +110,15 @@ module Network.PagerDuty.REST.Schedules
110 , sFinalSchedule
110 , sFinalSchedule
111 ) where
111 ) where
112
112
113−import Control.Lens hiding (Empty, (.=))
113+import Control.Lens hiding ((.=))
114−import Data.Aeson
114+import Data.Aeson
115+import Data.ByteString.Builder (Builder)
115−import Data.Text (Text)
116+import Data.Text (Text)
116−import Data.Time
117+import Data.Time
117−import Network.HTTP.Types
118+import Network.HTTP.Types
118−import Network.PagerDuty.Internal.TH
119−import Network.PagerDuty.Internal.Types
120−import Network.PagerDuty.REST.Users (User)
119+import Network.PagerDuty.REST.Users (User)
120+import Network.PagerDuty.TH
121+import Network.PagerDuty.Types
121
122
122default (Path)
123default (Path)
123
124
@@ -225,7 +226,7 @@ data ScheduleInfo = ScheduleInfo
225 , _siName' :: Text
226 , _siName' :: Text
226 , _siTimeZone' :: TZ
227 , _siTimeZone' :: TZ
227 , _siToday' :: Date
228 , _siToday' :: Date
228− , _siEscalationPolicies' :: [EscalationPolicyId]
229+ , _siEscalationPolicies' :: [PolicyId]
229 } deriving (Eq, Show)
230 } deriving (Eq, Show)
230
231
231deriveRecord ''ScheduleInfo
232deriveRecord ''ScheduleInfo
@@ -242,7 +243,7 @@ class HasScheduleInfo a where
242 -- | The current day in the schedule's time zone.
243 -- | The current day in the schedule's time zone.
243 sToday :: Lens' a UTCTime
244 sToday :: Lens' a UTCTime
244 -- | An list of all the escalation policies that uses this schedule.
245 -- | An list of all the escalation policies that uses this schedule.
245− sEscalationPolicies :: Lens' a [EscalationPolicyId]
246+ sEscalationPolicies :: Lens' a [PolicyId]
246
247
247 sId = scheduleInfo.siId'
248 sId = scheduleInfo.siId'
248 sName = scheduleInfo.siName'
249 sName = scheduleInfo.siName'
src/Network/PagerDuty/REST/Schedules/Overrides.hs+12−12
@@ -1,13 +1,13 @@
1−{-# LANGUAGE DataKinds #-}
1+{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE ExtendedDefaultRules #-}
2+{-# LANGUAGE ExtendedDefaultRules #-}
3−{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE TemplateHaskell #-}
4+{-# LANGUAGE TemplateHaskell #-}
5−{-# LANGUAGE TypeFamilies #-}
5+{-# LANGUAGE TypeFamilies #-}
6
6
7{-# OPTIONS_GHC -fno-warn-type-defaults #-}
7{-# OPTIONS_GHC -fno-warn-type-defaults #-}
8
8
9-- Module : Network.PagerDuty.REST.Schedules
9-- Module : Network.PagerDuty.REST.Schedules
10−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
10+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
11-- License : This Source Code Form is subject to the terms of
11-- License : This Source Code Form is subject to the terms of
12-- the Mozilla Public License, v. 2.0.
12-- the Mozilla Public License, v. 2.0.
13-- A copy of the MPL can be found in the LICENSE file or
13-- A copy of the MPL can be found in the LICENSE file or
@@ -50,12 +50,12 @@ module Network.PagerDuty.REST.Schedules.Overrides
50 , oUser
50 , oUser
51 ) where
51 ) where
52
52
53−import Control.Lens
53+import Control.Lens
54−import Data.Time
54+import Data.Time
55−import Network.HTTP.Types
55+import Network.HTTP.Types
56−import Network.PagerDuty.Internal.TH
57−import Network.PagerDuty.Internal.Types
58−import Network.PagerDuty.REST.Users
56+import Network.PagerDuty.REST.Users
57+import Network.PagerDuty.TH
58+import Network.PagerDuty.Types
59
59
60overrides :: ScheduleId -> Path
60overrides :: ScheduleId -> Path
61overrides i = "schedules" % i % "overrides"
61overrides i = "schedules" % i % "overrides"
src/Network/PagerDuty/REST/Services.hs+24−24
@@ -1,13 +1,13 @@
1−{-# LANGUAGE DataKinds #-}
1+{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE ExtendedDefaultRules #-}
2+{-# LANGUAGE ExtendedDefaultRules #-}
3−{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE TemplateHaskell #-}
4+{-# LANGUAGE TemplateHaskell #-}
5−{-# LANGUAGE TypeFamilies #-}
5+{-# LANGUAGE TypeFamilies #-}
6
6
7{-# OPTIONS_GHC -fno-warn-type-defaults #-}
7{-# OPTIONS_GHC -fno-warn-type-defaults #-}
8
8
9-- Module : Network.PagerDuty.REST.Services
9-- 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>
11-- License : This Source Code Form is subject to the terms of
11-- License : This Source Code Form is subject to the terms of
12-- the Mozilla Public License, v. 2.0.
12-- the Mozilla Public License, v. 2.0.
13-- A copy of the MPL can be found in the LICENSE file or
13-- A copy of the MPL can be found in the LICENSE file or
@@ -106,14 +106,14 @@ module Network.PagerDuty.REST.Services
106 , svcSeverityFilter
106 , svcSeverityFilter
107 ) where
107 ) where
108
108
109−import Control.Lens hiding (Empty)
109+import Control.Lens
110−import Data.Aeson.Lens
110+import Data.Aeson.Lens
111+import Data.ByteString.Builder (Builder)
111−import Data.Text (Text)
112+import Data.Text (Text)
112−import Data.Time
113+import Data.Time
113−import Network.HTTP.Types
114+import Network.HTTP.Types
114−import Network.PagerDuty.Internal.TH
115+import Network.PagerDuty.TH
115−import Network.PagerDuty.Internal.Types
116+import Network.PagerDuty.Types
116−import Network.PagerDuty.REST.Services.EmailFilters
117
117
118default (Path)
118default (Path)
119
119
@@ -187,7 +187,7 @@ data ServiceType
187deriveNullary ''ServiceType
187deriveNullary ''ServiceType
188
188
189data PolicyInfo = PolicyInfo
189data PolicyInfo = PolicyInfo
190− { _pinfoId :: EscalationPolicyId
190+ { _pinfoId :: PolicyId
191 , _pinfoName :: Text
191 , _pinfoName :: Text
192 } deriving (Eq, Show)
192 } deriving (Eq, Show)
193
193
@@ -223,8 +223,8 @@ data Service = Service
223 , _svcIncidentCounts :: IncidentCounts
223 , _svcIncidentCounts :: IncidentCounts
224 , _svcEmailFilterMode :: EmailFilterMode
224 , _svcEmailFilterMode :: EmailFilterMode
225 , _svcType :: ServiceType
225 , _svcType :: ServiceType
226− , _svcEscalationPolicy :: Maybe PolicyInfo -- FIXME: extract from inline.
226+ , _svcEscalationPolicy :: Maybe PolicyInfo -- FIXME: extract from inline.
227− , _svcEmailFilters :: Maybe [EmailFilterInfo] -- FIXME: extract from inline.
227+ , _svcEmailFilters :: Maybe EmailFilters -- FIXME: extract from inline.
228 , _svcSeverityFilter :: Maybe SeverityFilter
228 , _svcSeverityFilter :: Maybe SeverityFilter
229 } deriving (Eq, Show)
229 } deriving (Eq, Show)
230
230
@@ -322,7 +322,7 @@ listServices =
322
322
323data CreateService = CreateService
323data CreateService = CreateService
324 { _csName' :: Text
324 { _csName' :: Text
325− , _csEscalationPolicyId' :: EscalationPolicyId
325+ , _csEscalationPolicyId' :: PolicyId
326 , _csType' :: !ServiceType
326 , _csType' :: !ServiceType
327 , _csVendorId' :: Maybe VendorId
327 , _csVendorId' :: Maybe VendorId
328 , _csDescription' :: Maybe Text
328 , _csDescription' :: Maybe Text
@@ -351,7 +351,7 @@ csVendorId :: Lens' (Request CreateService s r) (Maybe VendorId)
351csVendorId = upd.csVendorId'
351csVendorId = upd.csVendorId'
352
352
353-- | The id of the escalation policy to be used by this service.
353-- | The id of the escalation policy to be used by this service.
354−csEscalationPolicyId :: Lens' (Request CreateService s r) EscalationPolicyId
354+csEscalationPolicyId :: Lens' (Request CreateService s r) PolicyId
355csEscalationPolicyId = upd.csEscalationPolicyId'
355csEscalationPolicyId = upd.csEscalationPolicyId'
356
356
357-- | The duration in seconds before an incidents acknowledged in this service
357-- | The duration in seconds before an incidents acknowledged in this service
@@ -377,7 +377,7 @@ csSeverityFilter = upd.csSeverityFilter'
377--
377--
378-- /See:/ <http://developer.pagerduty.com/documentation/rest/services/create>
378-- /See:/ <http://developer.pagerduty.com/documentation/rest/services/create>
379createService :: Text
379createService :: Text
380− -> EscalationPolicyId
380+ -> PolicyId
381 -> ServiceType
381 -> ServiceType
382 -> Request CreateService s Service
382 -> Request CreateService s Service
383createService n p t =
383createService n p t =
@@ -407,7 +407,7 @@ getService i = empty
407data UpdateService = UpdateService
407data UpdateService = UpdateService
408 { _usName' :: Maybe Text
408 { _usName' :: Maybe Text
409 , _usDescription' :: Maybe Text
409 , _usDescription' :: Maybe Text
410− , _usEscalationPolicyId' :: Maybe EscalationPolicyId
410+ , _usEscalationPolicyId' :: Maybe PolicyId
411 , _usAcknowledgementTimeout' :: Maybe Int
411 , _usAcknowledgementTimeout' :: Maybe Int
412 , _usAutoResolveTimeout' :: Maybe Int
412 , _usAutoResolveTimeout' :: Maybe Int
413 , _usSeverityFilter' :: Maybe SeverityFilter
413 , _usSeverityFilter' :: Maybe SeverityFilter
@@ -424,7 +424,7 @@ usDescription :: Lens' (Request UpdateService s r) (Maybe Text)
424usDescription = upd.usDescription'
424usDescription = upd.usDescription'
425
425
426-- | The id of the escalation policy to be used by this service.
426-- | The id of the escalation policy to be used by this service.
427−usEscalationPolicyId :: Lens' (Request UpdateService s r) (Maybe EscalationPolicyId)
427+usEscalationPolicyId :: Lens' (Request UpdateService s r) (Maybe PolicyId)
428usEscalationPolicyId = upd.usEscalationPolicyId'
428usEscalationPolicyId = upd.usEscalationPolicyId'
429
429
430-- | The duration in seconds before an incidents acknowledged in this service
430-- | The duration in seconds before an incidents acknowledged in this service
@@ -483,7 +483,7 @@ enableService r i =
483
483
484-- | A version of 'enableService' which uses HTTP Basic authentication and
484-- | A version of 'enableService' which uses HTTP Basic authentication and
485-- doesn't require a 'RequesterId'.
485-- doesn't require a 'RequesterId'.
486−enableServiceBasic :: ServiceId -> Request Empty 'Basic Empty
486+enableServiceBasic :: ServiceId -> Request Empty Basic Empty
487enableServiceBasic i = empty & meth .~ PUT & path .~ services % i % "enable"
487enableServiceBasic i = empty & meth .~ PUT & path .~ services % i % "enable"
488
488
489-- | Disable a service. Once a service is disabled, it will not be able to
489-- | Disable a service. Once a service is disabled, it will not be able to
@@ -498,7 +498,7 @@ disableService r i =
498
498
499-- | A version of 'disableService' which uses HTTP Basic authentication and
499-- | A version of 'disableService' which uses HTTP Basic authentication and
500-- doesn't require a 'RequesterId'.
500-- doesn't require a 'RequesterId'.
501−disableServiceBasic :: ServiceId -> Request Empty 'Basic Empty
501+disableServiceBasic :: ServiceId -> Request Empty Basic Empty
502disableServiceBasic i = empty & meth .~ PUT & path .~ services % i % "disable"
502disableServiceBasic i = empty & meth .~ PUT & path .~ services % i % "disable"
503
503
504-- | Regenerate a new service key for an existing service.
504-- | Regenerate a new service key for an existing service.
src/Network/PagerDuty/REST/Services/EmailFilters.hs+14−14
@@ -1,11 +1,11 @@
1−{-# LANGUAGE ExtendedDefaultRules #-}
1+{-# LANGUAGE ExtendedDefaultRules #-}
2−{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE TemplateHaskell #-}
3+{-# LANGUAGE TemplateHaskell #-}
4
4
5{-# OPTIONS_GHC -fno-warn-type-defaults #-}
5{-# OPTIONS_GHC -fno-warn-type-defaults #-}
6
6
7-- Module : Network.PagerDuty.REST.Services.EmailFilters
7-- Module : Network.PagerDuty.REST.Services.EmailFilters
8−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
8+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
9-- License : This Source Code Form is subject to the terms of
9-- License : This Source Code Form is subject to the terms of
10-- the Mozilla Public License, v. 2.0.
10-- the Mozilla Public License, v. 2.0.
11-- A copy of the MPL can be found in the LICENSE file or
11-- A copy of the MPL can be found in the LICENSE file or
@@ -39,15 +39,15 @@ module Network.PagerDuty.REST.Services.EmailFilters
39 , efId
39 , efId
40 ) where
40 ) where
41
41
42−import Control.Applicative hiding (empty)
42+import Control.Applicative hiding (empty)
43−import Control.Lens hiding ((.=))
43+import Control.Lens hiding ((.=))
44−import Data.Aeson
44+import Data.Aeson
45−import Data.Default.Class
45+import Data.Default
46−import Data.Monoid
46+import Data.Monoid
47−import Data.Text (Text)
47+import Data.Text (Text)
48−import Network.HTTP.Types
48+import Network.HTTP.Types
49−import Network.PagerDuty.Internal.TH
49+import Network.PagerDuty.TH
50−import Network.PagerDuty.Internal.Types
50+import Network.PagerDuty.Types
51
51
52default (Path)
52default (Path)
53
53
@@ -65,7 +65,7 @@ deriveNullaryWith hyphenated ''MatchMode
65-- FIXME: Tighten up this type! Make the regex required for match/no-match and
65-- FIXME: Tighten up this type! Make the regex required for match/no-match and
66-- encode the conditional invariants.
66-- encode the conditional invariants.
67data EmailFilterInfo = EmailFilterInfo
67data EmailFilterInfo = EmailFilterInfo
68− { _efSubjectMode' :: Maybe MatchMode
68+ { _efSubjectMode' :: Maybe MatchMode
69 , _efSubjectRegex' :: Maybe Text
69 , _efSubjectRegex' :: Maybe Text
70 , _efBodyMode' :: Maybe MatchMode
70 , _efBodyMode' :: Maybe MatchMode
71 , _efBodyRegex' :: Maybe Text
71 , _efBodyRegex' :: Maybe Text
src/Network/PagerDuty/REST/Users.hs+28−29
@@ -1,13 +1,13 @@
1−{-# LANGUAGE DataKinds #-}
1+{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE ExtendedDefaultRules #-}
2+{-# LANGUAGE ExtendedDefaultRules #-}
3−{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE TemplateHaskell #-}
4+{-# LANGUAGE TemplateHaskell #-}
5−{-# LANGUAGE TypeFamilies #-}
5+{-# LANGUAGE TypeFamilies #-}
6
6
7{-# OPTIONS_GHC -fno-warn-type-defaults #-}
7{-# OPTIONS_GHC -fno-warn-type-defaults #-}
8
8
9-- Module : Network.PagerDuty.REST.Users
9-- Module : Network.PagerDuty.REST.Users
10−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
10+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
11-- License : This Source Code Form is subject to the terms of
11-- License : This Source Code Form is subject to the terms of
12-- the Mozilla Public License, v. 2.0.
12-- the Mozilla Public License, v. 2.0.
13-- A copy of the MPL can be found in the LICENSE file or
13-- A copy of the MPL can be found in the LICENSE file or
@@ -81,16 +81,15 @@ module Network.PagerDuty.REST.Users
81 , uJobTitle
81 , uJobTitle
82 ) where
82 ) where
83
83
84−import Control.Applicative hiding (empty)
84+import Control.Applicative hiding (empty)
85−import Control.Lens hiding (Empty, (.=))
85+import Control.Lens hiding ((.=))
86−import Data.Aeson
86+import Data.Aeson
87−import Data.Default.Class
87+import Data.Default
88−import Data.Monoid
89−import Data.Text (Text)
88+import Data.Text (Text)
90−import Data.Time
89+import Data.Time
91−import Network.HTTP.Types
90+import Network.HTTP.Types
92−import Network.PagerDuty.Internal.TH
91+import Network.PagerDuty.TH
93−import Network.PagerDuty.Internal.Types
92+import Network.PagerDuty.Types
94
93
95default (Path)
94default (Path)
96
95
@@ -145,7 +144,7 @@ instance HasUserInfo UserInfo where
145 userInfo = id
144 userInfo = id
146
145
147data PolicyInfo = PolicyInfo
146data PolicyInfo = PolicyInfo
148− { _piId :: EscalationPolicyId
147+ { _piId :: PolicyId
149 , _piName :: Text
148 , _piName :: Text
150 } deriving (Eq, Show)
149 } deriving (Eq, Show)
151
150
@@ -193,17 +192,17 @@ instance FromJSON User where
193 <*> o .: "invitation_sent"
192 <*> o .: "invitation_sent"
194 <*> o .:? "job_title"
193 <*> o .:? "job_title"
195
194
196−instance ToJSON User where
195+-- instance ToJSON User where
197− toJSON u = Object (x <> y)
196+-- toJSON u = Object (x <> y)
198− where
197+-- where
199− Object x = toJSON (_uInfo u)
198+-- Object x = toJSON (_uInfo u)
200− Object y = object
199+-- Object y = object
201− [ "role" .= _uRole u
200+-- [ "role" .= _uRole u
202− , "avatar_url" .= _uAvatarUrl u
201+-- , "avatar_url" .= _uAvatarUrl u
203− , "user_url" .= _uUserUrl u
202+-- , "user_url" .= _uUserUrl u
204− , "invitation_sent" .= _uInvitationSent' u
203+-- , "invitation_sent" .= _uInvitationSent' u
205− , "job_title" .= _uJobTitle u
204+-- , "job_title"
206− ]
205+-- ]
207
206
208instance HasUserInfo User where
207instance HasUserInfo User where
209 userInfo = uInfo
208 userInfo = uInfo
@@ -315,7 +314,7 @@ createUser r n e = auth (createUserBasic n e) & query .~ [("requester_id", r)]
315-- doesn't require a 'RequesterId'.
314-- doesn't require a 'RequesterId'.
316createUserBasic :: Text -- ^ 'cuName'
315createUserBasic :: Text -- ^ 'cuName'
317 -> Address -- ^ 'cuEmail'
316 -> Address -- ^ 'cuEmail'
318− -> Request CreateUser 'Basic User
317+ -> Request CreateUser Basic User
319createUserBasic n e =
318createUserBasic n e =
320 mk CreateUser
319 mk CreateUser
321 { _cuName' = n
320 { _cuName' = n
src/Network/PagerDuty/REST/Users/ContactMethods.hs+32−168
@@ -1,11 +1,8 @@
1−{-# LANGUAGE ExtendedDefaultRules #-}
2−{-# LANGUAGE OverloadedStrings #-}
1+{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE TemplateHaskell #-}
2+{-# LANGUAGE TemplateHaskell #-}
4−
5−{-# OPTIONS_GHC -fno-warn-type-defaults #-}
6
3
7-- Module : Network.PagerDuty.REST.Users.ContactMethods
4-- Module : Network.PagerDuty.REST.Users.ContactMethods
8−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
5+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
9-- License : This Source Code Form is subject to the terms of
6-- License : This Source Code Form is subject to the terms of
10-- the Mozilla Public License, v. 2.0.
7-- the Mozilla Public License, v. 2.0.
11-- A copy of the MPL can be found in the LICENSE file or
8-- A copy of the MPL can be found in the LICENSE file or
@@ -23,130 +20,58 @@
23-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/contact_methods>
20-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/contact_methods>
24module Network.PagerDuty.REST.Users.ContactMethods
21module Network.PagerDuty.REST.Users.ContactMethods
25 (
22 (
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
23 ) where
58
24
59−import Control.Lens
25+import Control.Lens
60−import Data.Aeson.Lens
26+import Data.Monoid
61−import Data.Text (Text)
27+import Data.Text (Text)
28+import Data.Time
62−import Network.HTTP.Types
29+import Network.HTTP.Types
63−import Network.PagerDuty.Internal.TH
30+import Network.PagerDuty.TH
64−import Network.PagerDuty.Internal.Types
31+import Network.PagerDuty.Types
65−
66−default (Path)
67
32
68contacts :: UserId -> Path
33contacts :: UserId -> Path
69contacts u = "users" % u % "contact_methods"
34contacts u = "users" % u % "contact_methods"
70
35
71−data ContactType
72− = SMS
73− | Phone
74− | Email
75− deriving (Eq, Show)
76−
77−deriveNullary ''ContactType
78−
79data Contact = Contact
36data Contact = Contact
80 { _cId :: ContactId
37 { _cId :: ContactId
81 , _cUserId :: UserId
38 , _cUserId :: UserId
82 , _cLabel :: Text
39 , _cLabel :: Text
83 , _cAddress :: Address
40 , _cAddress :: Address
84− , _cType :: !ContactType
41+ , _cType :: ContactType
85− , _cCountryCode :: Maybe Int
86 , _cSendShortEmail :: Maybe Bool'
42 , _cSendShortEmail :: Maybe Bool'
87 , _cBlacklisted :: Maybe Bool'
43 , _cBlacklisted :: Maybe Bool'
88 } deriving (Eq, Show)
44 } deriving (Eq, Show)
89
45
90−deriveJSON ''Contact
46+data ContactType
91−makeClassy ''Contact
47+ = SMS
48+ | Phone
49+ | Email
50+ deriving (Eq, Show)
51+
52+deriveNullary ''ContactType
53+
54+Name Type Required Description
55+type String Yes The type of the contact method. One of SMS, email or phone.
56+address String Yes The id of the contact method. For SMS and phone it is the number, and for email it is the email address.
57+country_code Integer No The number code for your country. Not used for email. Defaults to 1.
58+label String No A human friendly label for the contact method. (ie: "Home Phone", "Work Email", etc.) Defaults to the type of the contact method and the address (with country code for phone numbers).
59+send_short_email Boolean No Send an abbreviated email message instead of the standard email output. Useful for email-to-SMS gateways and email based pagers. Only valid for email contact methods. Defaults to false.
60+
92
61
93-- | List existing contact methods for the specified user.
62-- | List existing contact methods for the specified user.
94--
63--
95-- @GET \/users\/\:user_id\/contact_methods@
64-- @GET \/users\/\:user_id\/contact_methods@
96--
65--
97-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/contact_methods/list>
66-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/contact_methods/list>
98−listContacts :: UserId -> Request Empty s [Contact]
67+listContacts
99−listContacts u = empty & path .~ contacts u
100
68
101-- | Get details for a contact method.
69-- | Get details for a contact method.
102--
70--
103-- @GET \/users\/\:user_id\/contact_methods\/\:id@
71-- @GET \/users\/\:user_id\/contact_methods\/\:id@
104--
72--
105-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/contact_methods/show>
73-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/contact_methods/show>
106−getContact :: UserId -> ContactId -> Request Empty s Contact
74+getContact
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
75
151-- | Create a new contact method for a given user. A contact method can be one
76-- | 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
77-- of the following types: SMS, email, and phone. push_notification contact
@@ -158,79 +83,18 @@ ccSendShortEmail = upd.ccSendShortEmail'.mapping _B
158-- /Note:/ The contact info must be unique.
83-- /Note:/ The contact info must be unique.
159--
84--
160-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/contact_methods/create>
85-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/contact_methods/create>
161−createContact :: UserId
86+createContact
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
87
213−-- | Update an existing contact method of a given user. Note that you cannot
88+-- | Update an existing contact method of a given user. Note that you cannot change the type of an existing method.
214−-- change the type of an existing method.
215--
89--
216-- @PUT \/users\/\:user_id\/contact_methods\/\:id@
90-- @PUT \/users\/\:user_id\/contact_methods\/\:id@
217--
91--
218-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/contact_methods/update>
92-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/contact_methods/update>
219−updateContact :: UserId -> ContactId -> Request UpdateContact s Contact
93+updateContact
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
94
230-- | Remove a contact method and any corresponding notification rules.
95-- | Remove a contact method and any corresponding notification rules.
231--
96--
232-- @DELETE \/users\/\:user_id\/contact_methods\/\:id@
97-- @DELETE \/users\/\:user_id\/contact_methods\/\:id@
233--
98--
234-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/contact_methods/delete>
99-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/contact_methods/delete>
235−deleteContact :: UserId -> ContactId -> Request Empty s Empty
100+deleteContact
236−deleteContact u c = empty & meth .~ DELETE & path .~ contacts u % c
src/Network/PagerDuty/REST/Users/NotificationRules.hs+17−112
@@ -1,11 +1,8 @@
1−{-# LANGUAGE ExtendedDefaultRules #-}
2−{-# LANGUAGE OverloadedStrings #-}
1+{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE TemplateHaskell #-}
2+{-# LANGUAGE TemplateHaskell #-}
4−
5−{-# OPTIONS_GHC -fno-warn-type-defaults #-}
6
3
7-- Module : Network.PagerDuty.REST.Users.NotificationRules
4-- Module : Network.PagerDuty.REST.Users.NotificationRules
8−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
5+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
9-- License : This Source Code Form is subject to the terms of
6-- License : This Source Code Form is subject to the terms of
10-- the Mozilla Public License, v. 2.0.
7-- the Mozilla Public License, v. 2.0.
11-- A copy of the MPL can be found in the LICENSE file or
8-- A copy of the MPL can be found in the LICENSE file or
@@ -23,142 +20,50 @@
23-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/notification_rules>
20-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/notification_rules>
24module Network.PagerDuty.REST.Users.NotificationRules
21module Network.PagerDuty.REST.Users.NotificationRules
25 (
22 (
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
23 ) where
53
24
54−import Control.Lens
25+import Control.Lens
55−import Data.Aeson.Lens
26+import Data.Monoid
27+import Data.Text (Text)
28+import Data.Time
56−import Network.HTTP.Types
29+import Network.HTTP.Types
57−import Network.PagerDuty.Internal.TH
30+import Network.PagerDuty.TH
58−import Network.PagerDuty.Internal.Types
31+import Network.PagerDuty.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
32
72−deriveJSON ''Rule
33+users :: Path
73−makeLenses ''Rule
34+users = "users"
74−
75−instance HasContact Rule where
76− contact = rContactMethod
77
35
78-- | List existing notification rules for the specified user.
36-- | List existing notification rules for the specified user.
79--
37--
80-- @GET \/users\/\:user_id\/notification_rules@
38-- @GET \/users\/\:user_id\/notification_rules@
81--
39--
82-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/notification_rules/list>
40-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/notification_rules/list>
83−listRules :: UserId -> Request Empty s Rule
41+listNotificationRules
84−listRules u = empty & path .~ rules u
85
42
86-- | Get details for a notification rule.
43-- | Get details for a notification rule.
87--
44--
88-- @GET \/users\/\:user_id\/notification_rules\/\:id@
45-- @GET \/users\/\:user_id\/notification_rules\/\:id@
89--
46--
90-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/notification_rules/show>
47-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/notification_rules/show>
91−getRule :: UserId -> NotificationRuleId -> Request Empty s Rule
48+getNotificationRule
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
49
111-- | Create a new notification rule for the specified user.
50-- | Create a new notification rule for the specified user.
112--
51--
113-- @POST \/users\/\:user_id\/notification_rules@
52-- @POST \/users\/\:user_id\/notification_rules@
114--
53--
115-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/notification_rules/create>
54-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/notification_rules/create>
116−createRule :: UserId -> ContactId -> Int -> Request CreateRule s Rule
55+createNotificationRule
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
56
142-- | Update an existing notification rule.
57-- | Update an existing notification rule.
143--
58--
144-- @PUT \/users\/\:user_id\/notification_rules\/\:id@
59-- @PUT \/users\/\:user_id\/notification_rules\/\:id@
145--
60--
146-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/notification_rules/update>
61-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/notification_rules/update>
147−updateRule :: UserId -> NotificationRuleId -> Request UpdateRule s Rule
62+updateNotificationRule
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
63
156-- | Remove a notification rule.
64-- | Remove a notification rule.
157--
65--
158-- @DELETE \/users\/\:user_id\/notification_rules\/\:id@
66-- @DELETE \/users\/\:user_id\/notification_rules\/\:id@
159--
67--
160-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/notification_rules/delete>
68-- /See:/ <http://developer.pagerduty.com/documentation/rest/users/notification_rules/delete>
161−deleteRule :: UserId
69+deleteNotificationRule
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−89
@@ -1,9 +1,8 @@
1−{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE TemplateHaskell #-}
2{-# LANGUAGE TemplateHaskell #-}
4
3
5-- Module : Network.PagerDuty.REST.Webhooks
4-- Module : Network.PagerDuty.REST.Webhooks
6−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
5+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
7-- License : This Source Code Form is subject to the terms of
6-- License : This Source Code Form is subject to the terms of
8-- the Mozilla Public License, v. 2.0.
7-- the Mozilla Public License, v. 2.0.
9-- A copy of the MPL can be found in the LICENSE file or
8-- A copy of the MPL can be found in the LICENSE file or
@@ -25,92 +24,9 @@
25--
24--
26-- /See:/ <http://developer.pagerduty.com/documentation/rest/webhooks>
25-- /See:/ <http://developer.pagerduty.com/documentation/rest/webhooks>
27module Network.PagerDuty.REST.Webhooks
26module Network.PagerDuty.REST.Webhooks
28− ( WebhookType (..)
27+ (
29− , Webhook
30− , wId
31− , wType
32− , wCreatedOn
33− ) where
34−
35−import Control.Applicative hiding (empty)
36−import Control.Lens
37−import Data.Aeson
38−import Data.ByteString.Conversion (ToByteString (..),
39− toByteString')
40−import Data.Text (Text)
41−import qualified Data.Text.Encoding as Text
42−import Data.Time
43−import Network.PagerDuty.Internal.TH
44−import Network.PagerDuty.Internal.Types
45−import Network.PagerDuty.REST.Incidents
46−
47−data WebhookType
48− = WTrigger
49− -- ^ Sent when an incident is newly created/triggered.
50− | WAcknowledge
51− -- ^ Sent when an incident has had its status changed from triggered to
52− -- acknowledged.
53− | WUnacknowledge
54− -- ^ Sent when an incident is unacknowledged due to timeout.
55− | WResolve
56− -- ^ Sent when an incident has been resolved.
57− | WAssign
58− -- ^ Sent when an incident has been manually reassigned to another user
59− -- in a different escalation chain.
60− | WEscalate
61− -- ^ Sent when an incident has been escalated to another user in the
62− -- same escalation chain.
63− | WDelegate
64− -- ^ Sent when an incident has been reassigned to another escalation chain.
65− | WOther Text
66− -- ^ /Note:/ As new types of incident actions are supported,
67− -- new incident webhook message types will be added.
68− deriving (Eq, Show)
69−
70−instance ToByteString WebhookType where
71− builder = \case
72− WTrigger -> "incident.trigger"
73− WAcknowledge -> "incident.acknowledge"
74− WUnacknowledge -> "incident.unacknowledge"
75− WResolve -> "incident.resolve"
76− WAssign -> "incident.assign"
77− WEscalate -> "incident.escalate"
78− WDelegate -> "incident.delegate"
79− WOther t -> builder t
80−
81−instance FromJSON WebhookType where
82− parseJSON = withText "status" $ pure . \case
83− "incident.trigger" -> WTrigger
84− "incident.acknowledge" -> WAcknowledge
85− "incident.unacknowledge" -> WUnacknowledge
86− "incident.resolve" -> WResolve
87− "incident.assign" -> WAssign
88− "incident.escalate" -> WEscalate
89− "incident.delegate" -> WDelegate
90− t -> (WOther t)
91−
92−instance ToJSON WebhookType where
93− toJSON = String . Text.decodeUtf8 . toByteString'
94
28
95−data Webhook = Webhook
29+ ) where
96− { _wId :: WebhookId
97− , _wType :: !WebhookType
98− , _wCreatedOn :: !Date
99− , _wData :: Incident
100− } deriving (Eq, Show)
101−
102−deriveJSON ''Webhook
103−
104−instance HasIncident Webhook where
105− incident = lens _wData (\s x -> s { _wData = x })
106−
107−-- | Uniquely identifies this outgoing webhook message; can be used for
108−-- idempotency when processing the messages.
109−makeLens "_wId" ''Webhook
110−
111−-- | The webhook message type.
112−makeLens "_wType" ''Webhook
113
30
114−-- | The date/time when the incident changed state.
31+-- Just create the types + fromJSON instances
115−wCreatedOn :: Lens' Webhook UTCTime
32+decodeWebhook = undefined
116−wCreatedOn = lens _wCreatedOn (\i x -> i { _wCreatedOn = x }) . _D
src/Network/PagerDuty/Internal/TH.hs → src/Network/PagerDuty/TH.hsrenamed+9−9
@@ -1,7 +1,7 @@
1{-# LANGUAGE TemplateHaskell #-}
1{-# LANGUAGE TemplateHaskell #-}
2
2
3−-- Module : Network.PagerDuty.Internal.TH
3+-- Module : Network.PagerDuty.TH
4−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
4+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
5-- License : This Source Code Form is subject to the terms of
5-- License : This Source Code Form is subject to the terms of
6-- the Mozilla Public License, v. 2.0.
6-- the Mozilla Public License, v. 2.0.
7-- A copy of the MPL can be found in the LICENSE file or
7-- A copy of the MPL can be found in the LICENSE file or
@@ -10,7 +10,7 @@
10-- Stability : experimental
10-- Stability : experimental
11-- Portability : non-portable (GHC extensions)
11-- Portability : non-portable (GHC extensions)
12
12
13−module Network.PagerDuty.Internal.TH
13+module Network.PagerDuty.TH
14 (
14 (
15 -- * Requests
15 -- * Requests
16 jsonRequest
16 jsonRequest
@@ -40,15 +40,15 @@ module Network.PagerDuty.Internal.TH
40
40
41import Control.Applicative
41import Control.Applicative
42import Control.Lens
42import Control.Lens
43−import qualified Data.Aeson.TH as Aeson
43+import qualified Data.Aeson.TH as Aeson
44import Data.Aeson.Types
44import Data.Aeson.Types
45−import Data.ByteString (ByteString)
45+import Data.ByteString (ByteString)
46−import qualified Data.Text.Encoding as Text
46+import qualified Data.Text.Encoding as Text
47import Generics.SOP.TH
47import Generics.SOP.TH
48import Language.Haskell.TH
48import Language.Haskell.TH
49import Network.HTTP.Types.QueryLike
49import Network.HTTP.Types.QueryLike
50−import Network.PagerDuty.Internal.Options
50+import Network.PagerDuty.Query
51−import Network.PagerDuty.Internal.Query
51+import Network.PagerDuty.Options
52
52
53jsonRequest :: Name -> Q [Dec]
53jsonRequest :: Name -> Q [Dec]
54jsonRequest n = concat <$> sequence
54jsonRequest n = concat <$> sequence
@@ -61,7 +61,7 @@ queryRequest :: Name -> Q [Dec]
61queryRequest n = concat <$> sequence
61queryRequest n = concat <$> sequence
62 [ deriveGeneric n
62 [ deriveGeneric n
63 , makeLenses n
63 , makeLenses n
64− , [d|instance ToJSON $(conT n) where toJSON = const emptyObject|]
64+ , [d|instance ToJSON $(conT n) where toJSON = const (toJSON (object []))|]
65 , [d|instance QueryLike $(conT n) where toQuery = gquery|]
65 , [d|instance QueryLike $(conT n) where toQuery = gquery|]
66 ]
66 ]
67
67
src/Network/PagerDuty/Types.hs+429−84
@@ -1,5 +1,19 @@
1+{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6+{-# LANGUAGE KindSignatures #-}
7+{-# LANGUAGE OverloadedStrings #-}
8+{-# LANGUAGE PatternSynonyms #-}
9+{-# LANGUAGE RankNTypes #-}
10+{-# LANGUAGE StandaloneDeriving #-}
11+{-# LANGUAGE TemplateHaskell #-}
12+{-# LANGUAGE TupleSections #-}
13+{-# LANGUAGE ViewPatterns #-}
14+
1-- Module : Network.PagerDuty.Types
15-- Module : Network.PagerDuty.Types
2−-- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>
16+-- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
3-- License : This Source Code Form is subject to the terms of
17-- License : This Source Code Form is subject to the terms of
4-- the Mozilla Public License, v. 2.0.
18-- the Mozilla Public License, v. 2.0.
5-- A copy of the MPL can be found in the LICENSE file or
19-- A copy of the MPL can be found in the LICENSE file or
@@ -8,86 +22,417 @@
8-- Stability : experimental
22-- Stability : experimental
9-- Portability : non-portable (GHC extensions)
23-- Portability : non-portable (GHC extensions)
10
24
11−module Network.PagerDuty.Types
25+module Network.PagerDuty.Types where
12− (
26+ -- (
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+ -- -- * Requests
27− , Paginate
28+ -- Auth (..)
29+ -- , Cred (..)
30+ -- , Domain (..)
31+
32+ -- , Request (..)
28− , Request
33+ -- , Request'
29−
34+
35+ -- , Paginate (..)
36+
30− -- ** Errors
37+ -- -- * Errors
31− , Error
38+ -- , Code (..)
32− , _Internal
39+ -- , message
33− , _Integration
40+ -- , RestError (..)
34− , _REST
41+ -- , Error (..)
35− -- *** Messages
42+
36− , HasMessage (..)
43+ -- -- * Primitives
37− -- *** Fields
44+ -- , Key (..)
38− , HasErrors (..)
45+ -- , ServiceKey
39− -- *** Integration
46+ -- , IncidentKey
40− , IntegrationError
47+
41− , status
48+ -- , Id (..)
42− -- *** REST
49+ -- , ServiceId
43− , RESTError
50+ -- , RequesterId
44− , Code
51+
45− , code
52+ -- , Empty (..)
46− , description
53+ -- ) where
47−
54+
55+import Control.Applicative
56+import Control.Lens hiding ((.=))
57+import Data.Aeson hiding (Error)
58+import Data.Aeson.Types (Parser)
59+import Data.ByteString (ByteString)
60+import qualified Data.ByteString.Char8 as BS
61+import Data.ByteString.Conversion hiding (List)
62+import Data.Default.Class
63+import Data.Function (on)
64+import qualified Data.HashMap.Strict as Map
65+import Data.List (deleteBy, intersperse)
66+import Data.Monoid
67+import Data.String
68+import Data.Text (Text)
69+import qualified Data.Text as Text
70+import qualified Data.Text.Encoding as Text
71+import Data.Time
72+import GHC.TypeLits
73+import Network.HTTP.Types
74+import Network.HTTP.Types.QueryLike
75+import Network.PagerDuty.Query
76+import Network.PagerDuty.TH
77+import System.Locale
78+
79+-- FIXME: Verify IncidentId/IncidentKey .. *Id/*Key are actually different or needed
80+
81+newtype CSV a = CSV [a]
82+ deriving (Eq, Show, Monoid)
83+
84+makePrisms ''CSV
85+
86+instance ToByteString a => QueryValues (CSV a)
87+
88+instance ToByteString a => ToByteString (CSV a) where
89+ builder (CSV xs) = mconcat . intersperse "," $ map builder xs
90+
91+instance FromJSON a => FromJSON (CSV a) where
92+ parseJSON = withText "comma_separated_value" $
93+ fmap CSV . traverse (parseJSON . String) . Text.split (== ',')
94+
95+instance ToByteString a => ToJSON (CSV a) where
96+ toJSON = String . Text.decodeUtf8 . toByteString'
97+
98+newtype List a = L [a]
99+ deriving (Eq, Show, Monoid)
100+
101+deriveJSON ''List
102+makePrisms ''List
103+
104+instance QueryValues a => QueryValues (List a) where
105+ queryValues (L xs) = concatMap queryValues xs
106+
107+newtype Bool' = B Bool
108+ deriving (Eq, Show)
109+
110+deriveJSON ''Bool'
111+makePrisms ''Bool'
112+
113+instance ToByteString Bool' where
114+ builder (B True) = "true"
115+ builder (B False) = "false"
116+
117+instance QueryValues Bool'
118+
119+pattern T = B True
120+pattern F = B False
121+
122+newtype Date = D UTCTime
123+ deriving (Eq, Ord, Show)
124+
125+makePrisms ''Date
126+
127+instance FromJSON Date where
128+ parseJSON = fmap D . parseJSON
129+
130+instance ToJSON Date where
131+ toJSON (D d) = toJSON d
132+
133+instance ToByteString Date where
134+ builder (D d) = builder
135+ (formatTime defaultTimeLocale (iso8601DateFormat $ Just "%XZ") d)
136+
137+instance QueryValues Date
138+
139+newtype TZ = TZ TimeZone
140+ deriving (Eq, Show)
141+
142+makePrisms ''TZ
143+
144+instance FromJSON TZ where
145+ parseJSON = undefined
146+
147+instance ToJSON TZ where
148+ toJSON = toJSON . Text.decodeUtf8 . toByteString'
149+
150+instance ToByteString TZ where
151+ builder (TZ tz) = builder (timeZoneName tz)
152+
153+instance QueryValues TZ
154+
155+instance Default TZ where
156+ def = TZ utc
157+
158+data Security = Basic | Token
159+ deriving (Eq, Show)
160+
161+data Auth (a :: Security) where
162+ AuthBasic :: ByteString -> ByteString -> Auth Basic
163+ AuthToken :: ByteString -> Auth Token
164+
165+deriving instance Eq (Auth a)
166+deriving instance Show (Auth a)
167+
168+newtype SubDomain = SubDomain ByteString
169+ deriving (Eq, Show, IsString)
170+
171+domain :: SubDomain -> ByteString
172+domain (SubDomain s)
173+ | base `BS.isSuffixOf` s = s
174+ | otherwise = s <> base
175+ where
176+ base = ".pagerduty.com"
177+
178+newtype Code = Code Integer
179+ deriving (Eq, Show)
180+
181+deriveJSON ''Code
182+
183+description :: Code -> Text
184+description (Code c) =
185+ case c of
186+ 2000 -> "Internal Error"
187+ 2001 -> "Invalid Input Provided"
188+ 2002 -> "Arguments Caused Error"
189+ 2003 -> "Missing Arguments"
190+ 2004 -> "Invalid 'since' or 'until' Parameter Values"
191+ 2005 -> "Invalid Query Date Range"
48− -- ** Authentication
192+ 2006 -> "Authentication Failed"
49− , Security (..)
193+ 2007 -> "Account Not Found"
50− , Auth (..)
194+ 2008 -> "Account Locked"
51−
195+ 2009 -> "Only HTTPS Allowed For This Call"
52− -- ** Keys
196+ 2010 -> "Access Denied"
53− , Key
197+ 2011 -> "The action requires a 'requester_id' to be specified"
54− , mkKey
198+ 2012 -> "Your account is expired and cannot use the API"
55− -- *** Aliases
199+ _ -> "Unrecognised error code"
56− , ServiceKey
200+
57− , IncidentKey
201+data IntegrationError = IntegrationError
58−
202+ { _ieStatus :: Text
59− -- ** Identifiers
203+ , _ieMessage :: Text
60− , Id
204+ , _ieErrors :: [Text]
61− , mkId
205+ } deriving (Eq, Show)
62− -- *** Aliases
206+
207+deriveRecord ''IntegrationError
208+
209+data RestError = RestError
210+ { _reCode :: Code
211+ , _reMessage :: Text
212+ , _reErrors :: [Text]
213+ } deriving (Eq, Show)
214+
215+deriveRecord ''RestError
216+
217+data Error
218+ = Internal String
219+ | Integration IntegrationError
220+ | Rest RestError
221+ deriving (Eq, Show)
222+
223+instance FromJSON Error where
224+ parseJSON o = (Rest <$> parseJSON o)
225+ <|> (Integration <$> parseJSON o)
226+
227+makePrisms ''Error
228+
229+data Pager = Pager
230+ { _pgOffset :: !Int
231+ -- ^ The offset used in the execution of the query.
232+ , _pgLimit :: !Int
233+ -- ^ The limit used in the execution of the query.
234+ , _pgTotal :: !Int
235+ -- ^ The total number of records available.
236+ , _pgQuery :: Maybe Text
237+ -- ^ An optional query= value to be added to the query string.
238+ } deriving (Eq, Show)
239+
240+makeLenses ''Pager
241+
242+instance FromJSON a => FromJSON (a, Maybe Pager) where
243+ parseJSON = withObject "paginated" $ \o -> (,)
244+ <$> parseJSON (Object o)
245+ <*> optional (parse o)
246+ where
247+ parse o = Pager
248+ -- The offset of the first record returned.
249+ -- Default is 0.
250+ <$> o .: "offset" .!= 0
251+ -- The number of records returned.
252+ -- Default (and max limit) is 100 for most APIs.
253+ <*> o .: "limit" .!= 100
254+ <*> o .: "total"
255+ <*> o .:? "query"
256+
257+instance ToJSON Pager where
258+ toJSON p = object
259+ [ "offset" .= _pgOffset p
260+ , "limit" .= _pgLimit p
261+ ]
262+
263+-- | A path segment.
264+data Path where
265+ Path :: Path
266+ Seg :: ToByteString a => a -> Path
267+
268+instance Monoid Path where
269+ mempty = Path
270+ mappend x Path = x
271+ mappend Path y = y
272+ mappend (Seg x) (Seg y) = Seg (builder x <> "/" <> builder y)
273+
274+instance IsString Path where
275+ fromString = Seg
276+
277+instance ToByteString Path where
278+ builder Path = mempty
279+ builder (Seg x) = builder x
280+
281+(%) :: ToByteString a => Path -> a -> Path
282+a % b = a <> Seg b
283+
284+renderPath :: Path -> ByteString
285+renderPath = toByteString' . mappend v1
286+ where
287+ v1 :: Path
288+ v1 = "/api/v1"
289+
290+data Request a (s :: Security) b where
291+ Request :: (QueryLike a, ToJSON a)
292+ => { _rqMeth :: !StdMethod
293+ , _rqPath :: Path
294+ , _rqQuery :: Query
295+ , _rqBody :: a
296+ , _rqPager :: Maybe Pager
297+ , _rqUnwrap :: Value -> Parser Value
298+ }
299+ -> Request a s b
300+
301+instance ToJSON (Request a s b) where
302+ -- Manually unwrapped to ensure GADT constraint holds.
303+ toJSON (Request _ _ _ b p _) = Object $
304+ let Object x = toJSON b
305+ in case toJSON p of
306+ (Object y) -> x <> y
307+ _ -> x
308+
309+type Unwrap = Getting (First Value) Value Value
310+
311+-- | Create a defaulted request from the payload type.
312+mk :: (QueryLike a, ToJSON a) => a -> Request a s b
313+mk x = Request GET mempty mempty x Nothing pure
314+
315+empty :: Request Empty s r
316+empty = mk Empty
317+
318+-- | Lens into the body of a request.
319+upd :: (QueryLike a, ToJSON a) => Lens' (Request a s b) a
320+upd = lens _rqBody (\(Request m p q _ g u) x -> Request m p q x g u)
321+
322+-- | Drop the security constraint.
323+auth :: Request a s b -> Request a t b
324+auth (Request x m p q g u) = Request x m p q g u
325+
326+meth :: Lens' (Request a s b) StdMethod
327+meth = lens _rqMeth (\r x -> r { _rqMeth = x })
328+
329+path :: Lens' (Request a s b) Path
330+path = lens _rqPath (\r x -> r { _rqPath = x })
331+
332+query :: QueryValueLike v
333+ => Lens (Request a s b) (Request a s b) Query [(ByteString, v)]
334+query = lens _rqQuery (\r x -> r { _rqQuery = toQuery x })
335+
336+pager :: Lens' (Request a s b) (Maybe Pager)
337+pager = lens _rqPager (\r x -> r { _rqPager = x })
338+
339+unwrap :: Setter (Request a s b) (Request a s b) (Value -> Parser Value) Unwrap
340+unwrap f r = f (_rqUnwrap r) <&> \k -> r { _rqUnwrap = g k }
341+ where
342+ g k x = maybe (fail "Failed to extract nested keys.") return (x ^? k)
343+
344+-- | Exists primarily to obtain a constraint for the 'paginate' function.
345+class Paginate a where
346+ next :: Request a s b -> Maybe Pager -> Maybe (Request a s b)
347+ next rq = maybe Nothing go
348+ where
349+ go x | x^.pgTotal == 0 = Nothing
350+ | otherwise = Just $
351+ rq & pager ?~ (x & pgOffset +~ x^.pgTotal)
352+ & query %~ (add . clear)
353+ where
354+ add :: Query -> Query
355+ add = maybe id ((:) . (k,) . Just . Text.encodeUtf8) (x^.pgQuery)
356+
357+ clear :: Query -> Query
358+ clear = deleteBy ((==) `on` fst) (k, Nothing)
359+
360+ k :: ByteString
361+ k = "query"
362+
363+newtype Key (a :: Symbol) = Key Text
364+ deriving (Eq, Show, IsString)
365+
366+instance FromJSON (Key a) where
367+ parseJSON = withText "key" (return . Key)
368+
369+instance ToJSON (Key a) where
370+ toJSON (Key k) = toJSON k
371+
372+instance ToByteString (Key a) where
373+ builder (Key k) = builder k
374+
375+instance QueryValues (Key a)
376+
377+instance QueryValueLike (Key a) where
378+ toQueryValue = Just . toByteString'
379+
380+type ServiceKey = Key "service"
381+type IncidentKey = Key "incident"
382+
383+newtype Id (a :: Symbol) = Id Text
384+ deriving (Eq, Show, IsString)
385+
386+instance FromJSON (Id a) where
387+ parseJSON = withText "id" (return . Id)
388+
389+instance ToJSON (Id a) where
390+ toJSON (Id i) = toJSON i
391+
392+instance ToByteString (Id a) where
393+ builder (Id i) = builder i
394+
395+instance QueryValues (Id a)
396+
397+instance QueryValueLike (Id a) where
398+ toQueryValue = Just . toByteString'
399+
63− , AlertId
400+type AlertId = Id "alert"
64− , ContactId
65− , EmailFilterId
401+type EmailFilterId = Id "email-filter"
66− , EscalationPolicyId
402+type IncidentId = Id "incident"
67− , EscalationRuleId
68− , IncidentId
69− , LogEntryId
403+type LogEntryId = Id "log-entry"
70− , NoteId
404+type NoteId = Id "note"
71− , NotificationRuleId
72− , OverrideId
405+type OverrideId = Id "schedule-override"
406+type PolicyId = Id "escalation-policy"
73− , RequesterId
407+type RequesterId = Id "requester"
408+type RuleId = Id "rule"
74− , ScheduleId
409+type ScheduleId = Id "schedule"
75− , ServiceId
410+type ServiceId = Id "service"
76− , UserId
411+type UserId = Id "user"
77− , VendorId
412+type VendorId = Id "vendor"
78− , WebhookId
79− , WindowId
413+type WindowId = Id "maintenance-window"
80−
414+
81− -- ** SubDomain
415+data Empty = Empty
82− , SubDomain
416+
83− , mkSubDomain
417+instance ToJSON Empty where
84−
418+ toJSON = const (object [])
419+
420+instance FromJSON Empty where
421+ parseJSON = withObject "empty" f
422+ where
423+ f !o | Map.null o = pure Empty
424+ | otherwise = fail "Unexpected non-empty JSON object."
425+
426+instance QueryLike Empty where
427+ toQuery = const []
428+
85− -- ** Address
429+newtype Address = Address Text
430+ deriving (Eq, Show)
431+
86− , Address
432+deriveJSON ''Address
87− , mkAddress
433+makePrisms ''Address
88−
434+
89− -- ** Miscellaneous
435+instance ToByteString Address where
90− , Empty (..)
436+ builder (Address a) = builder a
91− ) where
437+
92−
438+instance QueryValues Address
93−import Network.PagerDuty.Internal.Types
stack.yamldeleted−7
@@ -1,7 +0,0 @@
1−resolver: lts-19.23
2−
3−packages:
4−- .
5−
6−nix:
7− packages: [zlib]