{-|
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.
-}

module Network.API.PagerDuty.EventV1 (
  -- * Triggering an Event
  TriggerEvent(..), TriggerEvent',
  Context(..),
  -- * Updating an Event
  UpdateEvent(..), UpdateEvent', UpdateType(..),
  -- * Delivering Events to PagerDuty
  deliver, Response(..)
  ) where

import           Control.Lens           (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       (Key, 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 (Int -> Context -> ShowS
[Context] -> ShowS
Context -> String
(Int -> Context -> ShowS)
-> (Context -> String) -> ([Context] -> ShowS) -> Show Context
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Context -> ShowS
showsPrec :: Int -> Context -> ShowS
$cshow :: Context -> String
show :: Context -> String
$cshowList :: [Context] -> ShowS
showList :: [Context] -> ShowS
Show, Context -> Context -> Bool
(Context -> Context -> Bool)
-> (Context -> Context -> Bool) -> Eq Context
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Context -> Context -> Bool
== :: Context -> Context -> Bool
$c/= :: Context -> Context -> Bool
/= :: Context -> Context -> Bool
Eq)

optj :: ToJSON v => [(Key, Maybe v)] -> [Pair]
optj :: forall v. ToJSON v => [(Key, Maybe v)] -> [Pair]
optj = ((Key, Maybe v) -> Maybe Pair) -> [(Key, Maybe v)] -> [Pair]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (((Key, v) -> Pair) -> Maybe (Key, v) -> Maybe Pair
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Key -> v -> Pair) -> (Key, v) -> Pair
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Key -> v -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
(.=)) (Maybe (Key, v) -> Maybe Pair)
-> ((Key, Maybe v) -> Maybe (Key, v))
-> (Key, Maybe v)
-> Maybe Pair
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key, Maybe v) -> Maybe (Key, v)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => (Key, f a) -> f (Key, a)
sequenceA)

instance ToJSON Context where
  toJSON :: Context -> Value
