pagerduty-hs (empty) → 0.1.0.0

raw patch · 7 files changed

+263/−0 lines, 7 filesdep +HUnitdep +aesondep +basesetup-changed

Dependencies added: HUnit, aeson, base, exceptions, lens, pagerduty-hsl, tasty, tasty-hunit, tasty-quickcheck, text, wreq

Files

ChangeLog.md +3/−0
LICENSE +30/−0
README.md +4/−0
Setup.hs +2/−0
pagerduty-hs.cabal +71/−0
src/Network/API/PagerDuty/EventV1.hs +142/−0
test/Spec.hs +11/−0

+ ChangeLog.md view

@@ -0,0 +1,3 @@+# Changelog for pagerduty++## Unreleased changes

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Dustin Sallings (c) 2021++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Dustin Sallings nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ README.md view

@@ -0,0 +1,4 @@+# pagerduty++A Haskell interface for trigger, acknowledging, and resolving events+at [PagerDuty](https://www.pagerduty.com).

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ pagerduty-hs.cabal view

@@ -0,0 +1,71 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name:           pagerduty-hs+version:        0.1.0.0+description:    Please see the README on GitHub at <https://github.com/dustin/pagerduty#readme>+homepage:       https://github.com/dustin/pagerduty-hs#readme+bug-reports:    https://github.com/dustin/pagerduty-hs/issues+author:         Dustin Sallings+maintainer:     dustin@spy.net+copyright:      Copyright © 2021 Dustin Sallings+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/dustin/pagerduty-hs++library+  exposed-modules:+      Network.API.PagerDuty.EventV1+  other-modules:+      Paths_pagerduty_hs+  hs-source-dirs:+      src+  default-extensions:+      OverloadedStrings+      RecordWildCards+      NamedFieldPuns+  ghc-options: -Wall -O2+  build-depends:+      aeson+    , base >=4.7 && <5+    , exceptions+    , lens+    , text+    , wreq+  default-language: Haskell2010++test-suite pagerduty-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_pagerduty_hs+  hs-source-dirs:+      test+  default-extensions:+      OverloadedStrings+      RecordWildCards+      NamedFieldPuns+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      HUnit+    , aeson+    , base >=4.7 && <5+    , exceptions+    , lens+    , pagerduty-hsl+    , tasty+    , tasty-hunit+    , tasty-quickcheck+    , text+    , wreq+  default-language: Haskell2010

+ src/Network/API/PagerDuty/EventV1.hs view

