diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,373 @@ +Mozilla Public License Version 2.0 +================================== + +1. Definitions +-------------- + +1.1. "Contributor" + means each individual or legal entity that creates, contributes to + the creation of, or owns Covered Software. + +1.2. "Contributor Version" + means the combination of the Contributions of others (if any) used + by a Contributor and that particular Contributor's Contribution. + +1.3. "Contribution" + means Covered Software of a particular Contributor. + +1.4. "Covered Software" + means Source Code Form to which the initial Contributor has attached + the notice in Exhibit A, the Executable Form of such Source Code + Form, and Modifications of such Source Code Form, in each case + including portions thereof. + +1.5. "Incompatible With Secondary Licenses" + means + + (a) that the initial Contributor has attached the notice described + in Exhibit B to the Covered Software; or + + (b) that the Covered Software was made available under the terms of + version 1.1 or earlier of the License, but not also under the + terms of a Secondary License. + +1.6. "Executable Form" + means any form of the work other than Source Code Form. + +1.7. "Larger Work" + means a work that combines Covered Software with other material, in + a separate file or files, that is not Covered Software. + +1.8. "License" + means this document. + +1.9. "Licensable" + means having the right to grant, to the maximum extent possible, + whether at the time of the initial grant or subsequently, any and + all of the rights conveyed by this License. + +1.10. "Modifications" + means any of the following: + + (a) any file in Source Code Form that results from an addition to, + deletion from, or modification of the contents of Covered + Software; or + + (b) any new file in Source Code Form that contains any Covered + Software. + +1.11. "Patent Claims" of a Contributor + means any patent claim(s), including without limitation, method, + process, and apparatus claims, in any patent Licensable by such + Contributor that would be infringed, but for the grant of the + License, by the making, using, selling, offering for sale, having + made, import, or transfer of either its Contributions or its + Contributor Version. + +1.12. "Secondary License" + means either the GNU General Public License, Version 2.0, the GNU + Lesser General Public License, Version 2.1, the GNU Affero General + Public License, Version 3.0, or any later versions of those + licenses. + +1.13. "Source Code Form" + means the form of the work preferred for making modifications. + +1.14. "You" (or "Your") + means an individual or a legal entity exercising rights under this + License. For legal entities, "You" includes any entity that + controls, is controlled by, or is under common control with You. For + purposes of this definition, "control" means (a) the power, direct + or indirect, to cause the direction or management of such entity, + whether by contract or otherwise, or (b) ownership of more than + fifty percent (50%) of the outstanding shares or beneficial + ownership of such entity. + +2. License Grants and Conditions +-------------------------------- + +2.1. Grants + +Each Contributor hereby grants You a world-wide, royalty-free, +non-exclusive license: + +(a) under intellectual property rights (other than patent or trademark) + Licensable by such Contributor to use, reproduce, make available, + modify, display, perform, distribute, and otherwise exploit its + Contributions, either on an unmodified basis, with Modifications, or + as part of a Larger Work; and + +(b) under Patent Claims of such Contributor to make, use, sell, offer + for sale, have made, import, and otherwise transfer either its + Contributions or its Contributor Version. + +2.2. Effective Date + +The licenses granted in Section 2.1 with respect to any Contribution +become effective for each Contribution on the date the Contributor first +distributes such Contribution. + +2.3. Limitations on Grant Scope + +The licenses granted in this Section 2 are the only rights granted under +this License. No additional rights or licenses will be implied from the +distribution or licensing of Covered Software under this License. +Notwithstanding Section 2.1(b) above, no patent license is granted by a +Contributor: + +(a) for any code that a Contributor has removed from Covered Software; + or + +(b) for infringements caused by: (i) Your and any other third party's + modifications of Covered Software, or (ii) the combination of its + Contributions with other software (except as part of its Contributor + Version); or + +(c) under Patent Claims infringed by Covered Software in the absence of + its Contributions. + +This License does not grant any rights in the trademarks, service marks, +or logos of any Contributor (except as may be necessary to comply with +the notice requirements in Section 3.4). + +2.4. Subsequent Licenses + +No Contributor makes additional grants as a result of Your choice to +distribute the Covered Software under a subsequent version of this +License (see Section 10.2) or under the terms of a Secondary License (if +permitted under the terms of Section 3.3). + +2.5. Representation + +Each Contributor represents that the Contributor believes its +Contributions are its original creation(s) or it has sufficient rights +to grant the rights to its Contributions conveyed by this License. + +2.6. Fair Use + +This License is not intended to limit any rights You have under +applicable copyright doctrines of fair use, fair dealing, or other +equivalents. + +2.7. Conditions + +Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted +in Section 2.1. + +3. Responsibilities +------------------- + +3.1. Distribution of Source Form + +All distribution of Covered Software in Source Code Form, including any +Modifications that You create or to which You contribute, must be under +the terms of this License. You must inform recipients that the Source +Code Form of the Covered Software is governed by the terms of this +License, and how they can obtain a copy of this License. You may not +attempt to alter or restrict the recipients' rights in the Source Code +Form. + +3.2. Distribution of Executable Form + +If You distribute Covered Software in Executable Form then: + +(a) such Covered Software must also be made available in Source Code + Form, as described in Section 3.1, and You must inform recipients of + the Executable Form how they can obtain a copy of such Source Code + Form by reasonable means in a timely manner, at a charge no more + than the cost of distribution to the recipient; and + +(b) You may distribute such Executable Form under the terms of this + License, or sublicense it under different terms, provided that the + license for the Executable Form does not attempt to limit or alter + the recipients' rights in the Source Code Form under this License. + +3.3. Distribution of a Larger Work + +You may create and distribute a Larger Work under terms of Your choice, +provided that You also comply with the requirements of this License for +the Covered Software. If the Larger Work is a combination of Covered +Software with a work governed by one or more Secondary Licenses, and the +Covered Software is not Incompatible With Secondary Licenses, this +License permits You to additionally distribute such Covered Software +under the terms of such Secondary License(s), so that the recipient of +the Larger Work may, at their option, further distribute the Covered +Software under the terms of either this License or such Secondary +License(s). + +3.4. Notices + +You may not remove or alter the substance of any license notices +(including copyright notices, patent notices, disclaimers of warranty, +or limitations of liability) contained within the Source Code Form of +the Covered Software, except that You may alter any license notices to +the extent required to remedy known factual inaccuracies. + +3.5. Application of Additional Terms + +You may choose to offer, and to charge a fee for, warranty, support, +indemnity or liability obligations to one or more recipients of Covered +Software. However, You may do so only on Your own behalf, and not on +behalf of any Contributor. You must make it absolutely clear that any +such warranty, support, indemnity, or liability obligation is offered by +You alone, and You hereby agree to indemnify every Contributor for any +liability incurred by such Contributor as a result of warranty, support, +indemnity or liability terms You offer. You may include additional +disclaimers of warranty and limitations of liability specific to any +jurisdiction. + +4. Inability to Comply Due to Statute or Regulation +--------------------------------------------------- + +If it is impossible for You to comply with any of the terms of this +License with respect to some or all of the Covered Software due to +statute, judicial order, or regulation then You must: (a) comply with +the terms of this License to the maximum extent possible; and (b) +describe the limitations and the code they affect. Such description must +be placed in a text file included with all distributions of the Covered +Software under this License. Except to the extent prohibited by statute +or regulation, such description must be sufficiently detailed for a +recipient of ordinary skill to be able to understand it. + +5. Termination +-------------- + +5.1. The rights granted under this License will terminate automatically +if You fail to comply with any of its terms. However, if You become +compliant, then the rights granted under this License from a particular +Contributor are reinstated (a) provisionally, unless and until such +Contributor explicitly and finally terminates Your grants, and (b) on an +ongoing basis, if such Contributor fails to notify You of the +non-compliance by some reasonable means prior to 60 days after You have +come back into compliance. Moreover, Your grants from a particular +Contributor are reinstated on an ongoing basis if such Contributor +notifies You of the non-compliance by some reasonable means, this is the +first time You have received notice of non-compliance with this License +from such Contributor, and You become compliant prior to 30 days after +Your receipt of the notice. + +5.2. If You initiate litigation against any entity by asserting a patent +infringement claim (excluding declaratory judgment actions, +counter-claims, and cross-claims) alleging that a Contributor Version +directly or indirectly infringes any patent, then the rights granted to +You by any and all Contributors for the Covered Software under Section +2.1 of this License shall terminate. + +5.3. In the event of termination under Sections 5.1 or 5.2 above, all +end user license agreements (excluding distributors and resellers) which +have been validly granted by You or Your distributors under this License +prior to termination shall survive termination. + +************************************************************************ +* * +* 6. Disclaimer of Warranty * +* ------------------------- * +* * +* Covered Software is provided under this License on an "as is" * +* basis, without warranty of any kind, either expressed, implied, or * +* statutory, including, without limitation, warranties that the * +* Covered Software is free of defects, merchantable, fit for a * +* particular purpose or non-infringing. The entire risk as to the * +* quality and performance of the Covered Software is with You. * +* Should any Covered Software prove defective in any respect, You * +* (not any Contributor) assume the cost of any necessary servicing, * +* repair, or correction. This disclaimer of warranty constitutes an * +* essential part of this License. No use of any Covered Software is * +* authorized under this License except under this disclaimer. * +* * +************************************************************************ + +************************************************************************ +* * +* 7. Limitation of Liability * +* -------------------------- * +* * +* Under no circumstances and under no legal theory, whether tort * +* (including negligence), contract, or otherwise, shall any * +* Contributor, or anyone who distributes Covered Software as * +* permitted above, be liable to You for any direct, indirect, * +* special, incidental, or consequential damages of any character * +* including, without limitation, damages for lost profits, loss of * +* goodwill, work stoppage, computer failure or malfunction, or any * +* and all other commercial damages or losses, even if such party * +* shall have been informed of the possibility of such damages. This * +* limitation of liability shall not apply to liability for death or * +* personal injury resulting from such party's negligence to the * +* extent applicable law prohibits such limitation. Some * +* jurisdictions do not allow the exclusion or limitation of * +* incidental or consequential damages, so this exclusion and * +* limitation may not apply to You. * +* * +************************************************************************ + +8. Litigation +------------- + +Any litigation relating to this License may be brought only in the +courts of a jurisdiction where the defendant maintains its principal +place of business and such litigation shall be governed by laws of that +jurisdiction, without reference to its conflict-of-law provisions. +Nothing in this Section shall prevent a party's ability to bring +cross-claims or counter-claims. + +9. Miscellaneous +---------------- + +This License represents the complete agreement concerning the subject +matter hereof. If any provision of this License is held to be +unenforceable, such provision shall be reformed only to the extent +necessary to make it enforceable. Any law or regulation which provides +that the language of a contract shall be construed against the drafter +shall not be used to construe this License against a Contributor. + +10. Versions of the License +--------------------------- + +10.1. New Versions + +Mozilla Foundation is the license steward. Except as provided in Section +10.3, no one other than the license steward has the right to modify or +publish new versions of this License. Each version will be given a +distinguishing version number. + +10.2. Effect of New Versions + +You may distribute the Covered Software under the terms of the version +of the License under which You originally received the Covered Software, +or under the terms of any subsequent version published by the license +steward. + +10.3. Modified Versions + +If you create software not governed by this License, and you want to +create a new license for such software, you may create and use a +modified version of this License if you rename the license and remove +any references to the name of the license steward (except to note that +such modified license differs from this License). + +10.4. Distributing Source Code Form that is Incompatible With Secondary +Licenses + +If You choose to distribute Source Code Form that is Incompatible With +Secondary Licenses under the terms of this version of the License, the +notice described in Exhibit B of this License must be attached. + +Exhibit A - Source Code Form License Notice +------------------------------------------- + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at http://mozilla.org/MPL/2.0/. + +If it is not possible or desirable to put the notice in a particular +file, then You may include the notice in a location (such as a LICENSE +file in a relevant directory) where a recipient would be likely to look +for such a notice. + +You may add additional accurate notices of copyright ownership. + +Exhibit B - "Incompatible With Secondary Licenses" Notice +--------------------------------------------------------- + + This Source Code Form is "Incompatible With Secondary Licenses", as + defined by the Mozilla Public License, v. 2.0. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/pagerduty.cabal b/pagerduty.cabal new file mode 100644 --- /dev/null +++ b/pagerduty.cabal @@ -0,0 +1,92 @@ +name: pagerduty +version: 0.0.0 +synopsis: Client library for PagerDuty Integration and REST APIs. +homepage: http://github.com/brendanhay/pagerduty +license: OtherLicense +license-file: LICENSE +author: Brendan Hay +maintainer: Brendan Hay +copyright: Copyright (c) 2013-2014 Brendan Hay, 2014 Kim Altintop +category: Network, PagerDuty, Monitoring +build-type: Simple +cabal-version: >= 1.10 + +description: + PagerDuty is an alerting system for IT professionals. PagerDuty connects + with a variety of systems (including monitoring tools and ticketing + systems) and dispatches alerts via automated phone call, SMS and email. + + This library implements the full PagerDuty Integration and REST APIs which + are documented here: + . + * Integration API - + * REST API - + . + /Warning:/ This is an experimental preview release which is still under + heavy development and not intended for public consumption, caveat emptor! + +extra-source-files: + README.md + +source-repository head + type: git + location: git://github.com/brendanhay/pagerduty.git + +library + default-language: Haskell2010 + hs-source-dirs: src + + ghc-options: -Wall + + exposed-modules: + Control.Monad.Trans.PagerDuty + , Network.PagerDuty.Integration + , Network.PagerDuty.REST + , Network.PagerDuty.REST.Alerts + , Network.PagerDuty.REST.EscalationPolicies + , Network.PagerDuty.REST.EscalationPolicies.EscalationRules + , Network.PagerDuty.REST.Incidents + , Network.PagerDuty.REST.Incidents.Notes + , Network.PagerDuty.REST.LogEntries + , Network.PagerDuty.REST.MaintenanceWindows + , Network.PagerDuty.REST.Reports + , Network.PagerDuty.REST.Schedules + , Network.PagerDuty.REST.Schedules.Overrides + , Network.PagerDuty.REST.Services + , Network.PagerDuty.REST.Services.EmailFilters + , Network.PagerDuty.REST.Users + , Network.PagerDuty.REST.Users.ContactMethods + , Network.PagerDuty.REST.Users.NotificationRules + , Network.PagerDuty.REST.Webhooks + + other-modules: + Network.PagerDuty.Internal.IO + , Network.PagerDuty.Internal.Options + , Network.PagerDuty.Internal.Query + , Network.PagerDuty.Internal.TH + , Network.PagerDuty.Internal.Types + + build-depends: + aeson > 0.7 && <= 0.8 + , base >= 4.5 && < 5.0 + , bifunctors >= 4 + , bytestring >= 0.9 + , bytestring-conversion >= 0.2.1 + , conduit >= 0.5.5 + , data-default-class >= 0.0.1 + , exceptions >= 0.6 + , generics-sop >= 0.1.0.2 + , http-client >= 0.3.6 + , http-types >= 0.8 + , lens >= 4.0 + , lens-aeson >= 1.0 + , mmorph >= 1.0 + , monad-control >= 0.3.2 + , mtl >= 2.2.1 + , old-locale >= 1.0.0.5 + , template-haskell >= 2.2 + , text >= 1.1 + , time == 1.4.* + , transformers >= 0.4.1 + , transformers-base >= 0.4.1 + , unordered-containers >= 0.2.3 diff --git a/src/Control/Monad/Trans/PagerDuty.hs b/src/Control/Monad/Trans/PagerDuty.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/PagerDuty.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- Module : Control.Monad.Trans.PagerDuty +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Control.Monad.Trans.PagerDuty + ( + -- * Transformer + PagerDuty + , PagerDutyT + + -- * Running + , runPagerDutyT + + -- * Configuration + -- ** Environment + , Env + , envDomain + , envAuth + , envManager + , envLogger + , scoped + + -- ** Logging + , Logger (..) + , debug + + -- * Integration events + , submit + , submitCatch + + -- * REST requests + , send + , sendCatch + , paginate + , paginateCatch + + -- * Errors + , Error(..) + , _Internal + , _Integration + , _REST + + -- ** Integration + , IntegrationError + , status + + -- ** REST + , RESTError + , code + + -- ** Code + , Code (..) + , description + + -- ** Fields + , message + , errors + + -- ** Lifting + , hoistError + ) where + +import Control.Applicative +import Control.Monad.Base +import Control.Monad.Catch +import Control.Monad.Except +import Control.Monad.Morph +import Control.Monad.Reader +import Control.Monad.Trans.Control +import Data.Aeson +import Data.Conduit +import Network.PagerDuty.Integration (Event, Response) +import qualified Network.PagerDuty.Integration as Int +import Network.PagerDuty.Internal.Types +import qualified Network.PagerDuty.REST as REST + +-- | A convenient alias for 'PagerDutyT' 'IO'. +type PagerDuty s = PagerDutyT s IO + +newtype PagerDutyT s m a = PagerDutyT + { unPagerDutyT :: ReaderT (Env s) (ExceptT Error m) a + } deriving + ( Functor + , Applicative + , Monad + , MonadIO + , MonadThrow + , MonadCatch + , MonadReader (Env s) + , MonadError Error + ) + +instance MonadTrans (PagerDutyT s) where + lift = PagerDutyT . lift . lift + {-# INLINE lift #-} + +instance MonadBase b m => MonadBase b (PagerDutyT s m) where + liftBase = liftBaseDefault + {-# INLINE liftBase #-} + +instance MonadTransControl (PagerDutyT s) where + newtype StT (PagerDutyT s) a = StTPDT + { unStT :: StT (ExceptT Error) (StT (ReaderT (Env s)) a) + } + + liftWith f = PagerDutyT $ + liftWith $ \g -> + liftWith $ \h -> + f (liftM StTPDT . h . g . unPagerDutyT) + {-# INLINE liftWith #-} + + restoreT = PagerDutyT . restoreT . restoreT . liftM unStT + {-# INLINE restoreT #-} + +instance MonadBaseControl b m => MonadBaseControl b (PagerDutyT s m) where + newtype StM (PagerDutyT s m) a = StMPDT + { unStMPDT :: ComposeSt (PagerDutyT s) m a + } + + liftBaseWith = defaultLiftBaseWith StMPDT + {-# INLINE liftBaseWith #-} + + restoreM = defaultRestoreM unStMPDT + {-# INLINE restoreM #-} + +instance MFunctor (PagerDutyT s) where + hoist nat m = PagerDutyT (ReaderT (ExceptT . nat . runPagerDutyT m)) + {-# INLINE hoist #-} + +instance MMonad (PagerDutyT s) where + embed f m = ask >>= f . runPagerDutyT m >>= either throwError return + {-# INLINE embed #-} + +runPagerDutyT :: PagerDutyT s m a -> Env s -> m (Either Error a) +runPagerDutyT (PagerDutyT k) = runExceptT . runReaderT k + +hoistError :: (MonadError Error m) => Either Error a -> m a +hoistError = either throwError return + +scoped :: MonadReader (Env s) m => (Env s -> m a) -> m a +scoped f = ask >>= f + +submit :: ( MonadIO m + , MonadReader (Env s) m + , MonadError Error m + ) + => Event + -> m Response +submit = submitCatch >=> hoistError + +submitCatch :: ( MonadIO m + , MonadReader (Env s) m + ) + => Event + -> m (Either Error Response) +submitCatch x = scoped $ \e -> Int.submitWith (_envManager e) (_envLogger e) x + +send :: ( MonadIO m + , MonadReader (Env s) m + , MonadError Error m + , FromJSON b + ) + => Request a s b + -> m b +send = sendCatch >=> hoistError + +sendCatch :: ( MonadIO m + , MonadReader (Env s) m + , FromJSON b + ) + => Request a s b + -> m (Either Error b) +sendCatch x = scoped (`REST.sendWith` x) + +paginate :: ( MonadIO m + , MonadReader (Env s) m + , MonadError Error m + , Paginate a + , FromJSON b + ) + => Request a s b + -> Source m b +paginate x = paginateCatch x $= awaitForever (hoistError >=> yield) + +paginateCatch :: ( MonadIO m + , MonadReader (Env s) m + , Paginate a + , FromJSON b + ) + => Request a s b + -> Source m (Either Error b) +paginateCatch x = scoped (`REST.paginateWith` x) diff --git a/src/Network/PagerDuty/Integration.hs b/src/Network/PagerDuty/Integration.hs new file mode 100644 --- /dev/null +++ b/src/Network/PagerDuty/Integration.hs @@ -0,0 +1,292 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- Module : Network.PagerDuty.Integration +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +-- | The PagerDuty event integration API is how you would add PagerDuty's +-- advanced alerting functionality to any system that can make an HTTP API +-- call. You can now add phone, SMS and email alerting to your monitoring +-- tools, ticketing systems and custom software. +-- +-- The API was designed to allow you to easily integrate a +-- monitoring system with a Service in PagerDuty. Monitoring systems +-- generally send out events when problems are detected and when these +-- problems have been resolved (fixed). Some more advanced systems also +-- understand the concept of acknowledgements: problems can be acknowledged +-- by an engineer to signal he or she is working on fixing the issue. +-- +-- Since monitoring systems emit events, the API is based around accepting +-- events. Incoming events (sent via the API) are routed to a PagerDuty +-- service and processed. They may result in a new incident being created, +-- or an existing incident being acknowledged or resolved. +-- +-- The same event-based API can also be used to integrate a PagerDuty +-- service with ticketing systems and various other software tools. +-- +-- /See:/ +module Network.PagerDuty.Integration + ( + -- * Sending events + submit + , submitWith + + -- ** Trigger + , Trigger + , trigger + , client + , clientUrl + + -- ** Acknowledge + , Acknowledge + , acknowledge + + -- ** Resolve + , Resolve + , resolve + + -- * Event fields + , HasServiceKey (..) + , HasIncidentKey (..) + , HasDescription (..) + , HasDetails (..) + + -- * Types + , Event (..) + , _Trigger + , _Acknowledge + , _Resolve + + , Response + , rsStatus + , rsMessage + , rsIncidentKey + ) where + +import Control.Lens +import Control.Monad.IO.Class +import Data.Aeson +import Data.Default.Class +import qualified Data.HashMap.Strict as Map +import Data.Text (Text) +import Network.HTTP.Client (Manager) +import qualified Network.HTTP.Client as Client +import Network.PagerDuty.Internal.IO +import Network.PagerDuty.Internal.TH +import Network.PagerDuty.Internal.Types + +data Response = Response + { _rsStatus :: Text + , _rsMessage :: Text + , _rsIncidentKey :: IncidentKey + } deriving (Eq, Show) + +deriveJSON ''Response + +-- | @success@. +makeLens "_rsStatus" ''Response + +-- | @Event processed@. +makeLens "_rsMessage" ''Response + +-- | The key of the incident that will be affected by the request. +makeLens "_rsIncidentKey" ''Response + +class HasServiceKey s a | s -> a where + -- | The GUID of one of your "Generic API" services. This is the "service key" + -- listed on a Generic API's service detail page. + serviceKey :: Lens' s a + +class HasIncidentKey s a | s -> a where + -- | Identifies the incident to which this trigger event should be applied. + -- If there's no open (i.e. unresolved) incident with this key, a new one + -- will be created. If there's already an open incident with a matching key, + -- this event will be appended to that incident's log. The event key provides + -- an easy way to "de-dup" problem reports. If this field isn't provided, + -- PagerDuty will automatically open a new incident with a unique key. + incidentKey :: Lens' s a + +class HasDescription s a | s -> a where + -- | A short description of the problem that led to this trigger. + -- This field (or a truncated version) will be used when generating phone + -- calls, SMS messages and alert emails. It will also appear on the incidents + -- tables in the PagerDuty UI. The maximum length is 1024 characters. + description :: Lens' s a + +class HasDetails s a | s -> a where + -- | An arbitrary JSON object containing any data you'd like included + -- in the incident log. + details :: Lens' s a + +data Trigger = Trigger' + { _tServiceKey' :: ServiceKey + , _tIncidentKey' :: IncidentKey + , _tDescription' :: Text + , _tDetails' :: Maybe Object + , _tClient' :: Maybe Text + , _tClientUrl' :: Maybe Text + } deriving (Eq, Show) + +deriveRecord ''Trigger + +instance HasServiceKey Trigger ServiceKey where serviceKey = tServiceKey' +instance HasIncidentKey Trigger IncidentKey where incidentKey = tIncidentKey' +instance HasDescription Trigger Text where description = tDescription' +instance HasDetails Trigger (Maybe Object) where details = tDetails' + +-- | The name of the monitoring client that is triggering this event. +client :: Lens' Trigger (Maybe Text) +client = tClient' + +-- | The URL of the monitoring client that is triggering this event. +clientUrl :: Lens' Trigger (Maybe Text) +clientUrl = tClientUrl' + +data Generic = Generic' + { _gServiceKey' :: ServiceKey + , _gIncidentKey' :: IncidentKey + , _gDescription' :: Maybe Text + , _gDetails' :: Maybe Object + } deriving (Eq, Show) + +deriveRecord ''Generic + +instance HasServiceKey Generic ServiceKey where serviceKey = gServiceKey' +instance HasIncidentKey Generic IncidentKey where incidentKey = gIncidentKey' +instance HasDescription Generic (Maybe Text) where description = gDescription' +instance HasDetails Generic (Maybe Object) where details = gDetails' + +type Resolve = Generic +type Acknowledge = Generic + +data Event + = Trigger Trigger -- ^ /See:/ 'trigger' + | Acknowledge Generic -- ^ /See:/ 'acknowledge' + | Resolve Generic -- ^ /See:/ 'resolve' + deriving (Eq, Show) + +makePrisms ''Event + +instance HasServiceKey Event ServiceKey where + serviceKey = lens f g + where + f (Trigger s) = _tServiceKey' s + f (Acknowledge s) = _gServiceKey' s + f (Resolve s) = _gServiceKey' s + + g (Trigger s) x = Trigger $ s { _tServiceKey' = x } + g (Acknowledge s) x = Acknowledge $ s { _gServiceKey' = x } + g (Resolve s) x = Resolve $ s { _gServiceKey' = x } + +instance HasIncidentKey Event IncidentKey where + incidentKey = lens f g + where + f (Trigger s) = _tIncidentKey' s + f (Acknowledge s) = _gIncidentKey' s + f (Resolve s) = _gIncidentKey' s + + g (Trigger s) x = Trigger $ s { _tIncidentKey' = x } + g (Acknowledge s) x = Acknowledge $ s { _gIncidentKey' = x } + g (Resolve s) x = Resolve $ s { _gIncidentKey' = x } + +instance HasDetails Event (Maybe Object) where + details = lens f g + where + f (Trigger s) = _tDetails' s + f (Acknowledge s) = _gDetails' s + f (Resolve s) = _gDetails' s + + g (Trigger s) x = Trigger $ s { _tDetails' = x } + g (Acknowledge s) x = Acknowledge $ s { _gDetails' = x } + g (Resolve s) x = Resolve $ s { _gDetails' = x } + +instance ToJSON Event where + toJSON = \case + Trigger x -> event "trigger" x + Acknowledge x -> event "acknowledge" x + Resolve x -> event "resolve" x + where + event k x = + case toJSON x of + Object o -> Object (Map.insert "event_type" (String k) o) + v -> v + +-- | Your monitoring tools should send PagerDuty a trigger event to report a new +-- or ongoing problem. When PagerDuty receives a trigger event, it will either open +-- a new incident, or add a new trigger log entry to an existing incident, +-- depending on the provided incident_key. +trigger :: ServiceKey -- ^ 'serviceKey' + -> IncidentKey -- ^ 'incidentKey' + -> Text -- ^ 'description' + -> Event +trigger k i d = + Trigger Trigger' + { _tServiceKey' = k + , _tDescription' = d + , _tIncidentKey' = i + , _tClient' = Nothing + , _tClientUrl' = Nothing + , _tDetails' = Nothing + } + +-- | Acknowledge events cause the referenced incident to enter the acknowledged +-- state. +-- +-- While an incident is acknowledged, it won't generate any additional +-- notifications, even if it receives new trigger events. Your monitoring tools +-- should send PagerDuty an acknowledge event when they know someone is +-- presently working on the problem. +acknowledge :: ServiceKey -- ^ 'serviceKey' + -> IncidentKey -- ^ 'incidentKey' + -> Event +acknowledge k i = + Acknowledge Generic' + { _gServiceKey' = k + , _gIncidentKey' = i + , _gDescription' = Nothing + , _gDetails' = Nothing + } + +-- | Resolve events cause the referenced incident to enter the resolved state. +-- +-- Once an incident is resolved, it won't generate any additional +-- notifications. New trigger events with the same incident_key as a resolved +-- incident won't re-open the incident. Instead, a new incident will be +-- created. Your monitoring tools should send PagerDuty a resolve event when the +-- problem that caused the initial trigger event has been fixed. +resolve :: ServiceKey -- ^ 'serviceKey' + -> IncidentKey -- ^ 'incidentKey' + -> Event +resolve k i = + Resolve Generic' + { _gServiceKey' = k + , _gIncidentKey' = i + , _gDescription' = Nothing + , _gDetails' = Nothing + } + +-- | Send an event to the integration API. +submit :: MonadIO m => Manager -> Event -> m (Either Error Response) +submit m = submitWith m None + +-- | /See:/ 'submit' +submitWith :: MonadIO m + => Manager + -> Logger + -> Event + -> m (Either Error Response) +submitWith m l e = request m l e $ + def { Client.host = "events.pagerduty.com" + , Client.path = "/generic/2010-04-15/create_event.json" + } diff --git a/src/Network/PagerDuty/Internal/IO.hs b/src/Network/PagerDuty/Internal/IO.hs new file mode 100644 --- /dev/null +++ b/src/Network/PagerDuty/Internal/IO.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- Module : Network.PagerDuty.Internal.IO +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Network.PagerDuty.Internal.IO where + +import Control.Monad +import Control.Monad.IO.Class +import Data.Aeson hiding (Error) +import qualified Data.ByteString.Lazy as LBS +import Data.Monoid +import qualified Data.Text as Text +import Network.HTTP.Client (Manager, httpLbs) +import qualified Network.HTTP.Client as Client +import Network.HTTP.Types +import Network.PagerDuty.Internal.Types + +request :: (MonadIO m, ToJSON a, FromJSON b) + => Manager + -> Logger + -> a + -> Client.Request + -> m (Either Error b) +request m l x rq = msg >> liftIO (httpLbs raw m) >>= response l + where + msg = debug l ("[Raw Request]\n" <> Text.pack (show raw)) + + raw = rq + { Client.secure = True + , Client.port = 443 + , Client.requestHeaders = headers + , Client.requestBody = Client.RequestBodyLBS (encode x) + } + + headers = + [ ("Content-Type", "application/json") + , ("Accept", "application/json") + ] + +response :: forall m b. (MonadIO m, FromJSON b) + => Logger + -> Client.Response LBS.ByteString + -> m (Either Error b) +response l rs = case statusCode (Client.responseStatus rs) of + 200 -> success + 201 -> success + 400 -> failure + 500 -> failure + n -> return . Left $ unhandled n + where + success = maybe (Left unknown) Right `liftM` parse + failure = maybe (Left unknown) Left `liftM` parse + + unhandled n = Internal $ + "PagerDuty returned unhandled status code: " + <> Text.pack (show n) + + unknown = Internal $ + "Unable to parse response into a PagerDuty API compatible type: " + <> Text.pack (show body) + + parse :: FromJSON a => m (Maybe a) + parse = msg >> return (decode body) + + msg = debug l ("[Raw Response]\n" <> Text.pack (show rs)) + + body = Client.responseBody rs diff --git a/src/Network/PagerDuty/Internal/Options.hs b/src/Network/PagerDuty/Internal/Options.hs new file mode 100644 --- /dev/null +++ b/src/Network/PagerDuty/Internal/Options.hs @@ -0,0 +1,56 @@ +-- Module : Network.PagerDuty.Internal.Options +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Network.PagerDuty.Internal.Options + ( dropped + , hyphenated + , underscored + ) where + +import Data.Aeson.Types +import Data.Char +import Data.List + +dropped :: Int -> Options -> Options +dropped n o = o + { constructorTagModifier = constructorTagModifier o . drop n + } + +hyphenated :: Options +hyphenated = underscored + { fieldLabelModifier = unsuffix . hyphenate . unprefix + , constructorTagModifier = hyphenate + } + +underscored :: Options +underscored = defaultOptions + { fieldLabelModifier = unsuffix . underscore . unprefix + , constructorTagModifier = underscore + , omitNothingFields = True + , allNullaryToStringTag = True + } + +hyphenate :: String -> String +hyphenate = intercalate "-" . map lower . splitBy isUpper + +underscore :: String -> String +underscore = intercalate "_" . map lower . splitBy isUpper + +lower :: String -> String +lower = map toLower + +unsuffix :: String -> String +unsuffix = takeWhile (/= '\'') + +unprefix :: String -> String +unprefix = dropWhile (not . isUpper) + +splitBy :: (a -> Bool) -> [a] -> [[a]] +splitBy p = groupBy (const (not . p)) diff --git a/src/Network/PagerDuty/Internal/Query.hs b/src/Network/PagerDuty/Internal/Query.hs new file mode 100644 --- /dev/null +++ b/src/Network/PagerDuty/Internal/Query.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +-- Module : Network.PagerDuty.Internal.Query +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Network.PagerDuty.Internal.Query + ( QueryValues (..) + , gquery + , gqueryWith + ) where + +import Data.Aeson.Types +import Data.Bifunctor +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import Data.ByteString.Conversion +import Data.Function (on) +import Data.List (groupBy) +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text.Encoding as Text +import Generics.SOP +import Network.HTTP.Types +import Network.PagerDuty.Internal.Options + +class QueryValues a where + queryValues :: a -> [ByteString] + + default queryValues :: ToByteString a => a -> [ByteString] + queryValues = (:[]) . toByteString' + +instance QueryValues a => QueryValues (Maybe a) where + queryValues (Just x) = queryValues x + queryValues Nothing = [] + +instance QueryValues Text where + queryValues x = [Text.encodeUtf8 x] + +gquery :: forall a. (Generic a, HasDatatypeInfo a, All2 QueryValues (Code a)) + => a + -> Query +gquery = gqueryWith underscored + +gqueryWith :: forall a. (Generic a, HasDatatypeInfo a, All2 QueryValues (Code a)) + => Options + -> a + -> Query +gqueryWith o a = case datatypeInfo (Proxy :: Proxy a) of + ADT _ _ cs -> go cs (from a) + Newtype _ _ c -> go (c :* Nil) (from a) + where + go :: (All2 QueryValues xss, SingI xss) + => NP ConstructorInfo xss + -> SOP I xss + -> Query + go cs (SOP sop) = group . unI . hcollapse $ hcliftA2' p (gctor o) cs sop + + group :: [(ByteString, ByteString)] -> Query + group = concatMap f . groupBy ((==) `on` fst) + where + f [] = [] + f [(k, v)] = [(k, Just v)] + f xs@((k,_):_) = let n = k <> "[]" in map (bimap (const n) Just) xs + +gctor :: All QueryValues xs + => Options + -> ConstructorInfo xs + -> NP I xs + -> K [(ByteString, ByteString)] xs +gctor o (Constructor n) args = + K . concat . hcollapse $ hcliftA p (K . map (k,) . queryValues . unI) args + where + k = BS.pack (constructorTagModifier o n) + +gctor o (Record _ ns) args = + K . concat . hcollapse $ hcliftA2 p (gfield o) ns args + +gctor o (Infix n _ _) (x :* y :* Nil) = + K $ map (k,) (queryValues (unI x) ++ queryValues (unI y)) + where + k = BS.pack (constructorTagModifier o n) + +gctor _ Infix{} _ = + error "Network.PagerDuty.Generics.inaccessible" + +gfield :: QueryValues a + => Options + -> FieldInfo a + -> I a + -> K [(ByteString, ByteString)] a +gfield o (FieldInfo f) (I a) = + K $ map (k,) (queryValues a) + where + k = BS.pack (fieldLabelModifier o f) + +p :: Proxy QueryValues +p = Proxy diff --git a/src/Network/PagerDuty/Internal/TH.hs b/src/Network/PagerDuty/Internal/TH.hs new file mode 100644 --- /dev/null +++ b/src/Network/PagerDuty/Internal/TH.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- Module : Network.PagerDuty.Internal.TH +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Network.PagerDuty.Internal.TH + ( + -- * Requests + jsonRequest + , queryRequest + + -- * Compound expressions + , deriveNullary + , deriveNullaryWith + , deriveRecord + + -- * JSON + , deriveJSON + , deriveJSONWith + + -- * Lenses + , makeLens + , makeFields + + -- * Re-exported generics + , deriveGeneric + + -- * Re-exported options + , dropped + , hyphenated + , underscored + ) where + +import Control.Applicative +import Control.Lens +import qualified Data.Aeson.TH as Aeson +import Data.Aeson.Types +import Data.ByteString (ByteString) +import qualified Data.Text.Encoding as Text +import Generics.SOP.TH +import Language.Haskell.TH +import Network.HTTP.Types.QueryLike +import Network.PagerDuty.Internal.Query +import Network.PagerDuty.Internal.Options + +jsonRequest :: Name -> Q [Dec] +jsonRequest n = concat <$> sequence + [ makeLenses n + , deriveJSON n + , [d|instance QueryLike $(conT n) where toQuery = const []|] + ] + +queryRequest :: Name -> Q [Dec] +queryRequest n = concat <$> sequence + [ deriveGeneric n + , makeLenses n + , [d|instance ToJSON $(conT n) where toJSON = const (toJSON (object []))|] + , [d|instance QueryLike $(conT n) where toQuery = gquery|] + ] + +deriveNullary :: Name -> Q [Dec] +deriveNullary = deriveNullaryWith underscored + +deriveNullaryWith :: Options -> Name -> Q [Dec] +deriveNullaryWith o n = concat <$> sequence + [ deriveJSONWith o n + , [d|instance QueryValues $(conT n) where queryValues = value . toJSON|] + ] + +deriveRecord :: Name -> Q [Dec] +deriveRecord n = concat <$> sequence + [ deriveJSON n + , makeLenses n + ] + +deriveJSON :: Name -> Q [Dec] +deriveJSON = deriveJSONWith underscored + +deriveJSONWith :: Options -> Name -> Q [Dec] +deriveJSONWith = Aeson.deriveJSON + +makeLens :: String -> Name -> Q [Dec] +makeLens k = makeLensesWith + $ lensRulesFor [(k, drop 1 k)] + & simpleLenses .~ True + +value :: Value -> [ByteString] +value (String t) = [Text.encodeUtf8 t] +value _ = [] diff --git a/src/Network/PagerDuty/Internal/Types.hs b/src/Network/PagerDuty/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/PagerDuty/Internal/Types.hs @@ -0,0 +1,480 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +-- Module : Network.PagerDuty.Internal.Types +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Network.PagerDuty.Internal.Types where + +import Control.Applicative +import Control.Lens hiding ((.=)) +import Control.Monad.IO.Class +import Data.Aeson hiding (Error) +import Data.Aeson.Types (Parser) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import Data.ByteString.Conversion hiding (List) +import Data.Default.Class +import Data.Function (on) +import qualified Data.HashMap.Strict as Map +import Data.List (deleteBy, intersperse) +import Data.Monoid +import Data.String +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Data.Time +import GHC.TypeLits +import Network.HTTP.Client (Manager) +import Network.HTTP.Types +import Network.HTTP.Types.QueryLike +import Network.PagerDuty.Internal.Query +import Network.PagerDuty.Internal.TH +import System.Locale + +-- FIXME: Verify IncidentId/IncidentKey .. *Id/*Key are actually different or needed + +newtype CSV a = CSV [a] + deriving (Eq, Show, Monoid) + +makePrisms ''CSV + +instance ToByteString a => QueryValues (CSV a) + +instance ToByteString a => ToByteString (CSV a) where + builder (CSV xs) = mconcat . intersperse "," $ map builder xs + +instance FromJSON a => FromJSON (CSV a) where + parseJSON = withText "comma_separated_value" $ + fmap CSV . traverse (parseJSON . String) . Text.split (== ',') + +instance ToByteString a => ToJSON (CSV a) where + toJSON = String . Text.decodeUtf8 . toByteString' + +newtype List a = L [a] + deriving (Eq, Show, Monoid) + +deriveJSON ''List +makePrisms ''List + +instance QueryValues a => QueryValues (List a) where + queryValues (L xs) = concatMap queryValues xs + +newtype Bool' = B Bool + deriving (Eq, Show) + +deriveJSON ''Bool' +makePrisms ''Bool' + +instance ToByteString Bool' where + builder (B True) = "true" + builder (B False) = "false" + +instance QueryValues Bool' + +pattern T = B True +pattern F = B False + +newtype Date = D UTCTime + deriving (Eq, Ord, Show) + +makePrisms ''Date + +instance FromJSON Date where + parseJSON = fmap D . parseJSON + +instance ToJSON Date where + toJSON (D d) = toJSON d + +instance ToByteString Date where + builder (D d) = builder + (formatTime defaultTimeLocale (iso8601DateFormat $ Just "%XZ") d) + +instance QueryValues Date + +newtype TZ = TZ TimeZone + deriving (Eq, Show) + +makePrisms ''TZ + +instance FromJSON TZ where + parseJSON = undefined + +instance ToJSON TZ where + toJSON = toJSON . Text.decodeUtf8 . toByteString' + +instance ToByteString TZ where + builder (TZ tz) = builder (timeZoneName tz) + +instance QueryValues TZ + +instance Default TZ where + def = TZ utc + +data Security = Basic | Token + deriving (Eq, Show) + +data Auth (a :: Security) where + AuthBasic :: ByteString -> ByteString -> Auth Basic + AuthToken :: ByteString -> Auth Token + +deriving instance Eq (Auth a) +deriving instance Show (Auth a) + +newtype SubDomain = SubDomain { subDomain :: ByteString } + deriving (Eq, Show, IsString) + +domain :: SubDomain -> ByteString +domain (SubDomain s) + | base `BS.isSuffixOf` s = s + | otherwise = s <> base + where + base = ".pagerduty.com" + +-- | The log level and associated logger function. +data Logger + = None + | Debug (Text -> IO ()) + +-- | Log a message using the debug logger, or if none is specified noop. +debug :: MonadIO m => Logger -> Text -> m () +debug None = const (return ()) +debug (Debug f) = liftIO . f + +-- | The environment containing the parameters required to +-- make PagerDuty requests. +data Env (s :: Security) = Env + { _envDomain :: SubDomain + , _envAuth' :: Auth s + , _envManager :: Manager + , _envLogger :: Logger + } + +makeLenses ''Env + +envAuth :: forall s s'. Lens (Env s) (Env s') (Auth s) (Auth s') +envAuth = lens _envAuth' (\s x -> s { _envAuth' = x }) + +prod :: SubDomain -> Auth s -> Manager -> Env s +prod d a m = Env d a m None + +newtype Code = Code Integer + deriving (Eq, Show) + +deriveJSON ''Code + +description :: Code -> Text +description (Code c) = + case c of + 2000 -> "Internal Error" + 2001 -> "Invalid Input Provided" + 2002 -> "Arguments Caused Error" + 2003 -> "Missing Arguments" + 2004 -> "Invalid 'since' or 'until' Parameter Values" + 2005 -> "Invalid Query Date Range" + 2006 -> "Authentication Failed" + 2007 -> "Account Not Found" + 2008 -> "Account Locked" + 2009 -> "Only HTTPS Allowed For This Call" + 2010 -> "Access Denied" + 2011 -> "The action requires a 'requester_id' to be specified" + 2012 -> "Your account is expired and cannot use the API" + _ -> "Unrecognised error code" + +class HasMessage s a | s -> a where + -- | A short human-readable message describing the error. + message :: Lens' s a + +class HasErrors s a | s -> a where + -- | A list of human-readable reasons for the error. These values, + -- and even their format, are subject to change. + errors :: Lens' s a + +data IntegrationError = IntegrationError + { _ieStatus :: Text + , _ieMessage :: Text + , _ieErrors :: [Text] + } deriving (Eq, Show) + +deriveRecord ''IntegrationError + +instance HasMessage IntegrationError Text where message = ieMessage +instance HasErrors IntegrationError [Text] where errors = ieErrors + +status :: Lens' IntegrationError Text +status = ieStatus + +data RESTError = RESTError + { _reCode :: Code + , _reMessage :: Text + , _reErrors :: [Text] + } deriving (Eq, Show) + +deriveRecord ''RESTError + +instance HasMessage RESTError Text where message = reMessage +instance HasErrors RESTError [Text] where errors = reErrors + +-- | In the case of an error, the PagerDuty error code can give further details +-- on the nature of the error. +-- +-- /See:/ 'description' +code :: Lens' RESTError Code +code = reCode + +data Error + = Internal Text + | Integration IntegrationError + | REST RESTError + deriving (Eq, Show) + +instance FromJSON Error where + parseJSON o = (REST <$> parseJSON o) + <|> (Integration <$> parseJSON o) + +makePrisms ''Error + +instance HasMessage Error Text where + message = lens f g + where + f (Internal x) = x + f (Integration s) = _ieMessage s + f (REST s) = _reMessage s + + g (Internal _) x = Internal x + g (Integration s) x = Integration $ s { _ieMessage = x } + g (REST s) x = REST $ s { _reMessage = x } + +data Pager = Pager + { _pgOffset :: !Int + -- ^ The offset used in the execution of the query. + , _pgLimit :: !Int + -- ^ The limit used in the execution of the query. + , _pgTotal :: !Int + -- ^ The total number of records available. + , _pgQuery :: Maybe Text + -- ^ An optional query= value to be added to the query string. + } deriving (Eq, Show) + +makeLenses ''Pager + +instance FromJSON a => FromJSON (a, Maybe Pager) where + parseJSON = withObject "paginated" $ \o -> (,) + <$> parseJSON (Object o) + <*> optional (parse o) + where + parse o = Pager + -- The offset of the first record returned. + -- Default is 0. + <$> o .: "offset" .!= 0 + -- The number of records returned. + -- Default (and max limit) is 100 for most APIs. + <*> o .: "limit" .!= 100 + <*> o .: "total" + <*> o .:? "query" + +instance ToJSON Pager where + toJSON p = object + [ "offset" .= _pgOffset p + , "limit" .= _pgLimit p + ] + +-- | A path segment. +data Path where + Path :: Path + Seg :: ToByteString a => a -> Path + +instance Monoid Path where + mempty = Path + mappend x Path = x + mappend Path y = y + mappend (Seg x) (Seg y) = Seg (builder x <> "/" <> builder y) + +instance IsString Path where + fromString = Seg + +instance ToByteString Path where + builder Path = mempty + builder (Seg x) = builder x + +(%) :: ToByteString a => Path -> a -> Path +a % b = a <> Seg b + +renderPath :: Path -> ByteString +renderPath = toByteString' . mappend v1 + where + v1 :: Path + v1 = "/api/v1" + +data Request a (s :: Security) b where + Request :: (QueryLike a, ToJSON a) + => { _rqMeth :: !StdMethod + , _rqPath :: Path + , _rqQuery :: Query + , _rqBody :: a + , _rqPager :: Maybe Pager + , _rqUnwrap :: Value -> Parser Value + } + -> Request a s b + +instance ToJSON (Request a s b) where + -- Manually unwrapped to ensure GADT constraint holds. + toJSON (Request _ _ _ b p _) = Object $ + let Object x = toJSON b + in case toJSON p of + (Object y) -> x <> y + _ -> x + +type Unwrap = Getting (First Value) Value Value + +-- | Create a defaulted request from the payload type. +mk :: (QueryLike a, ToJSON a) => a -> Request a s b +mk x = Request GET mempty mempty x Nothing pure + +empty :: Request Empty s r +empty = mk Empty + +-- | Lens into the body of a request. +upd :: (QueryLike a, ToJSON a) => Lens' (Request a s b) a +upd = lens _rqBody (\(Request m p q _ g u) x -> Request m p q x g u) + +-- | Drop the security constraint. +auth :: Request a s b -> Request a t b +auth (Request x m p q g u) = Request x m p q g u + +meth :: Lens' (Request a s b) StdMethod +meth = lens _rqMeth (\r x -> r { _rqMeth = x }) + +path :: Lens' (Request a s b) Path +path = lens _rqPath (\r x -> r { _rqPath = x }) + +query :: QueryValueLike v + => Lens (Request a s b) (Request a s b) Query [(ByteString, v)] +query = lens _rqQuery (\r x -> r { _rqQuery = toQuery x }) + +pager :: Lens' (Request a s b) (Maybe Pager) +pager = lens _rqPager (\r x -> r { _rqPager = x }) + +unwrap :: Setter (Request a s b) (Request a s b) (Value -> Parser Value) Unwrap +unwrap f r = f (_rqUnwrap r) <&> \k -> r { _rqUnwrap = g k } + where + g k x = maybe (fail "Failed to extract nested keys.") return (x ^? k) + +-- | Exists primarily to obtain a constraint for the 'paginate' function. +class Paginate a where + next :: Request a s b -> Maybe Pager -> Maybe (Request a s b) + next rq = maybe Nothing go + where + go x | x^.pgTotal == 0 = Nothing + | otherwise = Just $ + rq & pager ?~ (x & pgOffset +~ x^.pgTotal) + & query %~ (add . clear) + where + add :: Query -> Query + add = maybe id ((:) . (k,) . Just . Text.encodeUtf8) (x^.pgQuery) + + clear :: Query -> Query + clear = deleteBy ((==) `on` fst) (k, Nothing) + + k :: ByteString + k = "query" + +newtype Key (a :: Symbol) = Key Text + deriving (Eq, Show, IsString) + +instance FromJSON (Key a) where + parseJSON = withText "key" (return . Key) + +instance ToJSON (Key a) where + toJSON (Key k) = toJSON k + +instance ToByteString (Key a) where + builder (Key k) = builder k + +instance QueryValues (Key a) + +instance QueryValueLike (Key a) where + toQueryValue = Just . toByteString' + +type ServiceKey = Key "service" +type IncidentKey = Key "incident" + +newtype Id (a :: Symbol) = Id Text + deriving (Eq, Show, IsString) + +instance FromJSON (Id a) where + parseJSON = withText "id" (return . Id) + +instance ToJSON (Id a) where + toJSON (Id i) = toJSON i + +instance ToByteString (Id a) where + builder (Id i) = builder i + +instance QueryValues (Id a) + +instance QueryValueLike (Id a) where + toQueryValue = Just . toByteString' + +type AlertId = Id "alert" +type ContactId = Id "contact" +type EmailFilterId = Id "email-filter" +type EscalationPolicyId = Id "escalation-policy" +type EscalationRuleId = Id "escalation-rule" +type IncidentId = Id "incident" +type LogEntryId = Id "log-entry" +type NoteId = Id "note" +type NotificationRuleId = Id "notification-rule" +type OverrideId = Id "schedule-override" +type RequesterId = Id "requester" +type ScheduleId = Id "schedule" +type ServiceId = Id "service" +type UserId = Id "user" +type VendorId = Id "vendor" +type WebhookId = Id "webhook" +type WindowId = Id "maintenance-window" + +data Empty = Empty + +instance ToJSON Empty where + toJSON = const (object []) + +instance FromJSON Empty where + parseJSON = withObject "empty" f + where + f !o | Map.null o = pure Empty + | otherwise = fail "Unexpected non-empty JSON object." + +instance QueryLike Empty where + toQuery = const [] + +newtype Address = Address Text + deriving (Eq, Show) + +deriveJSON ''Address +makePrisms ''Address + +instance ToByteString Address where + builder (Address a) = builder a + +instance QueryValues Address diff --git a/src/Network/PagerDuty/REST.hs b/src/Network/PagerDuty/REST.hs new file mode 100644 --- /dev/null +++ b/src/Network/PagerDuty/REST.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} + +-- Module : Network.PagerDuty.REST +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Network.PagerDuty.REST + ( + + -- * Sending requests + send + , paginate + + -- * Configuration + -- ** Environment + , Env + , envDomain + , envAuth + , envManager + , envLogger + + -- ** Requests + , sendWith + , paginateWith + ) where + +import Control.Applicative +import Control.Lens +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans +import Data.Aeson (FromJSON) +import Data.Conduit +import Data.Default.Class +import Data.Monoid +import Network.HTTP.Client (Manager) +import qualified Network.HTTP.Client as Client +import Network.HTTP.Types +import Network.PagerDuty.Internal.IO +import Network.PagerDuty.Internal.Types + +-- FIXME: verify correct actions are all paginated +-- FIXME: Ensure RequesterId parameter is always most significant param +-- FIXME: add smart constructors for all types, for testing purposes + +send :: (MonadIO m, FromJSON b) + => SubDomain + -> Auth s + -> Manager + -> Request a s b + -> m (Either Error b) +send d a m = sendWith (prod d a m) + +-- | /See:/ 'sendWith' +sendWith :: (MonadIO m, FromJSON b) + => Env s + -> Request a s b + -> m (Either Error b) +sendWith e = liftM (fmap fst) . http e + +paginate :: (MonadIO m, Paginate a, FromJSON b) + => SubDomain + -> Auth s + -> Manager + -> Request a s b + -> Source m (Either Error b) +paginate d a m = paginateWith (prod d a m) + +-- | /See:/ 'paginateWith' +paginateWith :: (MonadIO m, Paginate a, FromJSON b) + => Env s + -> Request a s b + -> Source m (Either Error b) +paginateWith e = go + where + go rq = do + rs <- lift (http e rq) + yield (fst <$> rs) + either (const (return ())) + (maybe (return ()) go . next rq . snd) + rs + +http :: (MonadIO m, FromJSON b) + => Env s + -> Request a s b + -> m (Either Error (b, Maybe Pager)) +http e rq = request (e ^. envManager) (e ^. envLogger) rq $ raw + { Client.host = domain (e ^. envDomain) + , Client.path = renderPath (rq ^. path) + , Client.queryString = renderQuery False (rq ^. query) + } + where + raw = case e ^. envAuth of + AuthBasic u p -> Client.applyBasicAuth u p def + AuthToken t -> def + { Client.requestHeaders = [("Authorization", "Token token=" <> t)] + } diff --git a/src/Network/PagerDuty/REST/Alerts.hs b/src/Network/PagerDuty/REST/Alerts.hs new file mode 100644 --- /dev/null +++ b/src/Network/PagerDuty/REST/Alerts.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +-- Module : Network.PagerDuty.REST.Alerts +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +-- | When an incident is triggered or when it is escalated it creates an alert +-- (also known as a notification). Alerts are messages containing the details +-- of the incident, and can be sent through SMS, email, phone calls, +-- and push notifications. +-- +-- This API allows you to access read-only data regarding what alerts have been +-- sent to your users. +-- +-- /See:/ +module Network.PagerDuty.REST.Alerts + ( + -- * List Alerts + ListAlerts + , listAlerts + , laSince + , laUntil + , laFilter + , laTimeZone + + -- * Types + , AlertType (..) + + , Alert + , alertId + , alertType + , alertStartedAt + , alertUser + , alertAddress + ) where + +import Control.Lens +import Data.Aeson.Lens +import Data.Time +import Network.PagerDuty.REST.Users (User) +import Network.PagerDuty.Internal.TH +import Network.PagerDuty.Internal.Types + +alerts :: Path +alerts = "alerts" + +data AlertType + = SMS + | Email + | Phone + | Push + deriving (Eq, Show) + +deriveNullary ''AlertType + +data Alert = Alert + { _alertId :: AlertId + , _alertType :: AlertType + , _alertStartedAt :: Date + , _alertUser :: User + , _alertAddress :: Address + } deriving (Eq, Show) + +deriveRecord ''Alert + +data ListAlerts = ListAlerts + { _laSince' :: Date + , _laUntil' :: Date + , _laFilter' :: Maybe AlertType + , _laTimeZone' :: Maybe TZ + } deriving (Eq, Show) + +instance Paginate ListAlerts + +queryRequest ''ListAlerts + +-- | The start of the date range over which you want to search. +laSince :: Lens' (Request ListAlerts s b) UTCTime +laSince = upd.laSince'._D + +-- | The end of the date range over which you want to search. +-- This should be in the same format as 'since'. +-- +-- The size of the date range must be less than 3 months. +laUntil :: Lens' (Request ListAlerts s b) UTCTime +laUntil = upd.laUntil'._D + +-- | Returns only the alerts of the said 'AlertType' type. +laFilter :: Lens' (Request ListAlerts s b) (Maybe AlertType) +laFilter = upd.laFilter' + +-- | Time zone in which dates in the result will be rendered. +-- +-- /Default:/ account time zone. +laTimeZone :: Lens' (Request ListAlerts s b) (Maybe TimeZone) +laTimeZone = upd.laTimeZone'.mapping _TZ + +-- | List existing alerts for a given time range, optionally filtered by type +-- (SMS, Email, Phone, or Push). +-- +-- @GET \/alerts@ +-- +-- /See:/ +listAlerts :: Date -- ^ 'laSince' + -> Date -- ^ 'laUntil' + -> Request ListAlerts s [Alert] +listAlerts s u = + mk ListAlerts + { _laSince' = s + , _laUntil' = u + , _laFilter' = Nothing + , _laTimeZone' = Nothing + } & path .~ alerts + & unwrap .~ key "alerts" diff --git a/src/Network/PagerDuty/REST/EscalationPolicies.hs b/src/Network/PagerDuty/REST/EscalationPolicies.hs new file mode 100644 --- /dev/null +++ b/src/Network/PagerDuty/REST/EscalationPolicies.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +-- Module : Network.PagerDuty.REST.EscalationPolicies +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +-- | This API lets you access and manipulate escalation policies and rules. +-- +-- /See:/ +module Network.PagerDuty.REST.EscalationPolicies + ( + -- * List Policies + ListPolicies + , listPolicies + , lpQuery + + -- * List On Call Policies + , listOnCallPolicies + + -- * Create Policy + , CreatePolicy + , createPolicy + , cpName + , cpRepeatEnabled + , cpNumLoops + , cpEscalationRules + + -- * Get Policy + , getPolicy + + -- * Update Policy + , UpdatePolicy + , updatePolicy + , upName + , upRepeatEnabled + , upNumLoops + , upEscalationRules + + -- * Delete Policy + , deletePolicy + + -- * Types + , Policy + , pId + , pName + , pNumLoops + , pRules + , pServices + ) where + +import Control.Lens +import Data.Aeson.Lens +import Data.Text (Text) +import Network.HTTP.Types +import Network.PagerDuty.REST.Services (Service) +import Network.PagerDuty.Internal.TH +import Network.PagerDuty.Internal.Types + +import Network.PagerDuty.REST.EscalationPolicies.EscalationRules + +default (Path) + +policies :: Path +policies = "escalation_policies" + +data Policy = Policy + { _pId :: EscalationPolicyId + , _pName :: Text + , _pNumLoops :: !Int + , _pRules :: [Rule] + , _pServices :: [Service] + } deriving (Eq, Show) + +deriveJSON ''Policy + +-- | The ID of the escalation policy. +makeLens "_pId" ''Policy + +-- | The name of the escalation policy. +makeLens "_pName" ''Policy + +-- | The number of times the escalation policy will repeat after +-- reaching the end of its escalation. +makeLens "_pNumLoops" ''Policy + +-- | A list of the policy's escalation rules in order of escalation. +makeLens "_pRules" ''Policy + +-- | A list of services using this escalation policy. +makeLens "_pServices" ''Policy + +newtype ListPolicies = ListPolicies + { _lpQuery' :: Maybe Text + } deriving (Eq, Show) + +instance Paginate ListPolicies + +queryRequest ''ListPolicies + +-- | Filters the result, showing only the escalation policies +-- whose names match the query. +lpQuery :: Lens' (Request ListPolicies s b) (Maybe Text) +lpQuery = upd.lpQuery' + +-- | List all the existing escalation policies. +-- +-- @GET \/escalation_policies@ +-- +-- /See:/ +listPolicies :: Request ListPolicies s [Policy] +listPolicies = + mk ListPolicies + { _lpQuery' = Nothing + } & path .~ policies + & unwrap .~ key "escalation_policies" + +-- | List all the existing escalation policies with currently on-call users. +-- +-- If the start and end of an on-call object are null, then the user is always +-- on-call for an escalation policy level. +-- +-- @GET \/escalation_policies\/on_call@ +-- +-- /See:/ +listOnCallPolicies :: Request ListPolicies s [Policy] +listOnCallPolicies = listPolicies & path .~ policies % "on_call" + +data CreatePolicy = CreatePolicy + { _cpName' :: Text + , _cpRepeatEnabled' :: Bool' + , _cpNumLoops' :: Maybe Int + , _cpEscalationRules' :: [Rule] -- ^ Should be List1 + } deriving (Eq, Show) + +jsonRequest ''CreatePolicy + +-- | The name of the escalation policy. +cpName :: Lens' (Request CreatePolicy s b) Text +cpName = upd.cpName' + +-- | Whether or not to allow this policy to repeat its escalation +-- rules after the last rule is finished. +-- +-- /Default:/ false. +cpRepeatEnabled :: Lens' (Request CreatePolicy s b) Bool +cpRepeatEnabled = upd.cpRepeatEnabled'._B + +-- | The number of times to loop over the set of rules in this escalation policy. +cpNumLoops :: Lens' (Request CreatePolicy s b) (Maybe Int) +cpNumLoops = upd.cpNumLoops' + +-- | The escalation rules for this policy. +cpEscalationRules :: Lens' (Request CreatePolicy s b) [Rule] +cpEscalationRules = upd.cpEscalationRules' + +-- | Creates an existing escalation policy and rules. +-- +-- @POST \/escalation_policies@ +-- +-- /See:/ +createPolicy :: EscalationPolicyId + -> Text -- ^ 'creName' + -> [Rule] -- ^ 'creEscalationRules' + -> Request CreatePolicy s Policy +createPolicy i n rs = + mk CreatePolicy + { _cpName' = n + , _cpRepeatEnabled' = F + , _cpNumLoops' = Nothing + , _cpEscalationRules' = rs + } & meth .~ PUT + & path .~ policies % i + & unwrap .~ key "escalation_policy" + +-- | Get information about an existing escalation policy and its rules. +-- +-- @GET \/escalation_policies\/\:id@ +-- +-- /See:/ +getPolicy :: EscalationPolicyId -> Request Empty s Policy +getPolicy i = empty & path .~ policies % i & unwrap .~ key "escalation_policy" + +data UpdatePolicy = UpdatePolicy + { _upName' :: Maybe Text + , _upRepeatEnabled' :: Maybe Bool' + , _upNumLoops' :: Maybe Int + , _upEscalationRules' :: [Rule] + } deriving (Eq, Show) + +jsonRequest ''UpdatePolicy + +-- | The name of the escalation policy. +upName :: Lens' (Request UpdatePolicy s b) (Maybe Text) +upName = upd.upName' + +-- | Whether or not to allow this policy to repeat its escalation +-- rules after the last rule is finished. +upRepeatEnabled :: Lens' (Request UpdatePolicy s b) (Maybe Bool) +upRepeatEnabled = upd.upRepeatEnabled'.mapping _B + +-- | The number of times to loop over the set of rules in this escalation policy. +upNumLoops :: Lens' (Request UpdatePolicy s b) (Maybe Int) +upNumLoops = upd.upNumLoops' + +-- | The escalation rules for this policy. +upEscalationRules :: Lens' (Request UpdatePolicy s b) [Rule] +upEscalationRules = upd.upEscalationRules' + +-- | Updates an existing escalation policy and rules. +-- +-- @PUT \/escalation_policies\/\:id@ +-- +-- /See:/ +updatePolicy :: EscalationPolicyId -> Request UpdatePolicy s Policy +updatePolicy i = + mk UpdatePolicy + { _upName' = Nothing + , _upRepeatEnabled' = Nothing + , _upNumLoops' = Nothing + , _upEscalationRules' = [] + } & meth .~ PUT + & path .~ policies % i + & unwrap .~ key "escalation_policy" + +-- | Deletes an existing escalation policy and rules. The escalation policy +-- must not be in use by any services. +-- +-- @DELETE \/escalation_policies\/\:id@ +-- +-- /See:/ +deletePolicy :: EscalationPolicyId -> Request Empty s Empty +deletePolicy i = empty & meth .~ DELETE & path .~ policies % i diff --git a/src/Network/PagerDuty/REST/EscalationPolicies/EscalationRules.hs b/src/Network/PagerDuty/REST/EscalationPolicies/EscalationRules.hs new file mode 100644 --- /dev/null +++ b/src/Network/PagerDuty/REST/EscalationPolicies/EscalationRules.hs @@ -0,0 +1,277 @@ +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +-- Module : Network.PagerDuty.REST.EscalationPolicies.EscalationRules +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +-- | This API lets you access and manipulate escalation rules of an existing +-- escalation policy. +-- +-- /See:/ +module Network.PagerDuty.REST.EscalationPolicies.EscalationRules + ( + -- * List Rules + listRules + + -- * Create Rule + , CreateRule + , createRule + , crEscalationDelayInMinutes + , crTargets + + -- * Get Rule + , getRule + + -- * Update Rules + , UpdateRules + , updateRules + , urEscalationRules + + -- * Update Rule + , UpdateRule + , updateRule + , urEscalationDelayInMinutes + , urTargets + + -- * Delete Rule + , deleteRule + + -- * Types + , HasUserInfo (..) + + , Target (..) + , _TSchedule + , _TUser + + , ScheduleTarget + , stId + , stName + + , Rule + , rId + , rEscalationDelayInMinutes + , rTargets + ) where + +import Control.Applicative ((<$>)) +import Control.Lens hiding ((.=)) +import Data.Aeson +import qualified Data.HashMap.Strict as Map +import Data.Text (Text) +import Network.HTTP.Types +import Network.PagerDuty.REST.Users +import Network.PagerDuty.Internal.TH +import Network.PagerDuty.Internal.Types + +default (Path) + +-- FIXME: The lenses here need to operate over (Request x s b) using upd + +rules :: EscalationPolicyId -> Path +rules p = "escalation_policies" % p % "escalation_rules" + +data TargetType + = TargetSchedule + | TargetUser + +deriveJSONWith (dropped 6 underscored) ''TargetType + +data TargetId + = ScheduleId ScheduleId + | UserId UserId + deriving (Eq, Show) + +instance FromJSON TargetId where + parseJSON = withObject "target" $ \o -> do + t <- o .: "type" + case t of + TargetSchedule -> ScheduleId <$> o .: "id" + TargetUser -> UserId <$> o .: "id" + +instance ToJSON TargetId where + toJSON (ScheduleId s) = object ["type" .= TargetSchedule, "id" .= s] + toJSON (UserId u) = object ["type" .= TargetUser, "id" .= u] + +data ScheduleTarget = ScheduleTarget + { _stId :: ScheduleId + , _stName :: Text + } deriving (Eq, Show) + +deriveJSON ''ScheduleTarget + +-- | The id of the target. +makeLens "_stId" ''ScheduleTarget + +-- | The name of the target. +makeLens "_stName" ''ScheduleTarget + +data Target + = TSchedule ScheduleTarget + | TUser UserInfo + deriving (Eq, Show) + +makePrisms ''Target + +instance FromJSON Target where + parseJSON = withObject "target" $ \o -> do + t <- o .: "type" + case t of + TargetSchedule -> TSchedule <$> parseJSON (Object o) + TargetUser -> TUser <$> parseJSON (Object o) + +instance ToJSON Target where + toJSON t = Object (Map.insert "type" (String k) o) + where + (k, Object o) = case t of + TSchedule s -> ("schedule", toJSON s) + TUser u -> ("user", toJSON u) + +data Rule = Rule + { _rId :: EscalationRuleId + , _rEscalationDelayInMinutes :: !Int + , _rTargets :: [Target] + } deriving (Eq, Show) + +deriveJSON ''Rule + +-- | The ID of the escalation rule. +makeLens "_rId" ''Rule + +-- | The amount of time before an incident escalates away from this rule. +makeLens "_rEscalationDelayInMinutes" ''Rule + +-- | A list of targets which an incident will be assigned to upon reaching this rule. +makeLens "_rTargets" ''Rule + +-- | List all the escalation rules for an existing escalation policy. +-- +-- @GET \/escalation_policies\/\:escalation_policy_id\/escalation_rules@ +-- +-- /See:/ +listRules :: EscalationPolicyId -> Request Empty s [Rule] +listRules p = empty & path .~ rules p + +-- | Show the escalation rule for an existing escalation policy. +-- +-- @GET \/escalation_policies\/:escalation_policy_id\/escalation_rules\/\:id@ +-- +-- /See:/ +getRule :: EscalationPolicyId -> EscalationRuleId -> Request Empty s Rule +getRule p r = empty & path .~ rules p % r + +data CreateRule = CreateRule + { _crEscalationDelayInMinutes :: !Int + , _crTargets :: [TargetId] -- ^ list1? + } deriving (Eq, Show) + +deriveJSON ''CreateRule + +instance QueryLike CreateRule where + toQuery = const [] + +-- | The escalation timeout in minutes. Must be at least 5 if the rule has +-- multiple targets, and at least 1 if not. If an incident is not acknowledged +-- within this timeout then it will escalate onto the next escalation rule. +makeLens "_crEscalationDelayInMinutes" ''CreateRule + +-- | The list of the targets an incident should be assigned to upon reaching +-- this rule. +makeLens "_crTargets" ''CreateRule + +-- | Creates a new escalation rule for an escalation policy and appends it to +-- the end of the existing escalation rules. +-- +-- @POST \/escalation_policies\/\:escalation_policy_id\/escalation_rules@ +-- +-- /See:/ +createRule :: EscalationPolicyId + -> Int -- ^ 'crEscalationDelayInMinutes' + -> [TargetId] -- ^ 'crTargets' + -> Request CreateRule s Rule +createRule p n ts = + mk CreateRule + { _crEscalationDelayInMinutes = n + , _crTargets = ts + } & meth .~ POST + & path .~ rules p + +newtype UpdateRules = UpdateRules + { _urEscalationRules :: [TargetId] -- ^ list1 + } deriving (Eq, Show) + +deriveJSON ''UpdateRules + +instance QueryLike UpdateRules where + toQuery = const [] + +-- | An ordered array of escalation rules. +makeLens "_urEscalationRules" ''UpdateRules + +-- | Updates the entire collection of escalation rules for an existing escalation +-- policy. The ordering is determined by the positions of each rule in the +-- list. To create a new rule, add it to the list without an id. To remove a +-- rule, do not include it in the list. +-- +-- @PUT \/escalation_policies\/\:escalation_policy_id\/escalation_rules@ +-- +-- /See:/ +updateRules :: EscalationPolicyId + -> [TargetId] -- ^ 'urEscalationRules' + -> Request UpdateRules s [Rule] +updateRules p rs = + mk UpdateRules + { _urEscalationRules = rs + } & meth .~ PUT + & path .~ rules p + +data UpdateRule = UpdateRule + { _urEscalationDelayInMinutes :: Maybe Int + , _urTargets :: [TargetId] + } deriving (Eq, Show) + +deriveJSON ''UpdateRule + +instance QueryLike UpdateRule where + toQuery = const [] + +-- | The escalation timeout in minutes. Must be at least 5 if the rule has +-- multiple targets, and at least 1 if not. If an incident is not acknowledged +-- within this timeout then it will escalate onto the next escalation rule. +makeLens "_urEscalationDelayInMinutes" ''UpdateRule + +-- | The list of the targets an incident should be assigned to upon reaching +-- this rule. +makeLens "_urTargets" ''UpdateRule + +-- | Updates an escalation rule. +-- +-- @PUT \/escalation_policies\/\:escalation_policy_id\/escalation_rules\/\:id@ +-- +-- /See:/ +updateRule :: EscalationPolicyId -> EscalationRuleId -> Request UpdateRule s Rule +updateRule p r = + mk UpdateRule + { _urEscalationDelayInMinutes = Nothing + , _urTargets = [] + } & meth .~ PUT + & path .~ rules p % r + +-- | Deletes an existing escalation rule that belongs to an escalation +-- policy. There must be a matching rule. +-- +-- @DELETE \/escalation_policies\/\:escalation_policy_id\/escalation_rules\/\:id@ +-- +-- /See:/ +deleteRule :: EscalationPolicyId -> EscalationRuleId -> Request Empty s Empty +deleteRule p r = empty & meth .~ DELETE & path .~ rules p % r diff --git a/src/Network/PagerDuty/REST/Incidents.hs b/src/Network/PagerDuty/REST/Incidents.hs new file mode 100644 --- /dev/null +++ b/src/Network/PagerDuty/REST/Incidents.hs @@ -0,0 +1,650 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +-- Module : Network.PagerDuty.REST.Incidents +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +-- | PagerDuty receives updates (called events) from monitoring systems through +-- services (like Nagios, email or generic API calls). Upon receiving an event, +-- active services will create a new incident and begin escalating it as +-- defined by the service's escalation policy. Events can be de-duplicated into +-- existing incidents based on service de-duplication rules to prevent you from +-- being overwhelmed by event storms. +-- +-- An incident can be open, acknowledged or resolved. Whenever an incident is +-- created, it is assigned to a user (according to the escalation process, as +-- described by escalation rules and schedules). The assigned user has a chance +-- to either acknowledge that he is working on it, or to resolve it. +-- +-- Resolving an incident closes it, whereas acknowledging it halts the +-- escalation process. If the incident is not resolved by the service's +-- incident ack timeout it continues up the escalation chain. +-- +-- When an incident is triggered or when it is escalated it creates alerts +-- (also known as notifications). Alerts are messages containing the details of +-- the incident, and can be sent through SMS, email and phone calls. +-- +-- Incidents and Incident Counts from the last 30 days are returned by +-- default. To change this default date range, see the documentation for the +-- since, until or dateRange parameters. +-- +-- Note: that to create an incident you need to trigger it through the +-- "Network.PagerDuty.Integration" API. +-- +-- /See:/ +module Network.PagerDuty.REST.Incidents + ( + -- * List Incidents + ListIncidents + , listIncidents + , lsSince + , lsUntil + , lsDateRange + , lsStatus + , lsIncidentKey + , lsService + , lsAssignedToUser + , lsTimeZone + , lsSortBy + + -- * Count Incidents + , CountIncidents + , countIncidents + , cSince + , cUntil + , cDateRange + , cStatus + , cIncidentKey + , cService + , cAssignedToUser + + -- * Get Incident + , getIncident + + -- * Update Incidents + , UpdateIncidents + , updateIncidents + , updateIncidentsBasic + , uiIncidents + + -- * Resolve Incident + , resolveIncident + , resolveIncidentBasic + + -- * Acknowledge Incident + , acknowledgeIncident + , acknowledgeIncidentBasic + + -- * Reassign Incident + , ReassignIncident + , reassignIncident + , riEscalationPolicy + , riEscalationLevel + , riAssignedToUser + + -- * Types + , Sort (..) + , _Desc + , _Asc + + , Field (..) + + , IncidentStatus (..) + , UpdateStatus (..) + + , UpdateIncident + , iiId + , iiStatus + , iiEscalationLevel + , iiEscalationPolicy + , iiAssignedToUser + + , UpdatedIncidents + , uiId + , uiStatus + , uiIncidentNumber + , uiUrl + , uiError + + , Assignee + , aAt + , aObject + + , HasIncident (..) + , Incident + ) where + +import Control.Applicative hiding (empty) +import Control.Lens +import Data.Aeson +import Data.ByteString.Conversion (ToByteString(..), toByteString') +import Data.Default.Class +import Data.Maybe +import Data.Monoid hiding (All) +import Data.Text (Text) +import qualified Data.Text.Encoding as Text +import Data.Time +import Network.HTTP.Types +import Network.PagerDuty.Internal.Query +import Network.PagerDuty.Internal.TH +import Network.PagerDuty.Internal.Types + +default (Path) + +incidents :: Path +incidents = "incidents" + +data Sort a + = Desc a + | Asc a + deriving (Eq, Show) + +makePrisms ''Sort + +data Field + = IncidentNumber + -- ^ The number of your incident. + | CreatedOn + -- ^ The date/time the incident was triggered. + | ResolvedOn + -- ^ The date/time the incident was resolved. + deriving (Eq, Show) + +instance QueryValues (Sort Field) where + queryValues s = case s of + Desc f -> ["desc:" <> field f] + Asc f -> ["asc:" <> field f] + where + field IncidentNumber = "incidentNumber" + field CreatedOn = "createdOn" + field ResolvedOn = "resolvedOn" + +data Range = All + deriving (Eq, Show) + +instance QueryValues Range where + queryValues All = ["all"] + +data IncidentStatus + = ITriggered + | IAcknowledged + | IResolved + | IOther Text + deriving (Eq, Show) + +instance ToByteString IncidentStatus where + builder = \case + ITriggered -> "triggered" + IAcknowledged -> "acknowledged" + IResolved -> "resolved" + IOther t -> builder t + +instance FromJSON IncidentStatus where + parseJSON = withText "status" $ pure . \case + "triggered" -> ITriggered + "acknowledged" -> IAcknowledged + "resolved" -> IResolved + t -> IOther t + +instance ToJSON IncidentStatus where + toJSON = String . Text.decodeUtf8 . toByteString' + +data Assignee = Assignee + { _aAt :: Date + , _aObject :: Object + } deriving (Eq, Show) + +deriveRecord ''Assignee + +data Incident = Incident + { _iIncidentNumber' :: !Int + , _iStatus' :: !IncidentStatus + , _iCreatedOn' :: Date + , _iHtmlUrl' :: Text + , _iIncidentKey' :: Maybe IncidentKey + , _iService' :: Object + , _iEscalationPolicy' :: Maybe Object + , _iAssignedTo' :: [Assignee] + , _iAcknowledgers' :: [Assignee] + , _iLastStatusChangeBy' :: Maybe Assignee + , _iLastStatusChangeOn' :: Maybe Date + , _iTriggerSummaryData' :: Object + , _iTriggerDetailsHtmlUrl' :: Text + } deriving (Eq, Show) + +deriveRecord ''Incident + +class HasIncident a where + incident :: Lens' a Incident + + -- | The number of the incident. This is unique across your account. + iIncidentNumber :: Lens' a Int + + -- | The current status of the incident. Valid statuses are: + iStatus :: Lens' a IncidentStatus + + -- | The date/time the incident was triggered. + iCreatedOn :: Lens' a UTCTime + + -- | The PagerDuty website URL where the incident can be viewed and further + -- actions taken. This is not the resource URL. + iHtmlUrl :: Lens' a Text + + -- | The incident's de-duplication key. See the PagerDuty Integration API + -- docs for further details. + iIncidentKey :: Lens' a (Maybe IncidentKey) + + -- | The PagerDuty service that the incident belongs to. The service will + -- contain fields of its own. + iService :: Lens' a Object + + -- | The escalation policy that the incident belongs to. The policy will + -- contain fields of its own. + iEscalationPolicy :: Lens' a (Maybe Object) + + -- | The list of assignments of the incident. An assignment is an object + -- containing the assigned user as well as the date/time the incident was + -- assigned to that user. The user will contain fields of its own. + -- This list is empty if the status of the incident is resolved. + iAssignedTo :: Lens' a [Assignee] + + -- | The list of acknowledgements of the incident. An acknowledgement is an + -- object containing the acknowleding object (either a user or the + -- integration API) as well as the date/time the incident was acknowledged. + -- This field is only present if the status of the incident is acknowledged. + -- This field is sorted in ascending order by acknowledgement time. + iAcknowledgers :: Lens' a [Assignee] + + -- | 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. + iLastStatusChangeBy :: Lens' a (Maybe Assignee) + + -- | The date/time the incident's status last changed. + iLastStatusChangeOn :: Lens' a (Maybe UTCTime) + + -- | 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 + -- o nthe full presence of this data for every incident. + iTriggerSummaryData :: Lens' a Object + + -- | 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.) + iTriggerDetailsHtmlUrl :: Lens' a Text + + iIncidentNumber = incident.iIncidentNumber' + iStatus = incident.iStatus' + iCreatedOn = incident.iCreatedOn'._D + iHtmlUrl = incident.iHtmlUrl' + iIncidentKey = incident.iIncidentKey' + iService = incident.iService' + iEscalationPolicy = incident.iEscalationPolicy' + iAssignedTo = incident.iAssignedTo' + iAcknowledgers = incident.iAcknowledgers' + iLastStatusChangeBy = incident.iLastStatusChangeBy' + iLastStatusChangeOn = incident.iLastStatusChangeOn'.mapping _D + iTriggerSummaryData = incident.iTriggerSummaryData' + iTriggerDetailsHtmlUrl = incident.iTriggerDetailsHtmlUrl' + +instance HasIncident Incident where + incident = id + +data ListIncidents = ListIncidents + { _lsSince' :: Maybe Date + , _lsUntil' :: Maybe Date + , _lsDateRange' :: Maybe Range + , _lsStatus' :: Maybe (CSV IncidentStatus) + , _lsIncidentKey' :: Maybe IncidentKey + , _lsService' :: Maybe (CSV ServiceId) + , _lsAssignedToUser' :: Maybe (CSV UserId) + , _lsTimeZone' :: !TZ + , _lsSortBy' :: Maybe (Sort Field) + } deriving (Eq, Show) + +queryRequest ''ListIncidents + +instance Paginate ListIncidents + +-- | The start of the date range over which you want to search. +lsSince :: Lens' (Request ListIncidents s b) (Maybe UTCTime) +lsSince = upd.lsSince'.mapping _D + +-- | The end of the date range over which you want to search. +-- +-- /Note: If you leave off either since or until, a 30 day default range is +-- applied to your open ended range. Not including the since parameter will set +-- the date range to until - 30 days. Likewise, if you leave off until, +-- it is set to since + 30 days. +-- +-- Defaults to the last 30 days if you leave off both. The size of the date +-- range must be less than 180 days. +lsUntil :: Lens' (Request ListIncidents s b) (Maybe UTCTime) +lsUntil = upd.lsUntil'.mapping _D + +-- | When set, the since and until parameters and defaults are +-- ignored. Use this to get all incidents since the account was created. +lsDateRange :: Lens' (Request ListIncidents s b) Bool +lsDateRange = upd.lens get_ (flip set_) + where + get_ = (Just All ==) . view lsDateRange' + set_ x = lsDateRange' .~ listToMaybe [All | x] + +-- | Returns only the incidents currently in the passed status(es). +lsStatus :: Lens' (Request ListIncidents s b) (Maybe [IncidentStatus]) +lsStatus = upd.lsStatus'.mapping _CSV + +-- | Returns only the incidents with the passed de-duplication key. +-- +-- /See:/ "Network.PagerDuty.Integration" +lsIncidentKey :: Lens' (Request ListIncidents s b) (Maybe IncidentKey) +lsIncidentKey = upd.lsIncidentKey' + +-- | Returns only the incidents associated with the passed service(s). This +-- expects one or more service IDs. +lsService :: Lens' (Request ListIncidents s b) (Maybe [ServiceId]) +lsService = upd.lsService'.mapping _CSV + +-- | Returns only the incidents currently assigned to the passed user(s). This +-- expects one or more user IDs. +-- +-- /Note:/ When using the assignedToUser filter, you will only receive +-- incidents with statuses of triggered or acknowledged. This is because resolved +-- incidents are not assigned to any user. +lsAssignedToUser :: Lens' (Request ListIncidents s b) (Maybe [UserId]) +lsAssignedToUser = upd.lsAssignedToUser'.mapping _CSV + +-- | Time zone in which dates in the result will be rendered. +-- +-- /Default:/ 'UTC'. +lsTimeZone :: Lens' (Request ListIncidents s b) TimeZone +lsTimeZone = upd.lsTimeZone'._TZ + +-- | Used to specify both the field you wish to sort the results on, as well as +-- the direction (ascending/descending) of the results. +lsSortBy :: Lens' (Request ListIncidents s b) (Maybe (Sort Field)) +lsSortBy = upd.lsSortBy' + +-- | The PagerDuty incidents query API can be used to query current and +-- historical PagerDuty incidents over a date range, letting you build custom +-- dashboards or incident reports. The API allows for searching for incidents +-- with multiple filters or query parameters, various sorts, and also supports +-- the pagination of results. +-- +-- @GET \/incidents@ +-- +-- /See:/ +listIncidents :: Request ListIncidents s [Incident] +listIncidents = + mk ListIncidents + { _lsSince' = Nothing + , _lsUntil' = Nothing + , _lsDateRange' = Nothing + , _lsStatus' = Nothing + , _lsIncidentKey' = Nothing + , _lsService' = Nothing + , _lsAssignedToUser' = Nothing + , _lsTimeZone' = def + , _lsSortBy' = Nothing + } & path .~ incidents + +-- | Get detailed information about an incident. Accepts either an incident id, +-- or an incident number. +-- +-- @GET \/incidents\/\:id@ +-- +-- /See:/ +getIncident :: IncidentId -> Request Empty s Incident +getIncident i = empty & path .~ incidents % i + +data CountIncidents = CountIncidents + { _cSince' :: Maybe Date + , _cUntil' :: Maybe Date + , _cDateRange' :: Maybe Range + , _cStatus' :: Maybe (CSV IncidentStatus) + , _cIncidentKey' :: Maybe IncidentKey + , _cService' :: Maybe (CSV ServiceId) + , _cAssignedToUser' :: Maybe (CSV UserId) + } deriving (Eq, Show) + +queryRequest ''CountIncidents + +-- | The start of the date range over which you want to search. +cSince :: Lens' (Request CountIncidents s b) (Maybe UTCTime) +cSince = upd.cSince'.mapping _D + +-- | The end of the date range over which you want to search. +-- +-- /Note: If you leave off either since or until, a 30 day default range is +-- applied to your open ended range. Not including the since parameter will set +-- the date range to until - 30 days. Likewise, if you leave off until, +-- it is set to since + 30 days. +-- +-- Defaults to the last 30 days if you leave off both. The size of the date +-- range must be less than 180 days. +cUntil :: Lens' (Request CountIncidents s b) (Maybe UTCTime) +cUntil = upd.cUntil'.mapping _D + +-- | When set, the since and until parameters and defaults are +-- ignored. Use this to get all counts since the account was created. +cDateRange :: Lens' (Request CountIncidents s b) Bool +cDateRange = upd.lens get_ (flip set_) + where + get_ = (Just All ==) . view cDateRange' + set_ x = cDateRange' .~ listToMaybe [All | x] + +-- | Only counts the incidents currently in the passed status(es). +cStatus :: Lens' (Request CountIncidents s b) (Maybe [IncidentStatus]) +cStatus = upd.cStatus'.mapping _CSV + +-- | Returns only the incidents with the passed de-duplication key. +-- +-- /See:/ "Network.PagerDuty.Integration" +cIncidentKey :: Lens' (Request CountIncidents s b) (Maybe IncidentKey) +cIncidentKey = upd.cIncidentKey' + +-- | Only counts the incidents associated with the passed service(s). +-- This is expecting one or more service IDs. +cService :: Lens' (Request CountIncidents s b) (Maybe [ServiceId]) -- list1 +cService = upd.cService'.mapping _CSV + +-- | Only counts the incidents currently assigned to the passed user(s). +-- This is expecting one or more user IDs. +-- +-- /Note:/ When using the assigned_to_user filter, you will only count +-- incidents with statuses of triggered or acknowledged. This is because resolved +-- incidents are not assigned to any user. +cAssignedToUser :: Lens' (Request CountIncidents s b) (Maybe [UserId]) -- list1 +cAssignedToUser = upd.cAssignedToUser'.mapping _CSV + +newtype Count = Count Int + deriving (Eq, Ord, Show, Bounded, Enum, Num, Integral, Real) + +instance FromJSON Count where + parseJSON = withObject "count" $ \o -> Count <$> o .: "total" + +-- | Use this query if you are simply looking for the count of incidents that +-- match a given query. This should be used if you don't need access to the +-- actual incident details. +-- +-- @GET \/incidents\/count@ +-- +-- /See:/ +countIncidents :: Request CountIncidents s Count +countIncidents = + mk CountIncidents + { _cSince' = Nothing + , _cUntil' = Nothing + , _cDateRange' = Nothing + , _cStatus' = Nothing + , _cIncidentKey' = Nothing + , _cService' = Nothing + , _cAssignedToUser' = Nothing + } & path .~ incidents % "count" + + +data UpdateStatus + = UAcknowledged + | UResolved + deriving (Eq, Show) + +deriveNullary ''UpdateStatus + +data UpdateIncident = UpdateIncident + { _iiId :: IncidentId + , _iiStatus :: Maybe UpdateStatus + , _iiEscalationLevel :: Maybe Int + , _iiEscalationPolicy :: Maybe EscalationPolicyId + , _iiAssignedToUser :: Maybe (CSV UserId) + } deriving (Eq, Show) + +deriveJSON ''UpdateIncident + +-- | The id of the incident to update. +makeLens "_iiId" ''UpdateIncident + +-- | The new status of the incident. +makeLens "_iiStatus" ''UpdateIncident + +-- | Escalate incident to this level in the escalation policy. +makeLens "_iiEscalationLevel" ''UpdateIncident + +-- | Delegate this incident to the specified escalation policy id. +-- This restarts the incident's escalation following the new policy. +makeLens "_iiEscalationPolicy" ''UpdateIncident + +-- | List of user IDs to assign this incident to. +makeLens "_iiAssignedToUser" ''UpdateIncident + +data UpdatedIncidents = UpdatedIncidents + { _uiId :: IncidentId + , _uiStatus :: IncidentStatus + , _uiIncidentNumber :: !Int + , _uiUrl :: Text + , _uiError :: Maybe Object + } deriving (Eq, Show) + +deriveRecord ''UpdatedIncidents + +data UpdateIncidents = UpdateIncidents + { _uiIncidents' :: [UpdateIncident] + } deriving (Eq, Show) + +jsonRequest ''UpdateIncidents + +uiIncidents :: Lens' (Request UpdateIncidents s b) [UpdateIncident] +uiIncidents = upd.uiIncidents' + +-- | Acknowledge, resolve, escalate or reassign one or more incidents. +-- +-- @PUT \/incidents@ +-- +-- /See:/ +updateIncidents :: RequesterId -> Request UpdateIncidents s [UpdatedIncidents] +updateIncidents r = auth updateIncidentsBasic & query .~ [("requester_id", r)] + +-- | A version of 'updateIncidents' which uses HTTP Basic authentication and +-- doesn't require a 'RequesterId'. +updateIncidentsBasic :: Request UpdateIncidents Basic [UpdatedIncidents] +updateIncidentsBasic = + mk UpdateIncidents + { _uiIncidents' = [] + } & meth .~ PUT + & path .~ incidents + +-- | Resolve an incident. +-- +-- @PUT \/incidents\/\:id\/resolve@ +-- +-- /See:/ +resolveIncident :: IncidentId + -> RequesterId + -> Request Empty s Empty +resolveIncident i r = + auth (resolveIncidentBasic i) & query .~ [("requester_id", r)] + +-- | A version of 'resolveIncident' which uses HTTP Basic authentication and +-- doesn't require a 'RequesterId'. +resolveIncidentBasic :: IncidentId -> Request Empty s Empty +resolveIncidentBasic i = empty & meth .~ PUT & path .~ incidents % i % "resolve" + +-- | Acknowledge an incident. +-- +-- @PUT \/incidents\/\:id\/acknowledge@ +-- +-- /See:/ +acknowledgeIncident :: IncidentId + -> RequesterId + -> Request Empty s Empty +acknowledgeIncident i r = + auth (acknowledgeIncidentBasic i) & query .~ [("requester_id", r)] + +-- | A version of 'acknowledgeIncident' which uses HTTP Basic authentication and +-- doesn't require a 'RequesterId'. +acknowledgeIncidentBasic :: IncidentId -> Request Empty s Empty +acknowledgeIncidentBasic i = + empty & meth .~ PUT & path .~ incidents % i % "acknowledge" + +data ReassignIncident = ReassignIncident + { _riEscalationPolicy' :: Maybe EscalationPolicyId + , _riEscalationLevel' :: Maybe Int + , _riAssignedToUser' :: Maybe (CSV UserId) + } deriving (Eq, Show) + +jsonRequest ''ReassignIncident + +-- | The ID of an escalation policy. Delegate the incident to this escalation +-- policy. +riEscalationPolicy :: Lens' (Request ReassignIncident s b) (Maybe EscalationPolicyId) +riEscalationPolicy = upd.riEscalationPolicy' + +-- | Escalate incident to this level in the escalation policy. +riEscalationLevel :: Lens' (Request ReassignIncident s b) (Maybe Int) +riEscalationLevel = upd.riEscalationLevel' + +-- | Comma separated list of user IDs to assign this incident to. +riAssignedToUser :: Lens' (Request ReassignIncident s b) (Maybe [UserId]) +riAssignedToUser = upd.riAssignedToUser'.mapping _CSV + +-- | Reassign an incident. +-- +-- @PUT \/incidents\/\:id\/reassign@ +-- +-- /See:/ +reassignIncident :: IncidentId + -> RequesterId + -> Request ReassignIncident s Empty +reassignIncident i r = + auth (reassignIncidentBasic i) & query .~ [("requester_id", r)] + +-- | A version of 'reassignIncident' which uses HTTP Basic authentication and +-- doesn't require a 'RequesterId'. +reassignIncidentBasic :: IncidentId -> Request ReassignIncident s Empty +reassignIncidentBasic i = + mk ReassignIncident + { _riEscalationPolicy' = Nothing + , _riEscalationLevel' = Nothing + , _riAssignedToUser' = Nothing + } & meth .~ PUT + & path .~ incidents % i % "reassign" diff --git a/src/Network/PagerDuty/REST/Incidents/Notes.hs b/src/Network/PagerDuty/REST/Incidents/Notes.hs new file mode 100644 --- /dev/null +++ b/src/Network/PagerDuty/REST/Incidents/Notes.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +-- Module : Network.PagerDuty.REST.Incidents.Notes +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +-- | The Incident Notes API allows you to add notes to a specified incident. +-- +-- /See:/ +module Network.PagerDuty.REST.Incidents.Notes + ( + -- * List Notes + listNotes + + -- * Create Note + , CreateNote + , createNote + , createNoteBasic + , cnContent + + -- * Types + , Note + , nId + , nCreatedAt + , nUser + , nContent + ) where + +import Control.Lens hiding ((.=)) +import Data.Aeson +import Data.Text (Text) +import Data.Time +import Network.HTTP.Types +import Network.PagerDuty.REST.Users +import Network.PagerDuty.Internal.TH +import Network.PagerDuty.Internal.Types + +default (Path) + +notes :: IncidentId -> Path +notes i = "incidents" % i % "notes" + +data Note = Note + { _nId :: NoteId + , _nCreatedAt :: Date + , _nUser :: User + , _nContent :: Text + } deriving (Eq, Show) + +deriveJSON ''Note + +makeLens "_nId" ''Note +makeLens "_nUser" ''Note +makeLens "_nContent" ''Note + +nCreatedAt :: Lens' Note UTCTime +nCreatedAt = lens _nCreatedAt (\n x -> n { _nCreatedAt = x }) . _D + +-- | List existing notes for the specified incident. +-- +-- @GET \/incidents\/\:incident_id\/notes@ +-- +-- /See:/ +listNotes :: IncidentId -> Request Empty s [Note] +listNotes i = empty & path .~ notes i + +newtype CreateNote = CreateNote + { _cnContent' :: Maybe Text + } deriving (Eq, Show) + +makeLenses ''CreateNote + +instance ToJSON CreateNote where + toJSON cn = object ["note" .= object ["content" .= _cnContent' cn]] + +instance QueryLike CreateNote where + toQuery = const [] + +-- | The note content. +cnContent :: Lens' (Request CreateNote s b) (Maybe Text) +cnContent = upd.cnContent' + +-- | Create a new note for the specified incident. +-- +-- @POST \/incidents\/\:incident_id\/notes@ +-- +-- /See:/ +createNote :: IncidentId -> RequesterId -> Request CreateNote s Note +createNote i r = auth (createNoteBasic i) & query .~ [("requester_id", r)] + +-- | A version of 'createNote' which uses HTTP Basic authentication and +-- doesn't require a 'RequesterId'. +createNoteBasic :: IncidentId -> Request CreateNote s Note +createNoteBasic i = + mk CreateNote + { _cnContent' = Nothing + } & meth .~ POST + & path .~ notes i diff --git a/src/Network/PagerDuty/REST/LogEntries.hs b/src/Network/PagerDuty/REST/LogEntries.hs new file mode 100644 --- /dev/null +++ b/src/Network/PagerDuty/REST/LogEntries.hs @@ -0,0 +1,514 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +-- Module : Network.PagerDuty.REST.LogEntries +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +-- | PagerDuty keeps a log of all the events that happen to an incident. The +-- following APIs provide fine-grained access to this incident log entry data to +-- give you more insight into how your team or organization is handling your +-- incidents. Log entry data includes details about the event(s) that triggered +-- the incident, who was notified and when, how they were notified, and who +-- acknowledged or resolved it, amongst a few other things. +-- +-- /See:/ +module Network.PagerDuty.REST.LogEntries + ( + -- * List Logs + ListLogs + , listLogs + , listUserLogs + , listIncidentLogs + , llTimeZone + , llSince + , llUntil + , llIsOverview + + -- * Get Log + , GetLog + , getLog + , glTimeZone + + -- * Types + -- ** Channels + , Channel (..) + , _ChanNagios + , _ChanAPI + , _ChanEmail + , _ChanUserEmail + , _ChanWebTrigger + , _ChanSMS + , _ChanWeb + , _ChanNote + , _ChanAuto + , _ChanTimeout + + , NagiosChannel + , ncSummary + , ncHost + , ncService + , ncState + , ncDetails + + , APIChannel + , acSummary + , acServiceKey + , acDescription + , acIncidentKey + , acDetails + + , EmailType (..) + , EmailChannel + , ecSummary + , ecTo + , ecFrom + , ecSubject + , ecBody + , ecBodyContentType + , ecRawUrl + , ecHtmlUrl + + , WebTriggerChannel + , wcSummary + , wcSubject + , wcDetails + + -- ** Entries + , Entry (..) + , _LogEntry + , _NotifyEntry + + , LogEntryType (..) + , LogEntry + , leId + , leType + , leCreatedAt + , leNote + , leAssignedUser + , leChannel + + , NotifyEntry + , neCreatedAt + , neUser + , neNotification + + , NotificationType (..) + , NotificationStatus (..) + + , Notification + , nType + , nStatus + , nAddress + ) where + +import Control.Applicative +import Control.Lens +import Data.Aeson +import Data.Aeson.Lens +import Data.Default.Class +import qualified Data.HashMap.Strict as Map +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Time +import Network.HTTP.Types +import Network.PagerDuty.REST.Users (User) +import Network.PagerDuty.Internal.TH +import Network.PagerDuty.Internal.Types + +logs :: Path +logs = "log_entries" + +includes :: Query +includes = + [ ("include[]", Just "channel") + , ("include[]", Just "incident") + , ("include[]", Just "service") + ] + +data NagiosChannel = NagiosChannel + { _ncSummary :: Text + , _ncHost :: Text + , _ncService :: Maybe Text + , _ncState :: Text + , _ncDetails :: Object + } deriving (Eq, Show) + +deriveJSON ''NagiosChannel + +-- | Same as host. +makeLens "_ncSummary" ''NagiosChannel + +-- | Nagios host. +makeLens "_ncHost" ''NagiosChannel + +-- | Nagios service that created the event, if applicable. +makeLens "_ncService" ''NagiosChannel + +-- | State the caused the event. +makeLens "_ncState" ''NagiosChannel + +-- | Additional details of the incident. +makeLens "_ncDetails" ''NagiosChannel + +data APIChannel = APIChannel + { _acSummary :: Text + , _acServiceKey :: ServiceKey + , _acDescription :: Text + , _acIncidentKey :: IncidentKey + , _acDetails :: Object + } deriving (Eq, Show) + +deriveJSON ''APIChannel + +-- | Same as description. +makeLens "_acSummary" ''APIChannel + +-- | API service key. +makeLens "_acServiceKey" ''APIChannel + +-- | Description of the event. +makeLens "_acDescription" ''APIChannel + +-- | Incident deduping string. +makeLens "_acIncidentKey" ''APIChannel + +-- | Additional details of the incident, if any. +makeLens "_acDetails" ''APIChannel + +data EmailType + = Plain + | HTML + deriving (Eq, Show) + +deriveNullary ''EmailType + +data EmailChannel = EmailChannel + { _ecSummary :: Text + , _ecTo :: Text + , _ecFrom :: Text + , _ecSubject :: Text + , _ecBody :: Text + , _ecBodyContentType :: EmailType + , _ecRawUrl :: Text + , _ecHtmlUrl :: Maybe Text + } deriving (Eq, Show) + +deriveJSON ''EmailChannel + +-- | Same as subject. +makeLens "_ecSummary" ''EmailChannel + +-- | To address of the email. +makeLens "_ecTo" ''EmailChannel + +-- | From address of the email. +makeLens "_ecFrom" ''EmailChannel + +-- | Subject of the email. +makeLens "_ecSubject" ''EmailChannel + +-- | Body of the email. +makeLens "_ecBody" ''EmailChannel + +-- | Content type of the email body. +makeLens "_ecBodyContentType" ''EmailChannel + +-- | URL for raw text of email. +makeLens "_ecRawUrl" ''EmailChannel + +-- | URL for html rendered version of the email. +-- +-- Only present if content_type is 'HTML'. +makeLens "_ecHtmlUrl" ''EmailChannel + +data WebTriggerChannel = WebTriggerChannel + { _wcSummary :: Text + , _wcSubject :: Text + , _wcDetails :: Maybe Text + } deriving (Eq, Show) + +deriveJSON ''WebTriggerChannel + +-- | Same as subject. +makeLens "_wcSummary" ''WebTriggerChannel + +-- | Subject of the web trigger. +makeLens "_wcSubject" ''WebTriggerChannel + +-- | Details about the web trigger. +makeLens "_wcDetails" ''WebTriggerChannel + +-- | Representation of the means by which the action was channeled. +data Channel + = ChanNagios NagiosChannel + | ChanAPI APIChannel + | ChanEmail EmailChannel + | ChanUserEmail User EmailChannel + | ChanWebTrigger User WebTriggerChannel + | ChanSMS User + | ChanWeb User + | ChanNote User + | ChanAuto + | ChanTimeout + deriving (Eq, Show) + +makePrisms ''Channel + +instance FromJSON Channel where + parseJSON = withObject "agent+channel" $ \o -> do + t <- o .: "channel" >>= (.: "type") + let u = Map.member "user" o + case t of + -- service + "email" | not u -> ChanEmail <$> o .: "channel" + "nagios" -> ChanNagios <$> o .: "channel" + "api" -> ChanAPI <$> o .: "channel" + -- user + "email" | u -> ChanUserEmail <$> o .: "user" <*> o .: "channel" + "web_trigger" -> ChanWebTrigger <$> o .: "user" <*> o .: "channel" + "sms" -> ChanSMS <$> o .: "user" + "web" -> ChanWeb <$> o .: "user" + "note" -> ChanNote <$> o .: "user" + -- empty + "auto" -> pure ChanAuto + "timeout" -> pure ChanTimeout + _ -> fail $ + "unrecognised service channel type: " ++ Text.unpack t + +data LogEntryType + = Trigger + -- ^ The incident was triggered. + | Acknowledge + -- ^ The incident was acknowledged. + | Unacknowledge + -- ^ The incident was unacknowledged. + | Resolve + -- ^ The incident was resolved. + | Escalate + -- ^ The incident was escalated. + | Assign + -- ^ The incident was assigned to a user. + | Annotate + -- ^ A note was added to the incident. + | ReachTriggerLimit + -- ^ The incident has reached the log entry trigger limit and + -- will not create any more. + | RepeatEscalationPath + -- ^ The incident has reached the end of its escalation policy + -- and will restart. + | ExhaustEscalationPath + -- ^ The incident has cycled through its escalation policy the + -- max allowed number of times. + | Notify + -- ^ A user was notified. + deriving (Eq, Show) + +deriveNullary ''LogEntryType + +-- | The raw log event. +data LogEntry = LogEntry' + { _leId :: LogEntryId + , _leType :: LogEntryType + , _leCreatedAt :: Date + , _leNote :: Maybe Text + , _leAssignedUser :: Maybe User + , _leChannel :: Channel + } deriving (Eq, Show) + +instance FromJSON LogEntry where + parseJSON = withObject "log_entry" $ \o -> + LogEntry' <$> o .: "id" + <*> o .: "type" + <*> o .: "created_at" + <*> o .:? "note" + <*> o .:? "assigned_user" + <*> parseJSON (Object o) + +-- | Id of the log entry. +makeLens "_leId" ''LogEntry + +-- | Time at which the log entry was created. +makeLens "_leCreatedAt" ''LogEntry + +-- | The type of the log entry. +makeLens "_leType" ''LogEntry + +-- | Optional field containing an action note, if one was included +-- with the action. +makeLens "_leNote" ''LogEntry + +-- | Only for assign, escalate log entries. The user to which the incident is +-- assigned. +makeLens "_leAssignedUser" ''LogEntry + +-- | Representation of the means by which the action was channeled and the +-- possible perfomer of this action. +makeLens "_leChannel" ''LogEntry + +data NotificationType + = SMS + | Email + | Phone + | IosPushNotification + deriving (Eq, Show) + +deriveNullary ''NotificationType + +data NotificationStatus + = Success + | Blocked + | Busy + | Failed + | NoAnswer + | BadAddress + deriving (Eq, Show) + +deriveNullary ''NotificationStatus + +data Notification = Notification + { _nType :: !NotificationType + , _nStatus :: !NotificationStatus + , _nAddress :: Address + } deriving (Eq, Show) + +deriveJSON ''Notification + +-- | Type of notification. +makeLens "_nType" ''Notification + +-- | The current status of the notification. +makeLens "_nStatus" ''Notification + +-- | The address to which the notification was sent. I.e., an email address, +-- phone number, or iPhone name. +makeLens "_nAddress" ''Notification + +-- | Notify log entries correspond to notifications sent to users. They have a +-- distinct format from action log entries. +data NotifyEntry = NotifyEntry' + { _neCreatedAt' :: Date + , _neUser' :: User + , _neNotification' :: Notification + } deriving (Eq, Show) + +deriveRecord ''NotifyEntry + +-- | Time at which the log entry was created +neCreatedAt :: Lens' NotifyEntry UTCTime +neCreatedAt = neCreatedAt'._D + +-- | User who was notified +neUser :: Lens' NotifyEntry User +neUser = neUser' + +-- | Object representing the notification itself +neNotification :: Lens' NotifyEntry Notification +neNotification = neNotification' + +data Entry + = LogEntry LogEntry + -- ^ Log entries come in a wide variety of types. Most types use this format, + -- the exception being the 'NotifyEntry' type. + | NotifyEntry NotifyEntry + -- ^ A user was notified. + deriving (Eq, Show) + +makePrisms ''Entry + +data ListLogs = ListLogs + { _llTimeZone' :: TZ + , _llSince' :: Maybe Date + , _llUntil' :: Maybe Date + , _llIsOverview' :: Bool' + } deriving (Eq, Show) + +instance Paginate ListLogs + +queryRequest ''ListLogs + +-- | Time zone in which dates in the result will be rendered. +-- +-- /Default:/ UTC. +llTimeZone :: Lens' (Request ListLogs s b) TimeZone +llTimeZone = upd.llTimeZone'._TZ + +-- | The start of the date range over which you want to search. +llSince :: Lens' (Request ListLogs s b) (Maybe UTCTime) +llSince = upd.llSince'.mapping _D + +-- | The end of the date range over which you want to search. +llUntil :: Lens' (Request ListLogs s b) (Maybe UTCTime) +llUntil = upd.llUntil'.mapping _D + +-- | If true, will only return log entries of type trigger, acknowlldge, or resolve. +-- +-- /Default:/ false. +llIsOverview :: Lens' (Request ListLogs s b) Bool +llIsOverview = upd.llIsOverview'._B + +-- | List all incident log entries across the entire account. +-- +-- @GET \/log_entries@ +-- +-- /See:/ +listLogs :: Request ListLogs s [LogEntry] +listLogs = + mk ListLogs + { _llTimeZone' = def + , _llSince' = Nothing + , _llUntil' = Nothing + , _llIsOverview' = F + } & path .~ logs + & query .~ includes + & unwrap .~ key "log_entries" + +-- | List all incident log entries that describe interactions with a specific user. +-- +-- @GET \/users\/\:user_id\/log_entries@ +-- +-- /See:/ +listUserLogs :: UserId -> Request ListLogs s [LogEntry] +listUserLogs u = listLogs & path .~ "users" % u % logs + +-- | List all incident log entries for a specific incident. +-- +-- @GET \/incidents\/\:incident_id\/log_entries@ +-- +-- /See:/ +listIncidentLogs :: IncidentKey -> Request ListLogs s [LogEntry] +listIncidentLogs i = listLogs & path .~ "incidents" % i % logs + +newtype GetLog = GetLog + { _glTimeZone' :: TZ + } deriving (Eq, Show) + +queryRequest ''GetLog + +-- | Time zone in which dates in the result will be rendered. +-- +-- /Default:/ UTC. +glTimeZone :: Lens' (Request GetLog s b) TimeZone +glTimeZone = upd.glTimeZone'._TZ + +-- | Get details for a specific incident log entry. This method provides additional +-- information you can use to get at raw event data. +-- +-- @GET \/log_entries\/\:id@ +-- +-- /See:/ +getLog :: LogEntryId -> Request GetLog s LogEntry +getLog l = + mk GetLog + { _glTimeZone' = def + } & path .~ logs % l + & query .~ includes diff --git a/src/Network/PagerDuty/REST/MaintenanceWindows.hs b/src/Network/PagerDuty/REST/MaintenanceWindows.hs new file mode 100644 --- /dev/null +++ b/src/Network/PagerDuty/REST/MaintenanceWindows.hs @@ -0,0 +1,289 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +-- Module : Network.PagerDuty.REST.MaintenanceWindows +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +-- | Maintenance windows allow you to schedule service maintenance periods, +-- during which no incidents will be created. +-- +-- /See:/ +module Network.PagerDuty.REST.MaintenanceWindows + ( + -- * List Windows + ListWindows + , listWindows + , lwQuery + , lwServiceIds + , lwFilter + + , ListWindowsResponse + , lwMaintenanceWindows + , lwCounts + + -- * Create Window + , CreateWindow + , createWindow + , createWindowBasic + , cwStartTime + , cwEndTime + , cwDescription + , cwServiceIds + + -- * Get Window + , getWindow + + -- * Update Window + , UpdateWindow + , updateWindow + , uwStartTime + , uwEndTime + , uwDescription + , uwServiceIds + + -- * Delete Window + , deleteWindow + + -- * Types + , ServiceInfo + , siId + , siName + , siUrl + + , Counts + , cOngoing + , cFuture + , cPast + , cAll + + , MaintenanceWindow + , mwSequenceNumber + , mwStartTime + , mwEndTime + , mwDescription + , mwCreatedBy + , mwServices + ) where + +import Control.Lens +import Data.Monoid +import Data.Text (Text) +import Data.Time +import Network.HTTP.Types +import Network.PagerDuty.REST.Users (User) +import Network.PagerDuty.Internal.TH +import Network.PagerDuty.Internal.Types + +windows :: Path +windows = "maintenance_windows" + +data ServiceInfo = ServiceInfo + { _siId :: ServiceId + , _siName :: Text + , _siUrl :: Text + } deriving (Eq, Show) + +deriveRecord ''ServiceInfo + +data MaintenanceWindow = MaintenanceWindow + { _mwSequenceNumber :: !Int + , _mwStartTime :: Date + , _mwEndTime :: Date + , _mwDescription :: Maybe Text + , _mwCreatedBy :: User + , _mwServices :: [ServiceInfo] + } deriving (Eq, Show) + +deriveRecord ''MaintenanceWindow + +data ListWindows = ListWindows + { _lwQuery' :: Maybe Text + , _lwServiceIds' :: List ServiceId + , _lwFilter' :: Maybe Text + } + +queryRequest ''ListWindows + +-- | Filters the results, showing only the maintenance windows whose +-- descriptions contain the query. +lwQuery :: Lens' (Request ListWindows s b) (Maybe Text) +lwQuery = upd.lwQuery' + +-- | An list of service IDs, specifying services whose maintenance +-- windows shall be returned. +lwServiceIds :: Lens' (Request ListWindows s b) [ServiceId] +lwServiceIds = upd.lwServiceIds'._L + +-- | Only return maintenance windows that are of this type. Possible values +-- are past, future, ongoing. If this parameter is omitted, all maintenance +-- windows will be returned. +lwFilter :: Lens' (Request ListWindows s b) (Maybe Text) +lwFilter = upd.lwFilter' + +data Counts = Counts + { _cOngoing :: !Int + , _cFuture :: !Int + , _cPast :: !Int + , _cAll :: !Int + } deriving (Eq, Show) + +deriveRecord ''Counts + +data ListWindowsResponse = ListWindowsResponse + { _lwMaintenanceWindows :: [MaintenanceWindow] + , _lwCounts :: Counts + } deriving (Eq, Show) + +deriveRecord ''ListWindowsResponse + +-- | List existing maintenance windows, optionally filtered by service, +-- or whether they are from the past, present or future. +-- +-- @GET \/maintenance_windows@ +-- +-- /See:/ +listWindows :: Request ListWindows s ListWindowsResponse +listWindows = + mk ListWindows + { _lwQuery' = Nothing + , _lwServiceIds' = mempty + , _lwFilter' = Nothing + } & path .~ windows + +data CreateWindow' = CreateWindow' + { _cwStartTime' :: Date + , _cwEndTime' :: Date + , _cwDescription' :: Maybe Text + , _cwServiceIds' :: [ServiceId] -- ^ List1 + } deriving (Eq, Show) + +deriveRecord ''CreateWindow' + +data CreateWindow = CreateWindow + { _cwRequesterId' :: Maybe RequesterId + , _cwMaintenanceWindow' :: CreateWindow' + } deriving (Eq, Show) + +jsonRequest ''CreateWindow + +-- | This maintenance window's start time. This is when the services will stop +-- creating incidents. If this date is in the past, it will be updated to be the +-- current time. +cwStartTime :: Lens' (Request CreateWindow s b) UTCTime +cwStartTime = upd.cwMaintenanceWindow'.cwStartTime'._D + +-- | This maintenance window's end time. This is when the services will start +-- creating incidents again. This date must be in the future and after the +-- start_time. +cwEndTime :: Lens' (Request CreateWindow s b) UTCTime +cwEndTime = upd.cwMaintenanceWindow'.cwEndTime'._D + +-- | A description for this maintenance window. +cwDescription :: Lens' (Request CreateWindow s b) (Maybe Text) +cwDescription = upd.cwMaintenanceWindow'.cwDescription' + +-- | The ids of the services that are affected by this maintenance window. +cwServiceIds :: Lens' (Request CreateWindow s b) [ServiceId] +cwServiceIds = upd.cwMaintenanceWindow'.cwServiceIds' + +-- | Create a new maintenance window for the specified services. No new +-- incidents will be created for a service that is currently in maintenance. +-- +-- @POST \/maintenance_windows@ +-- +-- /See:/ +createWindow :: RequesterId + -> UTCTime -- ^ 'cwStartTime' + -> UTCTime -- ^ 'cwEndTime' + -> [ServiceId] -- ^ 'cwServiceIds' + -> Request CreateWindow s MaintenanceWindow +createWindow r s e xs = + auth (createWindowBasic s e xs) & upd.cwRequesterId' ?~ r + +-- | A version of 'createWindow' which uses HTTP Basic authentication and +-- doesn't require a 'RequesterId'. +createWindowBasic :: UTCTime -- ^ 'cwStartTime' + -> UTCTime -- ^ 'cwEndTime' + -> [ServiceId] -- ^ 'cwServiceIds' + -> Request CreateWindow Basic MaintenanceWindow +createWindowBasic s e xs = + mk CreateWindow + { _cwRequesterId' = Nothing + , _cwMaintenanceWindow' = CreateWindow' + { _cwStartTime' = D s + , _cwEndTime' = D e + , _cwDescription' = Nothing + , _cwServiceIds' = xs + } + } & meth .~ POST + & path .~ windows + +-- | Get details about an existing maintenance window. +-- +-- @GET \/maintenance_windows\/\:id@ +-- +-- /See:/ +getWindow :: WindowId -> Request Empty s MaintenanceWindow +getWindow w = empty & path .~ windows % w + +data UpdateWindow = UpdateWindow + { _uwStartTime' :: Maybe Date + , _uwEndTime' :: Maybe Date + , _uwDescription' :: Maybe Text + , _uwServiceIds' :: Maybe [ServiceId] + } deriving (Eq, Show) + +jsonRequest ''UpdateWindow + +-- | The maintenance window's start time. Can only be updated on future +-- maintenance windows. If the start_time is set to a date in the past, it will be +-- updated to the current date. +uwStartTime :: Lens' (Request UpdateWindow s b) (Maybe Date) +uwStartTime = upd.uwStartTime' + +-- | The maintenance window's end time. Can only be updated on ongoing and +-- future maintenance windows, and cannot be set to a value before start_time. +uwEndTime :: Lens' (Request UpdateWindow s b) (Maybe Date) +uwEndTime = upd.uwEndTime' + +-- | Description for this maintenance window. Can only be updated on ongoing +-- and future maintenance windows. +uwDescription :: Lens' (Request UpdateWindow s b) (Maybe Text) +uwDescription = upd.uwDescription' + +-- | Services that are affected by this maintenance window. Can only be updated +-- on future maintenance windows. +uwServiceIds :: Lens' (Request UpdateWindow s b) (Maybe [ServiceId]) +uwServiceIds = upd.uwServiceIds' + +-- | Update an existing maintenance window. +-- +-- @PUT \/maintenance_windows\/\:id@ +-- +-- /See:/ +updateWindow :: WindowId -> Request UpdateWindow s MaintenanceWindow +updateWindow w = + mk UpdateWindow + { _uwStartTime' = Nothing + , _uwEndTime' = Nothing + , _uwDescription' = Nothing + , _uwServiceIds' = Nothing + } & meth .~ PUT + & path .~ windows % w + +-- | Cancel or delete an existing maintenance window. +-- +-- @DELETE \/maintenance_windows\/\:id@ +-- +-- /See:/ +deleteWindow :: WindowId -> Request Empty s Empty +deleteWindow w = empty & meth .~ DELETE & path .~ windows % w diff --git a/src/Network/PagerDuty/REST/Reports.hs b/src/Network/PagerDuty/REST/Reports.hs new file mode 100644 --- /dev/null +++ b/src/Network/PagerDuty/REST/Reports.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +-- Module : Network.PagerDuty.REST.Reports +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +-- | Access high level reports about alerts and incidents. +-- Useful for creating graphs. +-- +-- /See:/ +module Network.PagerDuty.REST.Reports + ( + -- * Alerts Per Time + alertsPerTime + + -- * Incidents Per Time + , incidentsPerTime + + -- * Types + , Report + , rSince + , rUntil + , rRollup + + , Rollup (..) + + , AlertReport + , arStart + , arEnd + , arNumberOfAlerts + , arNumberOfPhoneAlerts + , arNumberOfSmsAlerts + , arNumberOfEmailAlerts + + , AlertTotals + , atAlerts + , atTotalNumberOfAlerts + , atTotalNumberOfPhoneAlerts + , atTotalNumberOfSmsAlerts + , atTotalNumberOfEmailAlerts + , atTotalNumberOfBillableAlerts + + , IncidentReport + , irStart + , irEnd + , irNumberOfIncidents + ) where + +import Control.Lens +import Data.Aeson.Lens +import Data.Time +import Network.PagerDuty.Internal.TH +import Network.PagerDuty.Internal.Types + +default (Path) + +reports :: Path +reports = "reports" + +data Rollup + = Daily + | Weekly + | Monthly + deriving (Eq, Show) + +deriveNullary ''Rollup + +data Report = Report + { _rSince' :: Date + , _rUntil' :: Date + , _rRollup' :: !Rollup + } deriving (Eq, Show) + +queryRequest ''Report + +-- | Start of the date range over which you want to search. The time element +-- is optional. +rSince :: Lens' (Request Report s b) UTCTime +rSince = upd.rSince'._D + +-- | The end of the date range over which you want to search. This should be +-- in the same format as since. +rUntil :: Lens' (Request Report s b) UTCTime +rUntil = upd.rUntil'._D + +-- | Specifies the bucket duration for each summation. +-- +-- /Default:/ monthly. +-- +-- Example: A time window of two years (based on since and until) with a +-- rollup of monthly will result in 24 sets of data points being returned +-- (one for each month in the span). +rRollup :: Lens' (Request Report s b) Rollup +rRollup = upd.rRollup' + +data AlertReport = AlertReport + { _arStart :: Date + , _arEnd :: Date + , _arNumberOfAlerts :: !Int + , _arNumberOfPhoneAlerts :: !Int + , _arNumberOfSmsAlerts :: !Int + , _arNumberOfEmailAlerts :: !Int + } deriving (Eq, Show) + +deriveJSON ''AlertReport + +arStart :: Lens' AlertReport UTCTime +arStart = lens _arStart (\r x -> r { _arStart = x }) ._D + +arEnd :: Lens' AlertReport UTCTime +arEnd = lens _arEnd (\r x -> r { _arEnd = x }) ._D + +makeLens "_arNumberOfAlerts" ''AlertReport +makeLens "_arNumberOfPhoneAlerts" ''AlertReport +makeLens "_arNumberOfSmsAlerts" ''AlertReport +makeLens "_arNumberOfEmailAlerts" ''AlertReport + +data AlertTotals = AlertTotals + { _atAlerts :: [AlertReport] + , _atTotalNumberOfAlerts :: !Int + , _atTotalNumberOfPhoneAlerts :: !Int + , _atTotalNumberOfSmsAlerts :: !Int + , _atTotalNumberOfEmailAlerts :: !Int + , _atTotalNumberOfBillableAlerts :: !Int + } deriving (Eq, Show) + +deriveRecord ''AlertTotals + +-- | Get high level statistics about the number of alerts (SMSes, phone calls and +-- emails) sent for the desired time period, summed daily, weekly or monthly. +-- +-- @GET \/reports\/alerts_per_time@ +-- +-- /See:/ +alertsPerTime :: UTCTime -- ^ 'rSince' + -> UTCTime -- ^ 'rUntil' + -> Request Report s AlertTotals +alertsPerTime s u = + mk Report + { _rSince' = D s + , _rUntil' = D u + , _rRollup' = Monthly + } & path .~ reports % "alerts_per_time" + +data IncidentReport = IncidentReport + { _irStart :: Date + , _irEnd :: Date + , _irNumberOfIncidents :: !Int + } deriving (Eq, Show) + +deriveJSON ''IncidentReport + +irStart :: Lens' IncidentReport UTCTime +irStart = lens _irStart (\r x -> r { _irStart = x }) . _D + +irEnd :: Lens' IncidentReport UTCTime +irEnd = lens _irEnd (\r x -> r { _irEnd = x }) . _D + +makeLens "_irNumberOfIncidents" ''IncidentReport + +-- | Get high level statistics about the number of incidents created for the +-- desired time period, summed daily, weekly or monthly. +-- +-- @GET \/reports\/incidents_per_time@ +-- +-- /See:/ +incidentsPerTime :: UTCTime -- ^ 'rSince' + -> UTCTime -- ^ 'rUntil' + -> Request Report s [IncidentReport] +incidentsPerTime s u = + mk Report + { _rSince' = D s + , _rUntil' = D u + , _rRollup' = Monthly + } & path .~ reports % "incidents_per_time" + & unwrap .~ key "incidents" diff --git a/src/Network/PagerDuty/REST/Schedules.hs b/src/Network/PagerDuty/REST/Schedules.hs new file mode 100644 --- /dev/null +++ b/src/Network/PagerDuty/REST/Schedules.hs @@ -0,0 +1,638 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +-- Module : Network.PagerDuty.REST.Schedules +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +-- | On call schedules determine the time periods that users are on-call. Only when +-- a user is on-call he is eligible to receive alerts from incidents. +-- +-- This API allows users to manipulate on-call schedules. +-- +-- /See:/ +module Network.PagerDuty.REST.Schedules + ( + -- * List Schedules + ListSchedules + , listSchedules + , lsQuery + + -- * Get Schedule + , GetSchedule + , getSchedule + , gsSince + , gsUntil + , gsTimeZone + + -- * Get Schedule Users + , GetScheduleUsers + , getScheduleUsers + , gsuSince + , gsuUntil + + -- * Get Schedule Entries + , GetScheduleEntries + , getScheduleEntries + , gseSince + , gseUntil + , gseOverflow + , gseTimeZone + , gseUserId + + -- * Create Schedule + , CreateSchedule + , createSchedule + , csName + , csOverflow + , csTimeZone + , csScheduleLayers + + -- * Update Schedule + , UpdateSchedule + , updateSchedule + , usOverflow + , usTimeZone + , usScheduleLayers + + -- * Preview Schedule + , PreviewSchedule + , previewSchedule + , psSince + , psUntil + , psOverflow + , psName + , psTimeZone + , psScheduleLayers + + -- * Delete Schedule + , deleteSchedule + + -- * Types + , RestrictionType (..) + , Restriction + , rStartTimeOfDay + , rDurationSeconds + + , Rotation + , rMemberOrder + , rUser + + , ScheduleLayer + , slName + , slRenderedScheduleEntries + , slRestrictionType + , slRestrictions + , slPriority + , slStart + , slEnd + , slRenderedCoveragePercentage + , slRotationTurnLengthSeconds + , slRotationVirtualStart + , slUsers + + , HasScheduleInfo (..) + , ScheduleInfo + , Schedule + , sScheduleLayers + , sOverridesSubschedule + , sFinalSchedule + ) where + +import Control.Lens hiding ((.=)) +import Data.Aeson +import Data.Text (Text) +import Data.Time +import Network.HTTP.Types +import Network.PagerDuty.REST.Users (User) +import Network.PagerDuty.Internal.TH +import Network.PagerDuty.Internal.Types + +default (Path) + +schedules :: Path +schedules = "schedules" + +data RestrictionType + = Daily + | Weekly + deriving (Eq, Show) + +deriveNullary ''RestrictionType + +data Restriction = Restriction + { _rStartTimeOfDay :: Date + , _rDurationSeconds :: !Int + } deriving (Eq, Show) + +deriveJSON ''Restriction + +rStartTimeOfDay :: Lens' Restriction UTCTime +rStartTimeOfDay = + lens _rStartTimeOfDay (\r x -> r { _rStartTimeOfDay = x }) . _D + +makeLens "_rDurationSeconds" ''Restriction + +data Rotation = Rotation + { _rMemberOrder :: !Int + , _rUser :: User + } deriving (Eq, Show) + +deriveRecord ''Rotation + +-- | A schedule is composed of multiple schedule layers. +-- +-- A layer is composed of a group of people who will rotate through the same +-- shift. In a basic weekly schedule, you create a single layer where each member +-- is on-call for one week, with a set day and time for transferring on-call duty. +-- +-- When a schedule has multiple layers, the layer can be ordered using the +-- priority field. The layer with the highest priority has precedence over the +-- layers with lower priority. You can use restrictions to control how layers +-- overlap. +-- +-- The override layer is a special layer where all the override entries are +-- stored. +-- +-- The final layer is a special layer that contains the result of all the previous +-- layers put together. This layer cannot be edited. +data ScheduleLayer = ScheduleLayer + { _slName :: Text + , _slRenderedScheduleEntries :: [ScheduleId] -- FIXME: what is this a list of? + , _slRestrictionType :: !RestrictionType + , _slRestrictions :: [Restriction] + , _slPriority :: !Int + , _slStart :: Date + , _slEnd :: Date + , _slRenderedCoveragePercentage :: !Double + , _slRotationTurnLengthSeconds :: !Int + , _slRotationVirtualStart :: Date + , _slUsers :: [Rotation] + } deriving (Eq, Show) + +-- FIXME: most of these fields are maybes + +deriveJSON ''ScheduleLayer + +makeLens "_slName" ''ScheduleLayer + +-- | This is a list of entries to be rendered for the current time range. +makeLens "_slRenderedScheduleEntries" ''ScheduleLayer + +-- | This specifies the type of restrictions present on this layer. +makeLens "_slRestrictionType" ''ScheduleLayer + +-- | A list of time restrictions for this layer. +makeLens "_slRestrictions" ''ScheduleLayer + +-- | The priority of the layer. Layers with higher priority will override +-- layers with a lower priority. +makeLens "_slPriority" ''ScheduleLayer + +-- | The effective start date of the layer +makeLens "_slStart" ''ScheduleLayer + +-- | The effective end date of the layer. If 'Nothing', the layer has no end date. +makeLens "_slEnd" ''ScheduleLayer + +-- | The percentage of the time range covered by this layer. +makeLens "_slRenderedCoveragePercentage" ''ScheduleLayer + +-- | The duration of each on-call shift in seconds. +makeLens "_slRotationTurnLengthSeconds" ''ScheduleLayer + +-- | The effective start time of the layer. This can be before the start +-- time of the schedule. +makeLens "_slRotationVirtualStart" ''ScheduleLayer + +-- | An ordered list of users in this layer. The member_order field controls +-- the order in which the users apear in the rotation. +makeLens "_slUsers" ''ScheduleLayer + +data ScheduleInfo = ScheduleInfo + { _siId' :: ScheduleId + , _siName' :: Text + , _siTimeZone' :: TZ + , _siToday' :: Date + , _siEscalationPolicies' :: [EscalationPolicyId] + } deriving (Eq, Show) + +deriveRecord ''ScheduleInfo + +class HasScheduleInfo a where + scheduleInfo :: Lens' a ScheduleInfo + + -- | The unique identifier of the schedule. + sId :: Lens' a ScheduleId + -- | The name of the schedule. + sName :: Lens' a Text + -- | The time zone of the schedule. + sTimeZone :: Lens' a TimeZone + -- | The current day in the schedule's time zone. + sToday :: Lens' a UTCTime + -- | An list of all the escalation policies that uses this schedule. + sEscalationPolicies :: Lens' a [EscalationPolicyId] + + sId = scheduleInfo.siId' + sName = scheduleInfo.siName' + sTimeZone = scheduleInfo.siTimeZone'._TZ + sToday = scheduleInfo.siToday'._D + sEscalationPolicies = scheduleInfo.siEscalationPolicies' + +instance HasScheduleInfo ScheduleInfo where + scheduleInfo = id + +data Schedule = Schedule + { _sInfo :: ScheduleInfo + , _sScheduleLayers :: [ScheduleLayer] + , _sOverridesSubschedule :: ScheduleLayer + , _sFinalSchedule :: ScheduleLayer + } deriving (Eq, Show) + +deriveJSON ''Schedule + +instance HasScheduleInfo Schedule where + scheduleInfo = lens _sInfo (\s x -> s { _sInfo = x }) + +-- | A list of schedule layers. See the schedule layers parameters for details. +makeLens "_sScheduleLayers" ''Schedule + +-- | The schedule layer object where all the overrides are stored. +makeLens "_sOverridesSubschedule" ''Schedule + +-- | The final schedule layer object. +makeLens "_sFinalSchedule" ''Schedule + +newtype ListSchedules = ListSchedules + { _lsQuery' :: Maybe Text + } deriving (Eq, Show) + +queryRequest ''ListSchedules + +-- | Filters the result, showing only the schedules whose name matches the query. +lsQuery :: Lens' (Request ListSchedules s b) (Maybe Text) +lsQuery = upd.lsQuery' + +instance Paginate ListSchedules + +-- | List existing on-call schedules. +-- +-- @GET \/schedules@ +-- +-- /See:/ +listSchedules :: RequesterId -> Request ListSchedules s [ScheduleInfo] +listSchedules r = auth listSchedulesBasic & query .~ [("requester_id", r)] + +-- | A version of 'listSchedules' which uses HTTP Basic authentication and +-- doesn't require a 'RequesterId'. +listSchedulesBasic :: Request ListSchedules s [ScheduleInfo] +listSchedulesBasic = + mk ListSchedules + { _lsQuery' = Nothing + } & path .~ schedules + +data GetSchedule = GetSchedule + { _gsSince' :: Maybe Date + , _gsUntil' :: Maybe Date + , _gsTimeZone' :: Maybe TZ + } deriving (Eq, Show) + +queryRequest ''GetSchedule + +-- | The start of the date range over which you want to return on-call schedule +-- entries and on-call schedule layers. +gsSince :: Lens' (Request GetSchedule s b) (Maybe UTCTime) +gsSince = upd.gsSince'.mapping _D + +-- | The end of the date range over which you want to return schedule entries +-- and on-call schedule layers. +gsUntil :: Lens' (Request GetSchedule s b) (Maybe UTCTime) +gsUntil = upd.gsUntil'.mapping _D + +-- | Time zone in which dates in the result will be rendered. +-- +-- /Default:/ account time zone. +gsTimeZone :: Lens' (Request GetSchedule s b) (Maybe TimeZone) +gsTimeZone = upd.gsTimeZone'.mapping _TZ + +-- | Show detailed information about a schedule, including entries for each +-- layer and sub-schedule. +-- +-- @GET \/schedules\/\:id@ +-- +-- /See:/ +getSchedule :: Request GetSchedule s Schedule +getSchedule = + mk GetSchedule + { _gsSince' = Nothing + , _gsUntil' = Nothing + , _gsTimeZone' = Nothing + } & path .~ schedules + + +data GetScheduleUsers = GetScheduleUsers + { _gsuSince' :: Maybe Date + , _gsuUntil' :: Maybe Date + } deriving (Eq, Show) + +queryRequest ''GetScheduleUsers + +-- | The start of the date range over which you want to return on-call users. +gsuSince :: Lens' (Request GetScheduleUsers s b) (Maybe UTCTime) +gsuSince = upd.gsuSince'.mapping _D + +-- | The end time of the date range over which you want to return on-call users. +gsuUntil :: Lens' (Request GetScheduleUsers s b) (Maybe UTCTime) +gsuUntil = upd.gsuUntil'.mapping _D + +-- | List all the users on-call in a given schedule for a given time range. +-- +-- @GET \/schedules\/\:id\/users@ +-- +-- /See:/ +getScheduleUsers :: UserId -> Request GetScheduleUsers s [User] +getScheduleUsers u = + mk GetScheduleUsers + { _gsuSince' = Nothing + , _gsuUntil' = Nothing + } & path .~ schedules % u % "users" + +data GetScheduleEntries = GetScheduleEntries + { _gseSince' :: Date + , _gseUntil' :: Date + , _gseOverflow' :: !Bool' + , _gseTimeZone' :: Maybe TZ + , _gseUserId' :: Maybe UserId + } deriving (Eq, Show) + +queryRequest ''GetScheduleEntries + +-- | The start of the date range over which you want to return on-call +-- schedule entries. +-- The maximum range queryable at once is three months. +gseSince :: Lens' (Request GetScheduleEntries s b) UTCTime +gseSince = upd.gseSince'._D + +-- | The end of the date range over which you want to return schedule entries. +gseUntil :: Lens' (Request GetScheduleEntries s b) UTCTime +gseUntil = upd.gseUntil'._D + +-- | Any on-call schedule entries that pass the date range bounds will be +-- truncated at the bounds, unless the parameter overflow=true is passed. +-- +-- Default: false. +-- +-- Example: if your schedule is a rotation that changes daily at midnight UTC, +-- and your date range is from 2011-06-01T10:00:00Z to 2011-06-01T14:00:00Z: If +-- you don't pass the overflow=true parameter, you will get one schedule entry +-- returned with a start of 2011-06-01T10:00:00Z and end of 2011-06-01T14:00:00Z. +-- If you do pass the overflow=true parameter, you will get one schedule entry +-- returned with a start of 2011-06-01T00:00:00Z and end of 2011-06-02T00:00:00Z. +gseOverflow :: Lens' (Request GetScheduleEntries s b) Bool +gseOverflow = upd.gseOverflow'._B + +-- | Time zone in which dates in the result will be rendered. +-- +-- Default: account time zone. +gseTimeZone :: Lens' (Request GetScheduleEntries s b) (Maybe TimeZone) +gseTimeZone = upd.gseTimeZone'.mapping _TZ + +-- | To filter the returned on-call schedule entries by a specific user, you +-- can optionally add the user_id parameter to the query. +gseUserId :: Lens' (Request GetScheduleEntries s b) (Maybe UserId) +gseUserId = upd.gseUserId' + +-- | List schedule entries that are active for a given time range for a +-- specified on-call schedule. +-- +-- @GET \/schedules\/\:id\/entries@ +-- +-- /See:/ +getScheduleEntries :: UserId + -> Date -- ^ 'gseSince' + -> Date -- ^ 'gseUntil' + -> Request GetScheduleEntries s b +getScheduleEntries i s u = + mk GetScheduleEntries + { _gseSince' = s + , _gseUntil' = u + , _gseOverflow' = F + , _gseTimeZone' = Nothing + , _gseUserId' = Nothing + } & path .~ schedules % i + +data CreateSchedule = CreateSchedule + { _csName' :: Text + , _csOverflow' :: !Bool' + , _csTimeZone' :: TZ + , _csScheduleLayers' :: [ScheduleLayer] + } deriving (Eq, Show) + +makeLenses ''CreateSchedule + +instance ToJSON CreateSchedule where + toJSON cs = object + [ "name" .= _csName' cs + , "overflow" .= _csOverflow' cs + , "schedule" .= object + [ "time_zone" .= _csTimeZone' cs + , "schedule_layers" .= _csScheduleLayers' cs + ] + ] + +instance QueryLike CreateSchedule where + toQuery = const [] + +-- | Any on-call schedule entries that pass the date range bounds will be +-- truncated at the bounds, unless 'csOverflow' is set to 'True'. +-- +-- Default: 'False'. +csOverflow :: Lens' (Request CreateSchedule s b) Bool +csOverflow = upd.csOverflow'._B + +-- | The name of the schedule. +csName :: Lens' (Request CreateSchedule s b) Text +csName = upd.csName' + +-- | The time zone of the schedule. +-- +-- Default: 'UTC'. +csTimeZone :: Lens' (Request CreateSchedule s b) TimeZone +csTimeZone = upd.csTimeZone'._TZ + +-- | A list of schedule layers. +csScheduleLayers :: Lens' (Request CreateSchedule s b) [ScheduleLayer] +csScheduleLayers = upd.csScheduleLayers' + +-- | Create a new on-call schedule. +-- +-- @POST \/schedules@ +-- +-- /See:/ +createSchedule :: Text -- ^ 'csName' + -> TimeZone -- ^ 'csTimeZone' + -> [ScheduleLayer] -- ^ 'csScheduleLayers' + -> Request CreateSchedule s Schedule +createSchedule n z ls = + mk CreateSchedule + { _csName' = n + , _csOverflow' = F + , _csTimeZone' = TZ z + , _csScheduleLayers' = ls + } & meth .~ POST + & path .~ schedules + +data UpdateSchedule = UpdateSchedule + { _usOverflow' :: !Bool' + , _usTimeZone' :: TZ + , _usScheduleLayers' :: [ScheduleLayer] + } deriving (Eq, Show) + +makeLenses ''UpdateSchedule + +instance ToJSON UpdateSchedule where + toJSON us = object + [ "overflow" .= _usOverflow' us + , "schedule" .= object + [ "time_zone" .= _usTimeZone' us + , "schedule_layers" .= _usScheduleLayers' us + ] + ] + +instance QueryLike UpdateSchedule where + toQuery = const [] + +-- | Any on-call schedule entries that pass the date range bounds will be +-- truncated at the bounds, unless 'usOverflow' is set to 'True'. +-- +-- Default: 'False'. +usOverflow :: Lens' (Request UpdateSchedule s b) Bool +usOverflow = upd.usOverflow'._B + +-- | The time zone of the schedule. +usTimeZone :: Lens' (Request UpdateSchedule s b) TimeZone +usTimeZone = upd.usTimeZone'._TZ + +-- | A list of schedule layers. +usScheduleLayers :: Lens' (Request UpdateSchedule s b) [ScheduleLayer] +usScheduleLayers = upd.usScheduleLayers' + +-- | Update an existing on-call schedule. +-- +-- /Note:/ You cannot delete schedule layers. You must include all layers in +-- your update request. To delete a layer, set the end parameter to schedule its +-- termination. +-- +-- @PUT \/schedules\/\:id@ +-- +-- /See:/ +updateSchedule :: ScheduleId + -> TimeZone -- ^ 'usTimeZone' + -> [ScheduleLayer] -- ^ 'usScheduleLayers' + -> Request UpdateSchedule s Schedule +updateSchedule s z ls = + mk UpdateSchedule + { _usOverflow' = F + , _usTimeZone' = TZ z + , _usScheduleLayers' = ls + } & meth .~ PUT + & path .~ schedules % s + +data PreviewSchedule = PreviewSchedule + { _psSince' :: Maybe Date + , _psUntil' :: Maybe Date + , _psName' :: Text + , _psOverflow' :: !Bool' + , _psTimeZone' :: TZ + , _psScheduleLayers' :: [ScheduleLayer] + } deriving (Eq, Show) + +makeLenses ''PreviewSchedule + +instance ToJSON PreviewSchedule where + toJSON ps = object + [ "since" .= _psSince' ps + , "until" .= _psUntil' ps + , "name" .= _psName' ps + , "overflow" .= _psOverflow' ps + , "schedule" .= object + [ "time_zone" .= _psTimeZone' ps + , "schedule_layers" .= _psScheduleLayers' ps + ] + ] + +instance QueryLike PreviewSchedule where + toQuery = const [] + +-- | The start of the date range over which you want to return on-call schedule +-- entries and on-call schedule layers. +psSince :: Lens' (Request PreviewSchedule s b) (Maybe UTCTime) +psSince = upd.psSince'.mapping _D + +-- | The end of the date range over which you want to return schedule entries +-- and on-call schedule layers. +psUntil :: Lens' (Request PreviewSchedule s b) (Maybe UTCTime) +psUntil = upd.psUntil'.mapping _D + +-- | Any on-call schedule entries that pass the date range bounds will be +-- truncated at the bounds, unless 'psOverflow' is set to 'True'. +-- +-- Default: 'False'. +psOverflow :: Lens' (Request PreviewSchedule s b) Bool +psOverflow = upd.psOverflow'._B + +-- | The name of the schedule. +psName :: Lens' (Request PreviewSchedule s b) Text +psName = upd.psName' + +-- | The time zone of the schedule. +-- +-- Default: 'UTC'. +psTimeZone :: Lens' (Request PreviewSchedule s b) TimeZone +psTimeZone = upd.psTimeZone'._TZ + +-- | A list of schedule layers. +psScheduleLayers :: Lens' (Request PreviewSchedule s b) [ScheduleLayer] +psScheduleLayers = upd.psScheduleLayers' + +-- | Preview what a schedule would look like without saving it. This work the +-- same as the update or create actions, except that the result is not +-- persisted. Preview optionally takes two additional arguments, since and until, +-- deliminating the span of the preview. +-- +-- @POST \/schedules\/preview@ +-- +-- /See:/ +previewSchedule :: Text -- ^ 'psName' + -> TimeZone -- ^ 'psTimeZone' + -> [ScheduleLayer] -- ^ 'psScheduleLayers' + -> Request PreviewSchedule s Schedule +previewSchedule n z ls = + mk PreviewSchedule + { _psSince' = Nothing + , _psUntil' = Nothing + , _psName' = n + , _psOverflow' = F + , _psTimeZone' = TZ z + , _psScheduleLayers' = ls + } & meth .~ POST + & path .~ schedules % "preview" + +-- | Delete an on-call schedule. +-- +-- @DELETE \/schedules\/\:id@ +-- +-- /See:/ +deleteSchedule :: ScheduleId -> Request Empty s Empty +deleteSchedule s = empty & meth .~ DELETE & path .~ schedules % s diff --git a/src/Network/PagerDuty/REST/Schedules/Overrides.hs b/src/Network/PagerDuty/REST/Schedules/Overrides.hs new file mode 100644 --- /dev/null +++ b/src/Network/PagerDuty/REST/Schedules/Overrides.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +-- Module : Network.PagerDuty.REST.Schedules +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +-- | Schedule overrides are custom, non-recurring exceptions to your regular +-- on-call schedules. Use them when your team members go on vacation, swap shifts, +-- or when you simply cannot achieve your normal scheduling with recurring layers. +-- +-- /See:/ +module Network.PagerDuty.REST.Schedules.Overrides + ( + -- * List Overrides + ListOverrides + , listOverrides + , lsSince + , lsUntil + , lsEditable + , lsOverflow + + -- * Create Override + , CreateOverride + , createOverride + , coUserId + , coStart + , coEnd + + -- * Delete Override + , deleteOverride + + -- * Types + , HasUserInfo (..) + , Override + , oId + , oStart + , oEnd + , oUser + ) where + +import Control.Lens +import Data.Time +import Network.HTTP.Types +import Network.PagerDuty.REST.Users +import Network.PagerDuty.Internal.TH +import Network.PagerDuty.Internal.Types + +overrides :: ScheduleId -> Path +overrides i = "schedules" % i % "overrides" + +data Override = Override + { _oId :: Maybe OverrideId + , _oStart :: Date + , _oEnd :: Date + , _oUser :: UserInfo + } deriving (Eq, Show) + +deriveRecord ''Override + +instance HasUserInfo Override where + userInfo = oUser + +data ListOverrides = ListOverrides + { _lsSince' :: Date + , _lsUntil' :: Date + , _lsEditable' :: Bool' + , _lsOverflow' :: Bool' + } deriving (Eq, Show) + +queryRequest ''ListOverrides + +-- | The start time of the date range you want to retrieve override for. +-- +-- The maximum date range queryable is 3 months. +lsSince :: Lens' (Request ListOverrides s b) UTCTime +lsSince = upd.lsSince'._D + +-- | The end time of the date range you want to retrieve override for. +lsUntil :: Lens' (Request ListOverrides s b) UTCTime +lsUntil = upd.lsUntil'._D + +-- | When 'True', only editable overrides will be returned. +-- +-- The result will onlyinclude the id the override if this parameter is present. +-- Only future overrides are editable. +-- +-- /Default:/ 'False.' +lsEditable :: Lens' (Request ListOverrides s b) Bool +lsEditable = upd.lsEditable'._B + +-- | Any on-call schedule entries that pass the date range bounds will be +-- truncated at the bounds, unless @lsEditable .~ True@ is specified. +-- +-- /Default:/ 'False.' +lsOverflow :: Lens' (Request ListOverrides s b) Bool +lsOverflow = upd.lsOverflow'._B + +-- | List overrides for a given time range. +-- +-- @GET \/schedules\/\:schedule_id\/overrides@ +-- +-- /See:/ +listOverrides :: ScheduleId + -> Date -- ^ 'lsSince' + -> Date -- ^ 'lsUntil' + -> Request ListOverrides s [Override] +listOverrides i s u = + mk ListOverrides + { _lsSince' = s + , _lsUntil' = u + , _lsEditable' = F + , _lsOverflow' = F + } & path .~ overrides i + +data CreateOverride = CreateOverride + { _coStart' :: Date + , _coEnd' :: Date + , _coUserId' :: UserId + } deriving (Eq, Show) + +jsonRequest ''CreateOverride + +-- | The start date and time for the override. +coStart :: Lens' (Request CreateOverride s b) UTCTime +coStart = upd.coStart'._D + +-- | The end date and time for the override. +coEnd :: Lens' (Request CreateOverride s b) UTCTime +coEnd = upd.coEnd'._D + +-- | The ID of the user who will be on call for the duration of the override. +coUserId :: Lens' (Request CreateOverride s b) UserId +coUserId = upd.coUserId' + +-- | Create an override for a specific user covering the specified time range. If +-- you create an override on top of an existing one, the last created override +-- will have priority. +-- +-- If no time zone information is present in the since and until parameters, the +-- schedule's time zone will be used. +-- +-- /Note:/ You cannot create overrides in the past. +-- +-- @POST \/schedules\/\:schedule_id\/overrides@ +-- +-- /See:/ +createOverride :: ScheduleId + -> UserId -- ^ 'coUserId' + -> Date -- ^ 'coStart' + -> Date -- ^ 'coEnd' + -> Request CreateOverride s Override +createOverride i u s e = + mk CreateOverride + { _coUserId' = u + , _coStart' = s + , _coEnd' = e + } & meth .~ POST + & path .~ overrides i + +-- | Remove an override. +-- +-- You cannot remove a past override. If the override start +-- time is before the current time, but the end time is after the current time, +-- the override will be truncated to the current time. If the override is +-- truncated, the status code will be 200 OK, as opposed to a 204 No Content for a +-- successful delete. +-- +-- @DELETE \/schedules\/\:schedule_id\/overrides\/\:id@ +-- +-- /See:/ + +-- FIXME: How to parse whether truncated or deleted? +deleteOverride :: ScheduleId -> OverrideId -> Request Empty s Empty +deleteOverride i o = empty + & meth .~ DELETE + & path .~ overrides i % o diff --git a/src/Network/PagerDuty/REST/Services.hs b/src/Network/PagerDuty/REST/Services.hs new file mode 100644 --- /dev/null +++ b/src/Network/PagerDuty/REST/Services.hs @@ -0,0 +1,513 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +-- Module : Network.PagerDuty.REST.Services +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +-- | This API lets you access and manipulate the services across your account. +-- +-- A service is an endpoint (like Nagios, email, or an API call) that +-- generates events, which Pagerduty normalizes and dedupes, creating incidents. +-- +-- When a service is shown inlined in other resources, a deleted service will +-- have its @html_url@ attribute set to 'Nothing'. +-- +-- /See:/ +module Network.PagerDuty.REST.Services + ( + -- * List Services + ListServices + , listServices + , lsTimeZone + + -- * Create Service + , CreateService + , createService + , csName + , csDescription + , csType + , csVendorId + , csEscalationPolicyId + , csAcknowledgementTimeout + , csAutoResolveTimeout + , csSeverityFilter + + -- * Get Service + , getService + + -- * Update Service + , UpdateService + , updateService + , usName + , usEscalationPolicyId + , usDescription + , usAcknowledgementTimeout + , usAutoResolveTimeout + , usSeverityFilter + + -- * Delete Service + , deleteService + + -- * Enable Service + , enableService + + -- * Disable Service + , disableService + + -- * Regenerate Key + , regenerateKey + + -- * Types + , EmailFilterMode (..) + , EmailIncidentCreation (..) + , ServiceStatus (..) + , ServiceType (..) + , SeverityFilter (..) + + , IncidentCounts + , cntTriggered + , cntAcknowledged + , cntResolved + , cntTotal + + , PolicyInfo + , pinfoId + , pinfoName + + , Service + , svcId + , svcName + , svcDescription + , svcServiceUrl + , svcServiceKey + , svcAutoResolveTimeout + , svcAcknowledgementTimeout + , svcCreatedAt + , svcStatus + , svcLastIncidentTimestamp + , svcEmailIncidentCreation + , svcIncidentCounts + , svcEmailFilterMode + , svcType + , svcEscalationPolicy + , svcEmailFilters + , svcSeverityFilter + ) where + +import Control.Lens +import Data.Aeson.Lens +import Data.Text (Text) +import Data.Time +import Network.HTTP.Types +import Network.PagerDuty.REST.Services.EmailFilters +import Network.PagerDuty.Internal.TH +import Network.PagerDuty.Internal.Types + +default (Path) + +services :: Path +services = "services" + +includes :: Query +includes = + [ ("include[]", Just "escalation_policy") + , ("include[]", Just "email_filters") + ] + +data IncidentCounts = IncidentCounts + { _cntTriggered :: !Int + , _cntAcknowledged :: !Int + , _cntResolved :: !Int + , _cntTotal :: !Int + } deriving (Eq, Show) + +deriveRecord ''IncidentCounts + +data EmailIncidentCreation + = OnNewEmail + -- ^ Open a new incident for each trigger email. + | OnNewEmailSubject + -- ^ Open a new incident for each new trigger email subject. + | OnlyIfNoOpenIncidents + -- ^ Open a new incident only if an open incident does not already exist. + deriving (Eq, Show) + +deriveNullary ''EmailIncidentCreation + +data EmailFilterMode + = AllEmail + -- ^ Accept all incoming email + | OrRulesEmail + -- ^ Accept email only if it matches ONE OR MORE rules below + | AndRulesEmail + -- ^ Accept email only if it matches ALL of the rules below + deriving (Eq, Show) + +deriveNullaryWith hyphenated ''EmailFilterMode + +data ServiceStatus + = Active + -- ^ The service is enabled and has no open incidents. + | Warning + -- ^ The service is enabled and has one or more acknowledged incidents. + | Critical + -- ^ The service is enabled and has one or more triggered incidents. + | Maintenance + -- ^ The service is under maintenance, no new incidents will be + -- triggered during maintenance mode. + | Disabled + -- ^ The service is disabled and will not have any new triggered incidents. + deriving (Eq, Show) + +deriveNullary ''ServiceStatus + +data ServiceType + = CloudKick + | GenericEmail + | GenericEventsApi + | Keynote + | Nagios + | Pingdom + | ServerDensity + | SqlMonitor + deriving (Eq, Show) + +deriveNullary ''ServiceType + +data PolicyInfo = PolicyInfo + { _pinfoId :: EscalationPolicyId + , _pinfoName :: Text + } deriving (Eq, Show) + +deriveRecord ''PolicyInfo + +data SeverityFilter + = SevCritical + -- ^ Incidents are created when an alarm enters the Critical state. + | SevCriticalOrWarning + -- ^ Incidents are created when an alarm enters the Critical OR Warning states + | SevOnAny + -- ^ SQL Monitor: Incidents are created for alerts of any severity. + | SevOnHigh + -- ^ SQL Monitor: Incidents are created for alerts with high severity. + | SevOnMediumHigh + -- ^ SQL Monitor: Incidents are created for with high or medium severity + deriving (Eq, Show) + +deriveNullaryWith (dropped 3 underscored) ''SeverityFilter + +data Service = Service + { _svcId :: ServiceId + , _svcName :: Text + , _svcDescription :: Text + , _svcServiceUrl :: Text + , _svcServiceKey :: ServiceKey + , _svcAutoResolveTimeout :: Maybe Int + , _svcAcknowledgementTimeout :: Maybe Int + , _svcCreatedAt :: Date + , _svcStatus :: ServiceStatus + , _svcLastIncidentTimestamp :: Maybe Date + , _svcEmailIncidentCreation :: Maybe EmailIncidentCreation + , _svcIncidentCounts :: IncidentCounts + , _svcEmailFilterMode :: EmailFilterMode + , _svcType :: ServiceType + , _svcEscalationPolicy :: Maybe PolicyInfo -- FIXME: extract from inline. + , _svcEmailFilters :: Maybe [EmailFilterInfo] -- FIXME: extract from inline. + , _svcSeverityFilter :: Maybe SeverityFilter + } deriving (Eq, Show) + +deriveJSON ''Service + +-- | A unique identifier for this service. +makeLens "_svcId" ''Service + +-- | The name of the service. +makeLens "_svcName" ''Service + +-- | The description of the service +makeLens "_svcDescription" ''Service + +-- | Relative URL that corresponds to this service. +makeLens "_svcServiceUrl" ''Service + +-- | For Email services, the serviceKey is the associated email address +-- for the service. +-- For all other service types, this is the unique key used for API calls. +makeLens "_svcServiceKey" ''Service + +-- | Time in seconds that an incident changes to the Triggered State after +-- being Acknowledged. Value is 'Nothing' if the feature is disabled. +makeLens "_svcAutoResolveTimeout" ''Service + +-- | Time in seconds that an incident is automatically resolved if left open for +-- that long. Value is 'Nothing' is the feature is disabled. +makeLens "_svcAcknowledgementTimeout" ''Service + +-- | The date/time when this service was created. +svcCreatedAt :: Lens' Service UTCTime +svcCreatedAt = lens _svcCreatedAt (\s x -> s { _svcCreatedAt = x }) . _D + +-- | The current state of the Service. +makeLens "_svcStatus" ''Service + +-- | The date/time when the most recent incident was created for this service. +svcLastIncidentTimestamp :: Lens' Service (Maybe UTCTime) +svcLastIncidentTimestamp = + lens _svcLastIncidentTimestamp + (\s x -> s { _svcLastIncidentTimestamp = x }) . mapping _D + +-- | If the service is a Generic Email service, this describes what kind of +-- emails create an incident. +makeLens "_svcEmailIncidentCreation" ''Service + +-- | An object with the number of incidents corresponding to these states. +makeLens "_svcIncidentCounts" ''Service + +-- | If the service is a Generic Email service, this describes which types of +-- email will generate an incident. +makeLens "_svcEmailFilterMode" ''Service + +-- | The service type. +makeLens "_svcType" ''Service + +-- | An object containing the ID and name of the escalation policy used by this +-- service. +makeLens "_svcEscalationPolicy" ''Service + +-- | An object containing inline Email Filters. +-- Note that only genericEmail services have filters. +makeLens "_svcEmailFilters" ''Service + +-- | Specifies what severity levels will create a new open incident. +makeLens "_svcSeverityFilter" ''Service + +newtype ListServices = ListServices + { _lsTimeZone' :: Maybe TZ + } deriving (Eq, Show) + +instance Paginate ListServices + +queryRequest ''ListServices + +-- | Time zone in which dates in the result will be rendered. +-- +-- /Default:/ account default time zone. +lsTimeZone :: Lens' (Request ListServices s r) (Maybe TimeZone) +lsTimeZone = upd.lsTimeZone'.mapping _TZ + +-- | List existing services. +-- +-- @GET \/services@ +-- +-- /See:/ +listServices :: Request ListServices s [Service] +listServices = + mk ListServices + { _lsTimeZone' = Nothing + } & path .~ services + & query .~ includes + & unwrap .~ key "escalation_policies" + +data CreateService = CreateService + { _csName' :: Text + , _csEscalationPolicyId' :: EscalationPolicyId + , _csType' :: !ServiceType + , _csVendorId' :: Maybe VendorId + , _csDescription' :: Maybe Text + , _csAcknowledgementTimeout' :: Maybe Int + , _csAutoResolveTimeout' :: Maybe Int + , _csSeverityFilter' :: Maybe SeverityFilter + } deriving (Eq, Show) + +jsonRequest ''CreateService + +-- | The name of the service. +csName :: Lens' (Request CreateService s r) Text +csName = upd.csName' + +-- | A description for your service. 1024 character maximum. +csDescription :: Lens' (Request CreateService s r) (Maybe Text) +csDescription = upd.csDescription' + +-- | The type of service to create. +csType :: Lens' (Request CreateService s r) ServiceType +csType = upd.csType' + +-- | PagerDuty's internal vendor identifier for this service. For more information +-- about a specific vendor, please contact PagerDuty Support. +csVendorId :: Lens' (Request CreateService s r) (Maybe VendorId) +csVendorId = upd.csVendorId' + +-- | The id of the escalation policy to be used by this service. +csEscalationPolicyId :: Lens' (Request CreateService s r) EscalationPolicyId +csEscalationPolicyId = upd.csEscalationPolicyId' + +-- | The duration in seconds before an incidents acknowledged in this service +-- become triggered again. +-- +-- /Default:/ 30 minutes. +csAcknowledgementTimeout :: Lens' (Request CreateService s r) (Maybe Int) +csAcknowledgementTimeout = upd.csAcknowledgementTimeout' + +-- | The duration in seconds before a triggered incident auto-resolves itself. +-- +-- /Default:/ 4 hours. +csAutoResolveTimeout :: Lens' (Request CreateService s r) (Maybe Int) +csAutoResolveTimeout = upd.csAutoResolveTimeout' + +-- | Specifies what severity levels will create a new open incident. +csSeverityFilter :: Lens' (Request CreateService s r) (Maybe SeverityFilter) +csSeverityFilter = upd.csSeverityFilter' + +-- | Creates a new service. +-- +-- @POST \/services@ +-- +-- /See:/ +createService :: Text + -> EscalationPolicyId + -> ServiceType + -> Request CreateService s Service +createService n p t = + mk CreateService + { _csName' = n + , _csEscalationPolicyId' = p + , _csType' = t + , _csVendorId' = Nothing + , _csDescription' = Nothing + , _csAcknowledgementTimeout' = Nothing + , _csAutoResolveTimeout' = Nothing + , _csSeverityFilter' = Nothing + } & path .~ services + & unwrap .~ key "service" + +-- | Get details about an existing service. +-- +-- @GET services\/\:id@ +-- +-- /See:/ +getService :: ServiceId -> Request Empty s Service +getService i = empty + & path .~ services % i + & query <>~ includes + & unwrap .~ key "service" + +data UpdateService = UpdateService + { _usName' :: Maybe Text + , _usDescription' :: Maybe Text + , _usEscalationPolicyId' :: Maybe EscalationPolicyId + , _usAcknowledgementTimeout' :: Maybe Int + , _usAutoResolveTimeout' :: Maybe Int + , _usSeverityFilter' :: Maybe SeverityFilter + } deriving (Eq, Show) + +jsonRequest ''UpdateService + +-- | The name of the service. +usName :: Lens' (Request UpdateService s r) (Maybe Text) +usName = upd.usName' + +-- | A description for your service. 1024 character maximum. +usDescription :: Lens' (Request UpdateService s r) (Maybe Text) +usDescription = upd.usDescription' + +-- | The id of the escalation policy to be used by this service. +usEscalationPolicyId :: Lens' (Request UpdateService s r) (Maybe EscalationPolicyId) +usEscalationPolicyId = upd.usEscalationPolicyId' + +-- | The duration in seconds before an incidents acknowledged in this service +-- become triggered again. +-- +-- /Default:/ 30 minutes. +usAcknowledgementTimeout :: Lens' (Request UpdateService s r) (Maybe Int) +usAcknowledgementTimeout = upd.usAcknowledgementTimeout' + +-- | The duration in seconds before a triggered incident auto-resolves itself. +-- +-- /Default:/ 4 hours. +usAutoResolveTimeout :: Lens' (Request UpdateService s r) (Maybe Int) +usAutoResolveTimeout = upd.usAutoResolveTimeout' + +-- | Specifies what severity levels will create a new open incident. +usSeverityFilter :: Lens' (Request UpdateService s r) (Maybe SeverityFilter) +usSeverityFilter = upd.usSeverityFilter' + +-- | Update an existing service. +-- +-- @PUT services\/\:id@ +-- +-- /See:/ +updateService :: ServiceId -> Request UpdateService s Service +updateService i = + mk UpdateService + { _usName' = Nothing + , _usEscalationPolicyId' = Nothing + , _usDescription' = Nothing + , _usAcknowledgementTimeout' = Nothing + , _usAutoResolveTimeout' = Nothing + , _usSeverityFilter' = Nothing + } & meth .~ PUT + & path .~ services % i + & unwrap .~ key "service" + +-- | Delete an existing service. Once the service is deleted, it will not be +-- accessible from the web UI and new incidents won't be able to be created +-- for this service. +-- +-- @DELETE \/services/:id@ +-- +-- /See:/ +deleteService :: ServiceId -> Request Empty s Empty +deleteService i = empty & meth .~ DELETE & path .~ services % i + +-- | Enable a previously disabled service. +-- +-- @PUT services\/\:id\/enable@ +-- +-- /See:/ +enableService :: RequesterId -> ServiceId -> Request Empty s Empty +enableService r i = + auth (enableServiceBasic i) & query .~ [("requester_id", r)] + +-- | A version of 'enableService' which uses HTTP Basic authentication and +-- doesn't require a 'RequesterId'. +enableServiceBasic :: ServiceId -> Request Empty Basic Empty +enableServiceBasic i = empty & meth .~ PUT & path .~ services % i % "enable" + +-- | Disable a service. Once a service is disabled, it will not be able to +-- create incidents until it is enabled again. +-- +-- @PUT services\/\:id\/disable@ +-- +-- /See:/ +disableService :: RequesterId -> ServiceId -> Request Empty s Empty +disableService r i = + auth (disableServiceBasic i) & query .~ [("requester_id", r)] + +-- | A version of 'disableService' which uses HTTP Basic authentication and +-- doesn't require a 'RequesterId'. +disableServiceBasic :: ServiceId -> Request Empty Basic Empty +disableServiceBasic i = empty & meth .~ PUT & path .~ services % i % "disable" + +-- | Regenerate a new service key for an existing service. +-- +-- _Warning! The service's previous key will be invalidated, and existing +-- monitoring integrations will need to be modified to use the new key!_ +-- +-- @POST services\/\:id\/regenerate_key@ +-- +-- /See:/ +regenerateKey :: ServiceId -> Request Empty s Service +regenerateKey i = empty & meth .~ POST & path .~ services % i % "regenerate_key" diff --git a/src/Network/PagerDuty/REST/Services/EmailFilters.hs b/src/Network/PagerDuty/REST/Services/EmailFilters.hs new file mode 100644 --- /dev/null +++ b/src/Network/PagerDuty/REST/Services/EmailFilters.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +-- Module : Network.PagerDuty.REST.Services.EmailFilters +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +-- | Email Filters are a set of rules that are applied to triggering email's body, +-- subject and from address. It only applies to generic_email kind of +-- Services. The way multiple filters are combined depends on the +-- email_filter_mode attribute of the service. +-- +-- /See:/ +module Network.PagerDuty.REST.Services.EmailFilters + ( + -- * Create Email Filter + createEmailFilter + + -- * Update Email Filter + , updateEmailFilter + + -- * Delete Email Filter + , deleteEmailFilter + + -- * Types + , MatchMode (..) + , HasEmailFilterInfo (..) + , EmailFilterInfo + , EmailFilter + , efId + ) where + +import Control.Applicative hiding (empty) +import Control.Lens hiding ((.=)) +import Data.Aeson +import Data.Default.Class +import Data.Monoid +import Data.Text (Text) +import Network.HTTP.Types +import Network.PagerDuty.Internal.TH +import Network.PagerDuty.Internal.Types + +default (Path) + +filters :: ServiceId -> Path +filters s = "services" % s % "email_filters" + +data MatchMode + = Always + | Match + | NoMatch + deriving (Eq, Show) + +deriveNullaryWith hyphenated ''MatchMode + +-- FIXME: Tighten up this type! Make the regex required for match/no-match and +-- encode the conditional invariants. +data EmailFilterInfo = EmailFilterInfo + { _efSubjectMode' :: Maybe MatchMode + , _efSubjectRegex' :: Maybe Text + , _efBodyMode' :: Maybe MatchMode + , _efBodyRegex' :: Maybe Text + , _efFromEmailMode' :: Maybe MatchMode + , _efFromEmailRegex' :: Maybe Text + } deriving (Eq, Show) + +deriveRecord ''EmailFilterInfo + +instance Default EmailFilterInfo where + def = EmailFilterInfo Nothing Nothing Nothing Nothing Nothing Nothing + +instance QueryLike EmailFilterInfo where + toQuery = const [] + +class HasEmailFilterInfo a where + emailFilterInfo :: Lens' a EmailFilterInfo + + -- | One of always, match, no-match, which, respectively, means to not + -- filter the email trigger by subject, filter it if the email subject + -- matches the given regex, or filter if it doesn't match the given regex. + -- + -- /Default:/ always. + efSubjectMode :: Lens' a (Maybe MatchMode) + + -- | The regex to be used when subject_mode is match or no-match. + -- It is a required parameter on such cases. + efSubjectRegex :: Lens' a (Maybe Text) + + -- | One of always, match, no-match, which, respectively, means to not filter + -- the email trigger by body, filter it if the body email matches the given + -- regex, or filter if it doesn't match the given regex. + -- + -- /Default:/ always. + efBodyMode :: Lens' a (Maybe MatchMode) + + -- | The regex to be used when body_mode is match or no-match. + -- It is a required parameter on such cases. + efBodyRegex :: Lens' a (Maybe Text) + + -- | One of always, match, no-match, which, respectively, means to not filter + -- the email trigger by its from address, filter it if the email from address + -- matches the given regex, or filter if it doesn't match the given regex. + -- + -- /Default:/ always. + efFromEmailMode :: Lens' a (Maybe MatchMode) + + -- | The regex to be used when from_email_mode is match or no-match. + -- It is a required parameter on such cases. + efFromEmailRegex :: Lens' a (Maybe Text) + + efSubjectMode = emailFilterInfo.efSubjectMode' + efSubjectRegex = emailFilterInfo.efSubjectRegex' + efBodyMode = emailFilterInfo.efBodyMode' + efBodyRegex = emailFilterInfo.efBodyRegex' + efFromEmailMode = emailFilterInfo.efFromEmailMode' + efFromEmailRegex = emailFilterInfo.efFromEmailRegex' + +instance (QueryLike a, ToJSON a, HasEmailFilterInfo a) + => HasEmailFilterInfo (Request a s b) where + emailFilterInfo = upd.emailFilterInfo + +instance HasEmailFilterInfo EmailFilterInfo where + emailFilterInfo = id + +data EmailFilter = EmailFilter + { _efId :: EmailFilterId + , _efInfo :: EmailFilterInfo + } deriving (Eq, Show) + +instance FromJSON EmailFilter where + parseJSON = withObject "email_filter" $ \o -> + EmailFilter <$> parseJSON (Object o) + <*> o .: "id" + +instance ToJSON EmailFilter where + toJSON e = Object (x <> y) + where + Object x = toJSON (_efInfo e) + Object y = object ["id" .= _efId e] + +instance HasEmailFilterInfo EmailFilter where + emailFilterInfo = lens _efInfo (\e x -> e { _efInfo = x }) + +-- | The email filter ID. +makeLens "_efId" ''EmailFilter + +-- | Create a new Email Filter for the specified service. +-- +-- @POST \/services\/\:service_id\/email_filters@ +-- +-- /See:/ +createEmailFilter :: ServiceId -> Request EmailFilterInfo s EmailFilter +createEmailFilter s = mk def & meth .~ POST & path .~ filters s + +-- | Update an existing Email Filter. +-- +-- @PUT \/services\/\:service_id\/email_filters\/\:id@ +-- +-- /See:/ +updateEmailFilter :: ServiceId + -> EmailFilterId + -> Request EmailFilterInfo s Empty +updateEmailFilter s e = mk def & meth .~ PUT & path .~ filters s % e + +-- | Delete an existing Email Filter. +-- +-- @DELETE \/services\/\:service_id\/email_filters\/\:id@ +-- +-- /See:/ +deleteEmailFilter :: ServiceId -> EmailFilterId -> Request Empty s Empty +deleteEmailFilter s e = empty & meth .~ DELETE & path .~ filters s % e diff --git a/src/Network/PagerDuty/REST/Users.hs b/src/Network/PagerDuty/REST/Users.hs new file mode 100644 --- /dev/null +++ b/src/Network/PagerDuty/REST/Users.hs @@ -0,0 +1,384 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +-- Module : Network.PagerDuty.REST.Users +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +-- | Access and manipulate user data for your PagerDuty account. When a user is +-- shown inlined in other resources, a deleted user will have its @html_url@ attribute +-- set to null. +-- +-- /See:/ +module Network.PagerDuty.REST.Users + ( + -- * List Users + ListUsers + , listUsers + , luQuery + + -- * List On Call Users + , listOnCallUsers + + -- * Create User + , CreateUser + , createUser + , cuName + , cuEmail + , cuRole + , cuJobTitle + , cuTimeZone + + -- * Get User + , getUser + + -- * Get User On Call + , getUserOnCall + + -- * Update User + , UpdateUser + , updateUser + , uuName + , uuEmail + , uuRole + , uuJobTitle + , uuTimeZone + + -- * Delete User + , deleteUser + + -- * Types + , PolicyInfo + , piId + , piName + + , OnCall + , ocLevel + , ocStart + , ocEnd + , ocEscalationPolicy + + , Role (..) + + , HasUserInfo (..) + , UserInfo + , User + , uRole + , uAvatarUrl + , uUserUrl + , uInvitationSent + , uJobTitle + ) where + +import Control.Applicative hiding (empty) +import Control.Lens hiding ((.=)) +import Data.Aeson +import Data.Default.Class +import Data.Monoid +import Data.Text (Text) +import Data.Time +import Network.HTTP.Types +import Network.PagerDuty.Internal.TH +import Network.PagerDuty.Internal.Types + +default (Path) + +users :: Path +users = "users" + +includes :: Query +includes = + [ ("include[]", Just "contact_methods") + , ("include[]", Just "notification_rules") + ] + +data UserInfo = UserInfo + { _uId' :: UserId + , _uName' :: Text + , _uEmail' :: Address + , _uColor' :: Text + , _uTimeZone' :: TZ + } deriving (Eq, Show) + +deriveRecord ''UserInfo + +class HasUserInfo a where + userInfo :: Lens' a UserInfo + + -- | The id of the user. + uId :: Lens' a UserId + + -- | The name of the user. + uName :: Lens' a Text + + -- | The user's email address. + uEmail :: Lens' a Address + + -- | The color used to represent the user in schedules. + uColor :: Lens' a Text + + -- | The user's personal time zone. + uTimeZone :: Lens' a TimeZone + + uId = userInfo.uId' + uName = userInfo.uName' + uEmail = userInfo.uEmail' + uColor = userInfo.uColor' + uTimeZone = userInfo.uTimeZone'._TZ + +instance (QueryLike a, ToJSON a, HasUserInfo a) + => HasUserInfo (Request a s b) where + userInfo = upd.userInfo + +instance HasUserInfo UserInfo where + userInfo = id + +data PolicyInfo = PolicyInfo + { _piId :: EscalationPolicyId + , _piName :: Text + } deriving (Eq, Show) + +deriveRecord ''PolicyInfo + +data OnCall = OnCall + { _ocLevel :: !Int + , _ocStart :: Maybe Date + , _ocEnd :: Maybe Date + , _ocEscalationPolicy :: PolicyInfo + } deriving (Eq, Show) + +deriveRecord ''OnCall + +data Role + = RoleAdmin + | RoleUser + | RoleLimitedUser + deriving (Eq, Show) + +deriveNullaryWith (dropped 4 underscored) ''Role + +instance Default Role where + def = RoleUser + +data User = User + { _uInfo :: UserInfo + , _uRole :: !Role + , _uAvatarUrl :: Text + , _uUserUrl :: Text + , _uInvitationSent' :: !Bool' + , _uJobTitle :: Maybe Text + } deriving (Eq, Show) + + -- FIXME: add notification_rules, contact_methods, on_call + +makeLenses ''User + +instance FromJSON User where + parseJSON = withObject "user" $ \o -> + User <$> parseJSON (Object o) + <*> o .: "role" + <*> o .: "avatar_url" + <*> o .: "user_url" + <*> o .: "invitation_sent" + <*> o .:? "job_title" + +instance ToJSON User where + toJSON u = Object (x <> y) + where + Object x = toJSON (_uInfo u) + Object y = object + [ "role" .= _uRole u + , "avatar_url" .= _uAvatarUrl u + , "user_url" .= _uUserUrl u + , "invitation_sent" .= _uInvitationSent' u + , "job_title" .= _uJobTitle u + ] + +instance HasUserInfo User where + userInfo = uInfo + +uInvitationSent :: Lens' User Bool +uInvitationSent = uInvitationSent'._B + +newtype ListUsers = ListUsers + { _luQuery' :: Maybe Text + } + +queryRequest ''ListUsers + +instance Paginate ListUsers + +-- | Filters the result, showing only the users whose names or email addresses +-- match the query. +luQuery :: Lens' (Request ListUsers s b) (Maybe Text) +luQuery = upd.luQuery' + +-- | List users of your PagerDuty account, optionally filtered by a search query. +-- +-- @GET \/users@ +-- +-- /See:/ +listUsers :: Request ListUsers s [User] +listUsers = + mk ListUsers + { _luQuery' = Nothing + } & path .~ users + & query .~ includes + +-- | List all the existing escalation policies with currently on-call users. +-- +-- If the start and end of an on-call object are null, then the user is always +-- on-call for an escalation policy level. +-- +-- @GET \/escalation_policies\/on_call@ +-- +-- /See:/ +listOnCallUsers :: Request ListUsers s [User] +listOnCallUsers = listUsers & path .~ users % "on_call" + +-- | Get information about an existing user. +-- +-- @GET \/users\/\:id@ +-- +-- /See:/ +getUser :: UserId -> Request Empty s User +getUser u = empty & path .~ users % u & query .~ includes + +-- | Get a user object with that user's current on-call status. If the on-call +-- object is an empty list, the user is never on-call. +-- +-- If the start and end of an on-call object are null, then the user is always +-- on-call for an escalation policy level. +-- +-- @GET \/users\/\:id\/on_call@ +-- +-- /See:/ +getUserOnCall :: UserId -> Request Empty s User +getUserOnCall u = empty & path .~ users % u % "on_call" & query .~ includes + +data CreateUser = CreateUser + { _cuName' :: Text + , _cuEmail' :: Address + , _cuRole' :: Maybe Role + , _cuJobTitle' :: Maybe Text + , _cuTimeZone' :: Maybe TZ + } deriving (Eq, Show) + +jsonRequest ''CreateUser + +-- | The name of the user. +cuName :: Lens' (Request CreateUser s b) Text +cuName = upd.cuName' + +-- | The email of the user. The newly created user will receive an email asking +-- to confirm the subscription. +cuEmail :: Lens' (Request CreateUser s b) Address +cuEmail = upd.cuEmail' + +-- | The user's role. +cuRole :: Lens' (Request CreateUser s b) (Maybe Role) +cuRole = upd.cuRole' + +-- | The job title of the user. +cuJobTitle :: Lens' (Request CreateUser s b) (Maybe Text) +cuJobTitle = upd.cuJobTitle' + +-- | The time zone the user is in. If not specified, the time zone of the +-- account making the API call will be used. +cuTimeZone :: Lens' (Request CreateUser s b) (Maybe TimeZone) +cuTimeZone = upd.cuTimeZone'.mapping _TZ + +-- | Create a new user for your account. An invite email will be sent asking +-- the user to choose a password. +-- +-- @POST \/users@ +-- +-- /See:/ +createUser :: RequesterId + -> Text -- ^ 'cuName' + -> Address -- ^ 'cuEmail' + -> Request CreateUser s User +createUser r n e = auth (createUserBasic n e) & query .~ [("requester_id", r)] + +-- | A version of 'disableService' which uses HTTP Basic authentication and +-- doesn't require a 'RequesterId'. +createUserBasic :: Text -- ^ 'cuName' + -> Address -- ^ 'cuEmail' + -> Request CreateUser Basic User +createUserBasic n e = + mk CreateUser + { _cuName' = n + , _cuEmail' = e + , _cuRole' = Nothing + , _cuJobTitle' = Nothing + , _cuTimeZone' = Nothing + } & meth .~ POST + & path .~ users + +data UpdateUser = UpdateUser + { _uuName' :: Maybe Text + , _uuEmail' :: Maybe Address + , _uuRole' :: Maybe Role + , _uuJobTitle' :: Maybe Text + , _uuTimeZone' :: Maybe TZ + } deriving (Eq, Show) + +jsonRequest ''UpdateUser + +-- | The name of the user. +uuName :: Lens' (Request UpdateUser s b) (Maybe Text) +uuName = upd.uuName' + +-- | The email of the user. The newly created user will receive an email asking +-- to confirm the subscription. +uuEmail :: Lens' (Request UpdateUser s b) (Maybe Address) +uuEmail = upd.uuEmail' + +-- | The user's role. +uuRole :: Lens' (Request UpdateUser s b) (Maybe Role) +uuRole = upd.uuRole' + +-- | The job title of the user. +uuJobTitle :: Lens' (Request UpdateUser s b) (Maybe Text) +uuJobTitle = upd.uuJobTitle' + +-- | The time zone the user is in. If not specified, the time zone of the +-- account making the API call will be used. +uuTimeZone :: Lens' (Request UpdateUser s b) (Maybe TimeZone) +uuTimeZone = upd.uuTimeZone'.mapping _TZ + +-- | Update an existing user. +-- +-- @PUT \/users\/\:id@ +-- +-- /See:/ +updateUser :: UserId -> Request UpdateUser s User +updateUser u = + mk UpdateUser + { _uuName' = Nothing + , _uuEmail' = Nothing + , _uuRole' = Nothing + , _uuJobTitle' = Nothing + , _uuTimeZone' = Nothing + } & meth .~ PUT + & path .~ users % u + +-- | Remove an existing user. +-- +-- @DELETE \/users\/\:id@ +-- +-- /See:/ +deleteUser :: UserId -> Request Empty s Empty +deleteUser u = empty & meth .~ DELETE & path .~ users % u +-- FIXME: deal with conflict errors diff --git a/src/Network/PagerDuty/REST/Users/ContactMethods.hs b/src/Network/PagerDuty/REST/Users/ContactMethods.hs new file mode 100644 --- /dev/null +++ b/src/Network/PagerDuty/REST/Users/ContactMethods.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +-- Module : Network.PagerDuty.REST.Users.ContactMethods +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +-- | Contact methods describe the various channels (phone numbers, SMS numbers +-- and email addresses) used to contact a user when an incident is assigned to +-- the user. +-- +-- Access and manipulate the contact methods for a user. +-- +-- /See:/ +module Network.PagerDuty.REST.Users.ContactMethods + ( + -- * List Contacts + listContacts + + -- * Create Contact + , CreateContact + , createContact + , ccType + , ccAddress + , ccCountryCode + , ccLabel + , ccSendShortEmail + + -- * Get Contact + , getContact + + -- * Update Contact + , UpdateContact + , updateContact + , ucAddress + , ucCountryCode + , ucLabel + , ucSendShortEmail + + -- * Delete Contact + , deleteContact + + -- * Types + , ContactType (..) + + , HasContact (..) + , Contact + ) where + +import Control.Lens +import Data.Aeson.Lens +import Data.Text (Text) +import Network.HTTP.Types +import Network.PagerDuty.Internal.TH +import Network.PagerDuty.Internal.Types + +default (Path) + +contacts :: UserId -> Path +contacts u = "users" % u % "contact_methods" + +data ContactType + = SMS + | Phone + | Email + deriving (Eq, Show) + +deriveNullary ''ContactType + +data Contact = Contact + { _cId :: ContactId + , _cUserId :: UserId + , _cLabel :: Text + , _cAddress :: Address + , _cType :: !ContactType + , _cCountryCode :: Maybe Int + , _cSendShortEmail :: Maybe Bool' + , _cBlacklisted :: Maybe Bool' + } deriving (Eq, Show) + +deriveJSON ''Contact +makeClassy ''Contact + +-- | List existing contact methods for the specified user. +-- +-- @GET \/users\/\:user_id\/contact_methods@ +-- +-- /See:/ +listContacts :: UserId -> Request Empty s [Contact] +listContacts u = empty & path .~ contacts u + +-- | Get details for a contact method. +-- +-- @GET \/users\/\:user_id\/contact_methods\/\:id@ +-- +-- /See:/ +getContact :: UserId -> ContactId -> Request Empty s Contact +getContact u c = empty & path .~ contacts u % c + +data CreateContact = CreateContact + { _ccType' :: !ContactType + , _ccAddress' :: Address + , _ccCountryCode' :: Maybe Int + , _ccLabel' :: Maybe Text + , _ccSendShortEmail' :: Maybe Bool' + } deriving (Eq, Show) + +jsonRequest ''CreateContact + +-- | The type of the contact method. +ccType :: Lens' (Request CreateContact s b) ContactType +ccType = upd.ccType' + +-- | The id of the contact method. For 'SMS' and 'Phone' it is the number, and for +-- 'Email' it is the email address. +ccAddress :: Lens' (Request CreateContact s b) Address +ccAddress = upd.ccAddress' + +-- | The number code for your country. Not used for 'Email'. +-- +-- /Default:/ 1 +ccCountryCode :: Lens' (Request CreateContact s b) (Maybe Int) +ccCountryCode = upd.ccCountryCode' + +-- | A human friendly label for the contact method. +-- +-- /Example:/ "Home Phone", "Work Email", etc. +-- +-- /Default:/ The type of the contact method and the address (with country code +-- for phone numbers). +ccLabel :: Lens' (Request CreateContact s b) (Maybe Text) +ccLabel = upd.ccLabel' + +-- | 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. +-- +-- /Default:/ false. +ccSendShortEmail :: Lens' (Request CreateContact s b) (Maybe Bool) +ccSendShortEmail = upd.ccSendShortEmail'.mapping _B + +-- | Create a new contact method for a given user. A contact method can be one +-- of the following types: SMS, email, and phone. push_notification contact +-- methods cannot be created using this API, they are added automatically during +-- device registration. +-- +-- @POST \/users\/\:user_id\/contact_methods@ +-- +-- /Note:/ The contact info must be unique. +-- +-- /See:/ +createContact :: UserId + -> ContactType + -> Address + -> Request CreateContact s Contact +createContact u t a = + mk CreateContact + { _ccType' = t + , _ccAddress' = a + , _ccCountryCode' = Nothing + , _ccLabel' = Nothing + , _ccSendShortEmail' = Nothing + } & meth .~ POST + & path .~ contacts u + & unwrap .~ key "contact_method" + +data UpdateContact = UpdateContact + { _ucAddress' :: Maybe Address + , _ucCountryCode' :: Maybe Int + , _ucLabel' :: Maybe Text + , _ucSendShortEmail' :: Maybe Bool' + } deriving (Eq, Show) + +jsonRequest ''UpdateContact + +-- | The id of the contact method. For 'SMS' and 'Phone' it is the number, and for +-- 'Email' it is the email address. +ucAddress :: Lens' (Request UpdateContact s b) (Maybe Address) +ucAddress = upd.ucAddress' + +-- | The number code for your country. Not used for 'Email'. +-- +-- /Default:/ 1 +ucCountryCode :: Lens' (Request UpdateContact s b) (Maybe Int) +ucCountryCode = upd.ucCountryCode' + +-- | A human friendly label for the contact method. +-- +-- /Example:/ "Home Phone", "Work Email", etc. +-- +-- /Default:/ The type of the contact method and the address (with country code +-- for phone numbers). +ucLabel :: Lens' (Request UpdateContact s b) (Maybe Text) +ucLabel = upd.ucLabel' + +-- | 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. +-- +-- /Default:/ false. +ucSendShortEmail :: Lens' (Request UpdateContact s b) (Maybe Bool) +ucSendShortEmail = upd.ucSendShortEmail'.mapping _B + +-- | Update an existing contact method of a given user. Note that you cannot +-- change the type of an existing method. +-- +-- @PUT \/users\/\:user_id\/contact_methods\/\:id@ +-- +-- /See:/ +updateContact :: UserId -> ContactId -> Request UpdateContact s Contact +updateContact u c = + mk UpdateContact + { _ucAddress' = Nothing + , _ucCountryCode' = Nothing + , _ucLabel' = Nothing + , _ucSendShortEmail' = Nothing + } & meth .~ PUT + & path .~ contacts u % c + & unwrap .~ key "contact_method" + +-- | Remove a contact method and any corresponding notification rules. +-- +-- @DELETE \/users\/\:user_id\/contact_methods\/\:id@ +-- +-- /See:/ +deleteContact :: UserId -> ContactId -> Request Empty s Empty +deleteContact u c = empty & meth .~ DELETE & path .~ contacts u % c diff --git a/src/Network/PagerDuty/REST/Users/NotificationRules.hs b/src/Network/PagerDuty/REST/Users/NotificationRules.hs new file mode 100644 --- /dev/null +++ b/src/Network/PagerDuty/REST/Users/NotificationRules.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +-- Module : Network.PagerDuty.REST.Users.NotificationRules +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +-- | When a user is assigned an incident, the user's notification rules are +-- used to determine which contact method will be used to alert the user and how +-- long after the incident to do so. +-- +-- Access and manipulate the notification rules for a user. +-- +-- /See:/ +module Network.PagerDuty.REST.Users.NotificationRules + ( + -- * List Rules + listRules + + -- * Create Rule + , CreateRule + , createRule + , crStartDelayInMinutes + , crContactMethodId + + -- * Get Rule + , getRule + + -- * Update Rule + , UpdateRule + , updateRule + , urStartDelayInMinutes + , urContactMethodId + + -- * Delete Rule + , deleteRule + + -- * Types + , Rule + , rId + , rStartDelayInMinutes + , rContactMethod + ) where + +import Control.Lens +import Data.Aeson.Lens +import Network.HTTP.Types +import Network.PagerDuty.REST.Users.ContactMethods +import Network.PagerDuty.Internal.TH +import Network.PagerDuty.Internal.Types + +default (Path) + +rules :: UserId -> Path +rules u = "users" % u % "notification_rules" + +data Rule = Rule + { _rId :: NotificationRuleId + , _rStartDelayInMinutes :: !Int + , _rContactMethod :: Contact + } deriving (Eq, Show) + +deriveJSON ''Rule +makeLenses ''Rule + +instance HasContact Rule where + contact = rContactMethod + +-- | List existing notification rules for the specified user. +-- +-- @GET \/users\/\:user_id\/notification_rules@ +-- +-- /See:/ +listRules :: UserId -> Request Empty s Rule +listRules u = empty & path .~ rules u + +-- | Get details for a notification rule. +-- +-- @GET \/users\/\:user_id\/notification_rules\/\:id@ +-- +-- /See:/ +getRule :: UserId -> NotificationRuleId -> Request Empty s Rule +getRule u n = empty & path .~ rules u % n + +data CreateRule = CreateRule + { _crStartDelayInMinutes' :: !Int + , _crContactMethodId' :: ContactId + } deriving (Eq, Show) + +jsonRequest ''CreateRule + +-- | Number of minutes it will take for the notification rule to be activated +-- (from the time the incident is assigned to the owning user) and an alert be +-- fired. +crStartDelayInMinutes :: Lens' (Request CreateRule s b) Int +crStartDelayInMinutes = upd.crStartDelayInMinutes' + +-- | The id of the contact method. +crContactMethodId :: Lens' (Request CreateRule s b) ContactId +crContactMethodId = upd.crContactMethodId' + +-- | Create a new notification rule for the specified user. +-- +-- @POST \/users\/\:user_id\/notification_rules@ +-- +-- /See:/ +createRule :: UserId -> ContactId -> Int -> Request CreateRule s Rule +createRule u c n = + mk CreateRule + { _crStartDelayInMinutes' = n + , _crContactMethodId' = c + } & meth .~ POST + & path .~ rules u + & unwrap .~ key "notification_rule" + +data UpdateRule = UpdateRule + { _urStartDelayInMinutes' :: Maybe Int + , _urContactMethodId' :: Maybe ContactId + } deriving (Eq, Show) + +jsonRequest ''UpdateRule + +-- | Number of minutes it will take for the notification rule to be activated +-- (from the time the incident is assigned to the owning user) and an alert be +-- fired. +urStartDelayInMinutes :: Lens' (Request UpdateRule s b) (Maybe Int) +urStartDelayInMinutes = upd.urStartDelayInMinutes' + +-- | The id of the contact method. +urContactMethodId :: Lens' (Request UpdateRule s b) (Maybe ContactId) +urContactMethodId = upd.urContactMethodId' + +-- | Update an existing notification rule. +-- +-- @PUT \/users\/\:user_id\/notification_rules\/\:id@ +-- +-- /See:/ +updateRule :: UserId -> NotificationRuleId -> Request UpdateRule s Rule +updateRule u r = + mk UpdateRule + { _urStartDelayInMinutes' = Nothing + , _urContactMethodId' = Nothing + } & meth .~ PUT + & path .~ rules u % r + & unwrap .~ key "notification_rule" + +-- | Remove a notification rule. +-- +-- @DELETE \/users\/\:user_id\/notification_rules\/\:id@ +-- +-- /See:/ +deleteRule :: UserId + -> NotificationRuleId + -> Request Empty s Empty +deleteRule u n = empty & meth .~ DELETE & path .~ rules u % n diff --git a/src/Network/PagerDuty/REST/Webhooks.hs b/src/Network/PagerDuty/REST/Webhooks.hs new file mode 100644 --- /dev/null +++ b/src/Network/PagerDuty/REST/Webhooks.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- Module : Network.PagerDuty.REST.Webhooks +-- Copyright : (c) 2013-2014 Brendan Hay +-- License : This Source Code Form is subject to the terms of +-- the Mozilla Public License, v. 2.0. +-- A copy of the MPL can be found in the LICENSE file or +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +-- | Webhooks let you recieve HTTP callbacks when interesting events happen within +-- your PagerDuty account. Details surrounding the interesting event will be sent +-- via HTTP to a URL that you specify. +-- +-- PagerDuty currently supports incident-based webhooks. After adding a webhook +-- URL to a PagerDuty service, the triggering of new incidents on that service +-- will cause outgoing webhook messages to be sent to that URL. In addition, +-- certain interesting changes to an incident's state will cause other types of +-- incident webhook messages to be sent: Generally, any change to the @status@ or +-- @assigned_to_user@ of an incident will cause an outgoing message to be sent. +-- +-- /See:/ +module Network.PagerDuty.REST.Webhooks + ( WebhookType (..) + , Webhook + , wId + , wType + , wCreatedOn + ) where + +import Control.Applicative hiding (empty) +import Control.Lens +import Data.Aeson +import Data.ByteString.Conversion (ToByteString(..), toByteString') +import Data.Text (Text) +import qualified Data.Text.Encoding as Text +import Data.Time +import Network.PagerDuty.REST.Incidents +import Network.PagerDuty.Internal.TH +import Network.PagerDuty.Internal.Types + +data WebhookType + = WTrigger + -- ^ Sent when an incident is newly created/triggered. + | WAcknowledge + -- ^ Sent when an incident has had its status changed from triggered to + -- acknowledged. + | WUnacknowledge + -- ^ Sent when an incident is unacknowledged due to timeout. + | WResolve + -- ^ Sent when an incident has been resolved. + | WAssign + -- ^ Sent when an incident has been manually reassigned to another user + -- in a different escalation chain. + | WEscalate + -- ^ Sent when an incident has been escalated to another user in the + -- same escalation chain. + | WDelegate + -- ^ Sent when an incident has been reassigned to another escalation chain. + | WOther Text + -- ^ /Note:/ As new types of incident actions are supported, + -- new incident webhook message types will be added. + deriving (Eq, Show) + +instance ToByteString WebhookType where + builder = \case + WTrigger -> "incident.trigger" + WAcknowledge -> "incident.acknowledge" + WUnacknowledge -> "incident.unacknowledge" + WResolve -> "incident.resolve" + WAssign -> "incident.assign" + WEscalate -> "incident.escalate" + WDelegate -> "incident.delegate" + WOther t -> builder t + +instance FromJSON WebhookType where + parseJSON = withText "status" $ pure . \case + "incident.trigger" -> WTrigger + "incident.acknowledge" -> WAcknowledge + "incident.unacknowledge" -> WUnacknowledge + "incident.resolve" -> WResolve + "incident.assign" -> WAssign + "incident.escalate" -> WEscalate + "incident.delegate" -> WDelegate + t -> (WOther t) + +instance ToJSON WebhookType where + toJSON = String . Text.decodeUtf8 . toByteString' + +data Webhook = Webhook + { _wId :: WebhookId + , _wType :: !WebhookType + , _wCreatedOn :: !Date + , _wData :: Incident + } deriving (Eq, Show) + +deriveJSON ''Webhook + +instance HasIncident Webhook where + incident = lens _wData (\s x -> s { _wData = x }) + +-- | Uniquely identifies this outgoing webhook message; can be used for +-- idempotency when processing the messages. +makeLens "_wId" ''Webhook + +-- | The webhook message type. +makeLens "_wType" ''Webhook + +-- | The date/time when the incident changed state. +wCreatedOn :: Lens' Webhook UTCTime +wCreatedOn = lens _wCreatedOn (\i x -> i { _wCreatedOn = x }) . _D