toJSON (Link Text
u Maybe Text
t)      = [Pair] -> Value
object ([Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"link" :: Text), Key
"href" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
u] [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> [(Key, Maybe Text)] -> [Pair]
forall v. ToJSON v => [(Key, Maybe v)] -> [Pair]
optj [(Key
"text", Maybe Text
t)])
  toJSON (Image Text
s Maybe Text
mu Maybe Text
mt) = [Pair] -> Value
object ([Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"image" :: Text), Key
"src" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
s] [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> [(Key, Maybe Text)] -> [Pair]
forall v. ToJSON v => [(Key, Maybe v)] -> [Pair]
optj [(Key
"href", Maybe Text
mu), (Key
"alt", Maybe Text
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 {
  forall a. TriggerEvent a -> Text
_teServiceKey    :: Text
  , forall a. TriggerEvent a -> Maybe Text
_teIncidentKey :: Maybe Text
  , forall a. TriggerEvent a -> Text
_teDescription :: Text
  , forall a. TriggerEvent a -> Maybe a
_teDetails     :: Maybe a
  , forall a. TriggerEvent a -> Text
_teClient      :: Text
  , forall a. TriggerEvent a -> Text
_teClientURL   :: Text
  , forall a. TriggerEvent a -> [Context]
_teContexts    :: [Context]
  }
  deriving (Int -> TriggerEvent a -> ShowS
[TriggerEvent a] -> ShowS
TriggerEvent a -> String
(Int -> TriggerEvent a -> ShowS)
-> (TriggerEvent a -> String)
-> ([TriggerEvent a] -> ShowS)
-> Show (TriggerEvent a)
forall a. Show a => Int -> TriggerEvent a -> ShowS
forall a. Show a => [TriggerEvent a] -> ShowS
forall a. Show a => TriggerEvent a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> TriggerEvent a -> ShowS
showsPrec :: Int -> TriggerEvent a -> ShowS
$cshow :: forall a. Show a => TriggerEvent a -> String
show :: TriggerEvent a -> String
$cshowList :: forall a. Show a => [TriggerEvent a] -> ShowS
showList :: [TriggerEvent a] -> ShowS
Show, TriggerEvent a -> TriggerEvent a -> Bool
(TriggerEvent a -> TriggerEvent a -> Bool)
-> (TriggerEvent a -> TriggerEvent a -> Bool)
-> Eq (TriggerEvent a)
forall a. Eq a => TriggerEvent a -> TriggerEvent a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => TriggerEvent a -> TriggerEvent a -> Bool
== :: TriggerEvent a -> TriggerEvent a -> Bool
$c/= :: forall a. Eq a => TriggerEvent a -> TriggerEvent a -> Bool
/= :: TriggerEvent a -> TriggerEvent a -> Bool
Eq)

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 a -> Value
toJSON TriggerEvent{[Context]
Maybe a
Maybe Text
Text
_teServiceKey :: forall a. TriggerEvent a -> Text
_teIncidentKey :: forall a. TriggerEvent a -> Maybe Text
_teDescription :: forall a. TriggerEvent a -> Text
_teDetails :: forall a. TriggerEvent a -> Maybe a
_teClient :: forall a. TriggerEvent a -> Text
_teClientURL :: forall a. TriggerEvent a -> Text
_teContexts :: forall a. TriggerEvent a -> [Context]
_teServiceKey :: Text
_teIncidentKey :: Maybe Text
_teDescription :: Text
_teDetails :: Maybe a
_teClient :: Text
_teClientURL :: Text
_teContexts :: [Context]
..} = [Pair] -> Value
object ([
                                       Key
"service_key" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
_teServiceKey
                                    , Key
"event_type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"trigger"::Text)
                                    , Key
"description" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
_teDescription
                                    , Key
"client" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
_teClient
                                    , Key
"client_url" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
_teClientURL
                                    ] [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> [(Key, Maybe a)] -> [Pair]
forall v. ToJSON v => [(Key, Maybe v)] -> [Pair]
optj [(Key
"details", Maybe a
_teDetails)]
                                     [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> [(Key, Maybe Text)] -> [Pair]
forall v. ToJSON v => [(Key, Maybe v)] -> [Pair]
optj [(Key
"incident_key", Maybe Text
_teIncidentKey)]
                                     [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> Key -> [Context] -> [Pair]
forall {e} {a} {a}. (KeyValue e a, ToJSON a) => Key -> [a] -> [a]
opta Key
"contexts" [Context]
_teContexts
                                   )
    where opta :: Key -> [a] -> [a]
opta Key
_ [] = []
          opta Key
k [a]
vs = [Key
k Key -> [a] -> a
forall v. ToJSON v => Key -> v -> a
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [a]
vs]

-- | An event update will either acknowledge or resolve an incident.
data UpdateType = Acknowledge | Resolve deriving (Int -> UpdateType -> ShowS
[UpdateType] -> ShowS
UpdateType -> String
(Int -> UpdateType -> ShowS)
-> (UpdateType -> String)
-> ([UpdateType] -> ShowS)
-> Show UpdateType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UpdateType -> ShowS
showsPrec :: Int -> UpdateType -> ShowS
$cshow :: UpdateType -> String
show :: UpdateType -> String
$cshowList :: [UpdateType] -> ShowS
showList :: [UpdateType] -> ShowS
Show, UpdateType -> UpdateType -> Bool
(UpdateType -> UpdateType -> Bool)
-> (UpdateType -> UpdateType -> Bool) -> Eq UpdateType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UpdateType -> UpdateType -> Bool
== :: UpdateType -> UpdateType -> Bool
$c/= :: UpdateType -> UpdateType -> Bool
/= :: UpdateType -> UpdateType -> Bool
Eq, UpdateType
UpdateType -> UpdateType -> Bounded UpdateType
forall a. a -> a -> Bounded a
$cminBound :: UpdateType
minBound :: UpdateType
$cmaxBound :: UpdateType
maxBound :: UpdateType
Bounded, Int -> UpdateType
UpdateType -> Int
UpdateType -> [UpdateType]
UpdateType -> UpdateType
UpdateType -> UpdateType -> [UpdateType]
UpdateType -> UpdateType -> UpdateType -> [UpdateType]
(UpdateType -> UpdateType)
-> (UpdateType -> UpdateType)
-> (Int -> UpdateType)
-> (UpdateType -> Int)
-> (UpdateType -> [UpdateType])
-> (UpdateType -> UpdateType -> [UpdateType])
-> (UpdateType -> UpdateType -> [UpdateType])
-> (UpdateType -> UpdateType -> UpdateType -> [UpdateType])
-> Enum UpdateType
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: UpdateType -> UpdateType
succ :: UpdateType -> UpdateType
$cpred :: UpdateType -> UpdateType
pred :: UpdateType -> UpdateType
$ctoEnum :: Int -> UpdateType
toEnum :: Int -> UpdateType
$cfromEnum :: UpdateType -> Int
fromEnum :: UpdateType -> Int
$cenumFrom :: UpdateType -> [UpdateType]
enumFrom :: UpdateType -> [UpdateType]
$cenumFromThen :: UpdateType -> UpdateType -> [UpdateType]
enumFromThen :: UpdateType -> UpdateType -> [UpdateType]
$cenumFromTo :: UpdateType -> UpdateType -> [UpdateType]
enumFromTo :: UpdateType -> UpdateType -> [UpdateType]
$cenumFromThenTo :: UpdateType -> UpdateType -> UpdateType -> [UpdateType]
enumFromThenTo :: UpdateType -> UpdateType -> UpdateType -> [UpdateType]
Enum)

-- | UpdateEvent is the message for both acknowledging and resolving
-- incidents.  This may be delivered using the 'deliver' function.
data UpdateEvent a = UpdateEvent {
  forall a. UpdateEvent a -> UpdateType
_updateType          :: UpdateType
  , forall a. UpdateEvent a -> Text
_updateServiceKey  :: Text
  , forall a. UpdateEvent a -> Text
_updateIncidentKey :: Text
  , forall a. UpdateEvent a -> Text
_updateDescription :: Text
  , forall a. UpdateEvent a -> Maybe a
_updateDetails     :: Maybe a
  }
  deriving (Int -> UpdateEvent a -> ShowS
[UpdateEvent a] -> ShowS
UpdateEvent a -> String
(Int -> UpdateEvent a -> ShowS)
-> (UpdateEvent a -> String)
-> ([UpdateEvent a] -> ShowS)
-> Show (UpdateEvent a)
forall a. Show a => Int -> UpdateEvent a -> ShowS
forall a. Show a => [UpdateEvent a] -> ShowS
forall a. Show a => UpdateEvent a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> UpdateEvent a -> ShowS
showsPrec :: Int -> UpdateEvent a -> ShowS
$cshow :: forall a. Show a => UpdateEvent a -> String
show :: UpdateEvent a -> String
$cshowList :: forall a. Show a => [UpdateEvent a] -> ShowS
showList :: [UpdateEvent a] -> ShowS
Show, UpdateEvent a -> UpdateEvent a -> Bool
(UpdateEvent a -> UpdateEvent a -> Bool)
-> (UpdateEvent a -> UpdateEvent a -> Bool) -> Eq (UpdateEvent a)
forall a. Eq a => UpdateEvent a -> UpdateEvent a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => UpdateEvent a -> UpdateEvent a -> Bool
== :: UpdateEvent a -> UpdateEvent a -> Bool
$c/= :: forall a. Eq a => UpdateEvent a -> UpdateEvent a -> Bool
/= :: UpdateEvent a -> UpdateEvent a -> Bool
Eq)

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 a -> Value
toJSON UpdateEvent{Maybe a
Text
UpdateType
_updateType :: forall a. UpdateEvent a -> UpdateType
_updateServiceKey :: forall a. UpdateEvent a -> Text
_updateIncidentKey :: forall a. UpdateEvent a -> Text
_updateDescription :: forall a. UpdateEvent a -> Text
_updateDetails :: forall a. UpdateEvent a -> Maybe a
_updateType :: UpdateType
_updateServiceKey :: Text
_updateIncidentKey :: Text
_updateDescription :: Text
_updateDetails :: Maybe a
..} = [Pair] -> Value
object ([
                                   Key
"service_key" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
_updateServiceKey
                                , Key
"event_type" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower ShowS -> (UpdateType -> String) -> UpdateType -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UpdateType -> String
forall a. Show a => a -> String
show) UpdateType
_updateType
                                , Key
"incident_key" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
_updateIncidentKey
                                , Key
"description" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
_updateDescription
                                ] [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<> [(Key, Maybe a)] -> [Pair]
forall v. ToJSON v => [(Key, Maybe v)] -> [Pair]
optj [(Key
"details", Maybe a
_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 (Int -> Response -> ShowS
[Response] -> ShowS
Response -> String
(Int -> Response -> ShowS)
-> (Response -> String) -> ([Response] -> ShowS) -> Show Response
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Response -> ShowS
showsPrec :: Int -> Response -> ShowS
$cshow :: Response -> String
show :: Response -> String
$cshowList :: [Response] -> ShowS
showList :: [Response] -> ShowS
Show, Response -> Response -> Bool
(Response -> Response -> Bool)
-> (Response -> Response -> Bool) -> Eq Response
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Response -> Response -> Bool
== :: Response -> Response -> Bool
$c/= :: Response -> Response -> Bool
/= :: Response -> Response -> Bool
Eq)

instance FromJSON Response where
  parseJSON :: Value -> Parser Response
parseJSON (Object Object
v) = Text -> Parser Response
subparse (Text -> Parser Response) -> Parser Text -> Parser Response
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Object
v Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"status"
      where
        subparse :: Text -> Parser Response
subparse Text
"success" = Text -> Response
Success (Text -> Response) -> Parser Text -> Parser Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"incident_key"
        subparse Text
e         = Text -> Text -> Response
Failure Text
e (Text -> Response) -> Parser Text -> Parser Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"message"
  parseJSON Value
invalid = String -> Value -> Parser Response
forall a. String -> Value -> Parser a
typeMismatch String
"Response" Value
invalid

jpost :: (MonadIO m, Postable a, FromJSON r) => String -> a -> m r
jpost :: forall (m :: * -> *) a r.
(MonadIO m, Postable a, FromJSON r) =>
String -> a -> m r
jpost String
u a
v = Getting r (Response r) r -> Response r -> r
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting r (Response r) r
forall body0 body1 (f :: * -> *).
Functor f =>
(body0 -> f body1) -> Response body0 -> f (Response body1)
responseBody (Response r -> r) -> m (Response r) -> m r
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Response r) -> m (Response r)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> a -> IO (Response ByteString)
forall a. Postable a => String -> a -> IO (Response ByteString)
post String
u a
v IO (Response ByteString)
-> (Response ByteString -> IO (Response r)) -> IO (Response r)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Response ByteString -> IO (Response r)
forall (m :: * -> *) a.
(MonadThrow m, FromJSON a) =>
Response ByteString -> m (Response a)
asJSON)

-- | Deliver a 'TriggerEvent' or 'UpdateEvent'.
deliver :: (EventRequest r, MonadCatch m, MonadIO m) => r -> m Response
deliver :: forall r (m :: * -> *).
(EventRequest r, MonadCatch m, MonadIO m) =>
r -> m Response
deliver r
r = r -> m Response
send r
r m Response -> (SomeException -> m Response) -> m Response
forall e a. (HasCallStack, Exception e) => m a -> (e -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
`catch` SomeException -> m Response
forall {f :: * -> *}. Applicative f => SomeException -> f Response
failed
  where
    send :: r -> m Response
send = String -> ByteString -> m Response
forall (m :: * -> *) a r.
(MonadIO m, Postable a, FromJSON r) =>
String -> a -> m r
jpost String
"https://events.pagerduty.com/generic/2010-04-15/create_event.json" (ByteString -> m Response) -> (r -> ByteString) -> r -> m Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> ByteString
forall a. ToJSON a => a -> ByteString
encode
    failed :: SomeException -> f Response
failed (SomeException e
e) = Response -> f Response
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response -> f Response) -> Response -> f Response
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Response
Failure Text
"http exception" (String -> Text
pack (e -> String
forall a. Show a => a -> String
show e
e))