@@ -0,0 +1,142 @@+{-|+Module      : Network.API.PagerDuty.EventV1+Description : PagerDuty Event V1 interface.+Copyright   : (c) Dustin Sallings, 2021+License     : BSD3+Maintainer  : dustin@spy.net+Stability   : experimental++PagerDuty Event V1 interface.+-}+{-# LANGUAGE TemplateHaskell #-}++module Network.API.PagerDuty.EventV1 (+  -- * Triggering an Event+  TriggerEvent(..), TriggerEvent',+  Context(..),+  -- * Updating an Event+  UpdateEvent(..), UpdateEvent', UpdateType(..),+  -- * Delivering Events to PagerDuty+  deliver, Response(..),+  -- * Lenses and Prisms+  _Link, _Image,+  teServiceKey, teIncidentKey, teDescription, teDetails, teClient, teClientURL, teContexts,+  _Acknowledge, _Resolve,+  updateType, updateServiceKey, updateIncidentKey, updateDescription, updateDetails+  ) where++import           Control.Lens           (makeLenses, makePrisms, view)+import           Control.Monad.Catch    (MonadCatch (..), SomeException (..), catch)+import           Control.Monad.IO.Class (MonadIO (..))+import           Data.Aeson             (FromJSON (..), ToJSON (..), Value (..), encode, object, (.:), (.=))+import           Data.Aeson.Types       (Pair, typeMismatch)+import           Data.Char              (toLower)+import           Data.Maybe             (mapMaybe)+import           Data.Text              (Text, pack)+import           Network.Wreq           (asJSON, post, responseBody)+import           Network.Wreq.Types     (Postable)++class (ToJSON j) => EventRequest j++-- | Context that may be added when creating an event.+data Context = Link Text (Maybe Text) -- ^ Link to a URL with an optional link description.+             | Image Text (Maybe Text) (Maybe Text) -- ^ Image URL, optional link ref, and optional alt text.+  deriving (Show, Eq)++makePrisms ''Context++optj :: ToJSON v => [(Text, Maybe v)] -> [Pair]+optj = mapMaybe (fmap (uncurry (.=)) . sequenceA)++instance ToJSON Context where+  toJSON (Link u t)      = object (["type" .= ("link" :: Text), "href" .= u] <> optj [("text", t)])+  toJSON (Image s mu mt) = object (["type" .= ("image" :: Text), "src" .= s] <> optj [("href", mu), ("alt", mt)])++-- | Request object to create an event.  Any value that may be+-- serialized to JSON maybe attached as details.+--+-- This may be delivered with the 'deliver' function.+data TriggerEvent a = TriggerEvent {+  _teServiceKey    :: Text+  , _teIncidentKey :: Maybe Text+  , _teDescription :: Text+  , _teDetails     :: Maybe a+  , _teClient      :: Text+  , _teClientURL   :: Text+  , _teContexts    :: [Context]+  }+  deriving (Show, Eq)++makeLenses ''TriggerEvent++instance ToJSON a => EventRequest (TriggerEvent a)++-- | A 'TriggerEvent' type that doesn't have details.+type TriggerEvent' = TriggerEvent ()++instance ToJSON a => ToJSON (TriggerEvent a) where+  toJSON TriggerEvent{..} = object ([+                                       "service_key" .= _teServiceKey+                                    , "event_type" .= ("trigger"::Text)+                                    , "description" .= _teDescription+                                    , "client" .= _teClient+                                    , "client_url" .= _teClientURL+                                    ] <> optj [("details", _teDetails)]+                                     <> optj [("incident_key", _teIncidentKey)]+                                     <> opta "contexts" _teContexts+                                   )+    where opta _ [] = []+          opta k vs = [k .= vs]++-- | An event update will either acknowledge or resolve an incident.+data UpdateType = Acknowledge | Resolve deriving (Show, Eq, Bounded, Enum)++makePrisms ''UpdateType++-- | UpdateEvent is the message for both acknowledging and resolving+-- incidents.  This may be delivered using the 'deliver' function.+data UpdateEvent a = UpdateEvent {+  _updateType          :: UpdateType+  , _updateServiceKey  :: Text+  , _updateIncidentKey :: Text+  , _updateDescription :: Text+  , _updateDetails     :: Maybe a+  }+  deriving (Show, Eq)++makeLenses ''UpdateEvent++instance ToJSON a => EventRequest (UpdateEvent a)++-- | A 'UpdateEvent' type that doesn't have details.+type UpdateEvent' = UpdateEvent ()++instance ToJSON a => ToJSON (UpdateEvent a) where+  toJSON UpdateEvent{..} = object ([+                                   "service_key" .= _updateServiceKey+                                , "event_type" .= (map toLower . show) _updateType+                                , "incident_key" .= _updateIncidentKey+                                , "description" .= _updateDescription+                                ] <> optj [("details", _updateDetails)])++-- | Response to a delivered message.+data Response = Failure Text Text -- ^ Failure status and message+              | Success Text      -- ^ Success and incident key for further updates+  deriving (Show, Eq)++instance FromJSON Response where+  parseJSON (Object v) = subparse =<< v .: "status"+      where+        subparse "success" = Success <$> v .: "incident_key"+        subparse e         = Failure e <$> v .: "message"+  parseJSON invalid = typeMismatch "Response" invalid++jpost :: (MonadIO m, Postable a, FromJSON r) => String -> a -> m r+jpost u v = view responseBody <$> liftIO (post u v >>= asJSON)++-- | Deliver a 'TriggerEvent' or 'UpdateEvent'.+deliver :: (EventRequest r, MonadCatch m, MonadIO m) => r -> m Response+deliver r = send r `catch` failed+  where+    send = jpost "https://events.pagerduty.com/generic/2010-04-15/create_event.json" . encode+    failed (SomeException e) = pure $ Failure "http exception" (pack (show e))

+ test/Spec.hs view

@@ -0,0 +1,11 @@+import           Test.Tasty+import           Test.Tasty.HUnit+import           Test.Tasty.QuickCheck as QC++tests :: [TestTree]+tests = [+    testProperty "a test property" (\x -> (x::Int) == id x)+    ]++main :: IO ()+main = defaultMain $ testGroup "All Tests" tests