{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Rollbar.Client.Deploy
  ( -- ** Requests
    Deploy(..)
  , mkDeploy
  , Status(..)
    -- ** Responses
  , DeployId(..)
    -- ** Endpoints
  , reportDeploy
  ) where

import qualified Data.Text as T

import Control.Monad.IO.Class (MonadIO(..))
import Data.Aeson
import Data.Text
import Network.HTTP.Req
import Rollbar.Client.Internal
import Rollbar.Client.Settings
import System.Environment (lookupEnv)

data Deploy = Deploy
  { Deploy -> Environment
deployEnvironment :: Environment
    -- ^ Environment to which the revision was deployed.
  , Deploy -> Revision
deployRevision :: Revision
    -- ^ Git SHA of revision being deployed.
  , Deploy -> Maybe Text
deployRollbarUsername :: Maybe Text
    -- ^ Rollbar username of person who deployed.
  , Deploy -> Maybe Text
deployLocalUsername :: Maybe Text
    -- ^ Local username of person who deployed. Displayed in web app if no
    -- 'deployRollbarUsername' was specified.
  , Deploy -> Maybe Text
deployComment :: Maybe Text
    -- ^ Additional text to include with the deploy.
  , Deploy -> Maybe Status
deployStatus :: Maybe Status
    -- ^ Status of the deployment.
  } deriving (Deploy -> Deploy -> Bool
(Deploy -> Deploy -> Bool)
-> (Deploy -> Deploy -> Bool) -> Eq Deploy
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Deploy -> Deploy -> Bool
== :: Deploy -> Deploy -> Bool
$c/= :: Deploy -> Deploy -> Bool
/= :: Deploy -> Deploy -> Bool
Eq, Int -> Deploy -> ShowS
[Deploy] -> ShowS
Deploy -> String
(Int -> Deploy -> ShowS)
-> (Deploy -> String) -> ([Deploy] -> ShowS) -> Show Deploy
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Deploy -> ShowS
showsPrec :: Int -> Deploy -> ShowS
$cshow :: Deploy -> String
show :: Deploy -> String
$cshowList :: [Deploy] -> ShowS
showList :: [Deploy] -> ShowS
Show)

instance ToJSON Deploy where
  toJSON :: Deploy -> Value
toJSON Deploy{Maybe Text
Maybe Status
Revision
Environment
deployEnvironment :: Deploy -> Environment
deployRevision :: Deploy -> Revision
deployRollbarUsername :: Deploy -> Maybe Text
deployLocalUsername :: Deploy -> Maybe Text
deployComment :: Deploy -> Maybe Text
deployStatus :: Deploy -> Maybe Status
deployEnvironment :: Environment
deployRevision :: Revision
deployRollbarUsername :: Maybe Text
deployLocalUsername :: Maybe Text
deployComment :: Maybe Text
deployStatus :: Maybe Status
..} = [Pair] -> Value
object
    [ Key
"environment" Key -> Environment -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Environment
deployEnvironment
    , Key
"revision" Key -> Revision -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Revision
deployRevision
    , Key
"rollbar_username" Key -> Maybe Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
deployRollbarUsername
    , Key
"local_username" Key -> Maybe Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
deployLocalUsername
    , Key
"comment" Key -> Maybe Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
deployComment
    , Key
"status" Key -> Maybe Status -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Maybe Status
deployStatus
    ]

-- | Builds a 'Deploy' based on a 'Revision'.
--
-- __Example__
--
-- > getRevision >>= mkDeploy
mkDeploy
  :: (HasSettings m, MonadIO m)
  => Revision
  -> m Deploy
mkDeploy :: forall (m :: * -> *).
(HasSettings m, MonadIO m) =>
Revision -> m Deploy
mkDeploy Revision
revision = do
  Environment
env <- Settings -> Environment
settingsEnvironment (Settings -> Environment) -> m Settings -> m Environment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Settings
forall (m :: * -> *). HasSettings m => m Settings
getSettings
  Maybe Text
muser <- (String -> Text) -> Maybe String -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
T.pack (Maybe String -> Maybe Text) -> m (Maybe String) -> m (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe String) -> m (Maybe String)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO (Maybe String)
lookupEnv String
"USER")
  Deploy -> m Deploy
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Deploy
    { deployEnvironment :: Environment
deployEnvironment = Environment
env
    , deployRevision :: Revision
deployRevision = Revision
revision
    , deployRollbarUsername :: Maybe Text
deployRollbarUsername = Maybe Text
forall a. Maybe a
Nothing
    , deployLocalUsername :: Maybe Text
deployLocalUsername = Maybe Text
muser
    , deployComment :: Maybe Text
deployComment = Maybe Text
forall a. Maybe a
Nothing
    , deployStatus :: Maybe Status
deployStatus = Status -> Maybe Status
forall a. a -> Maybe a
Just Status
StatusSucceeded
    }

-- | Status of the deployment.
data Status
  = StatusStarted
  | StatusSucceeded
  | StatusFailed
  | StatusTimedOut
  deriving (Status -> Status -> Bool
(Status -> Status -> Bool)
-> (Status -> Status -> Bool) -> Eq Status
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Status -> Status -> Bool
== :: Status -> Status -> Bool
$c/= :: Status -> Status -> Bool
/= :: Status -> Status -> Bool
Eq, Int -> Status -> ShowS
[Status] -> ShowS
Status -> String
(Int -> Status -> ShowS)
-> (Status -> String) -> ([Status] -> ShowS) -> Show Status
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Status -> ShowS
showsPrec :: Int -> Status -> ShowS
$cshow :: Status -> String
show :: Status -> String
$cshowList :: [Status] -> ShowS
showList :: [Status] -> ShowS
Show)

instance ToJSON Status where
  toJSON :: Status -> Value
toJSON Status
StatusStarted = Text -> Value
String Text
"started"
  toJSON Status
StatusSucceeded = Text -> Value
String Text
"succeeded"
  toJSON Status
StatusFailed = Text -> Value
String Text
"failed"
  toJSON Status
StatusTimedOut = Text -> Value
String Text
"timed_out"

newtype DeployId = DeployId Integer
  deriving (DeployId -> DeployId -> Bool
(DeployId -> DeployId -> Bool)
-> (DeployId -> DeployId -> Bool) -> Eq DeployId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DeployId -> DeployId -> Bool
== :: DeployId -> DeployId -> Bool
$c/= :: DeployId -> DeployId -> Bool
/= :: DeployId -> DeployId -> Bool
Eq, Integer -> DeployId
DeployId -> DeployId
DeployId -> DeployId -> DeployId
(DeployId -> DeployId -> DeployId)
-> (DeployId -> DeployId -> DeployId)
-> (DeployId -> DeployId -> DeployId)
-> (DeployId -> DeployId)
-> (DeployId -> DeployId)
-> (DeployId -> DeployId)
-> (Integer -> DeployId)
-> Num DeployId
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: DeployId -> DeployId -> DeployId
+ :: DeployId -> DeployId -> DeployId
$c- :: DeployId -> DeployId -> DeployId
- :: DeployId -> DeployId -> DeployId
$c* :: DeployId -> DeployId -> DeployId
* :: DeployId -> DeployId -> DeployId
$cnegate :: DeployId -> DeployId
negate :: DeployId -> DeployId
$cabs :: DeployId -> DeployId
abs :: DeployId -> DeployId
$csignum :: DeployId -> DeployId
signum :: DeployId -> DeployId
$cfromInteger :: Integer -> DeployId
fromInteger :: Integer -> DeployId
Num, Eq DeployId
Eq DeployId =>
(DeployId -> DeployId -> Ordering)
-> (DeployId -> DeployId -> Bool)
-> (DeployId -> DeployId -> Bool)
-> (DeployId -> DeployId -> Bool)
-> (DeployId -> DeployId -> Bool)
-> (DeployId -> DeployId -> DeployId)
-> (DeployId -> DeployId -> DeployId)
-> Ord DeployId
DeployId -> DeployId -> Bool
DeployId -> DeployId -> Ordering
DeployId -> DeployId -> DeployId
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: DeployId -> DeployId -> Ordering
compare :: DeployId -> DeployId -> Ordering
$c< :: DeployId -> DeployId -> Bool
< :: DeployId -> DeployId -> Bool
$c<= :: DeployId -> DeployId -> Bool
<= :: DeployId -> DeployId -> Bool
$c> :: DeployId -> DeployId -> Bool
> :: DeployId -> DeployId -> Bool
$c>= :: DeployId -> DeployId -> Bool
>= :: DeployId -> DeployId -> Bool
$cmax :: DeployId -> DeployId -> DeployId
max :: DeployId -> DeployId -> DeployId
$cmin :: DeployId -> DeployId -> DeployId
min :: DeployId -> DeployId -> DeployId
Ord, Int -> DeployId -> ShowS
[DeployId] -> ShowS
DeployId -> String
(Int -> DeployId -> ShowS)
-> (DeployId -> String) -> ([DeployId] -> ShowS) -> Show DeployId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DeployId -> ShowS
showsPrec :: Int -> DeployId -> ShowS
$cshow :: DeployId -> String
show :: DeployId -> String
$cshowList :: [DeployId] -> ShowS
showList :: [DeployId] -> ShowS
Show)

instance FromJSON DeployId where
  parseJSON :: Value -> Parser DeployId
parseJSON = String -> (Object -> Parser DeployId) -> Value -> Parser DeployId
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"DeployId" ((Object -> Parser DeployId) -> Value -> Parser DeployId)
-> (Object -> Parser DeployId) -> Value -> Parser DeployId
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    Integer -> DeployId
DeployId (Integer -> DeployId) -> Parser Integer -> Parser DeployId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Integer
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"deploy_id"

-- | Tracks a deploy in Rollbar.
--
-- __Example__
--
-- > settings <- readSettings "rollbar.yaml"
-- > runRollbar settings $ do
-- >   deploy <- getRevision >>= mkDeploy
-- >   reportDeploy deploy
--
-- __Reference__
--
-- <https://explorer.docs.rollbar.com/#operation/post-deploy>
reportDeploy
  :: (HasSettings m, MonadHttp m)
  => Deploy
  -> m DeployId
reportDeploy :: forall (m :: * -> *).
(HasSettings m, MonadHttp m) =>
Deploy -> m DeployId
reportDeploy Deploy
deploy =
  (JsonResponse (DataResponse DeployId) -> DeployId)
-> m (JsonResponse (DataResponse DeployId)) -> m DeployId
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
    (DataResponse DeployId -> DeployId
forall a. DataResponse a -> a
unDataResponse (DataResponse DeployId -> DeployId)
-> (JsonResponse (DataResponse DeployId) -> DataResponse DeployId)
-> JsonResponse (DataResponse DeployId)
-> DeployId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JsonResponse (DataResponse DeployId)
-> HttpResponseBody (JsonResponse (DataResponse DeployId))
JsonResponse (DataResponse DeployId) -> DataResponse DeployId
forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody)
    (POST
-> Url 'Https
-> ReqBodyJson Deploy
-> Proxy (JsonResponse (DataResponse DeployId))
-> m (JsonResponse (DataResponse DeployId))
forall (m :: * -> *) body method response.
(HasSettings m, HttpBody body,
 HttpBodyAllowed (AllowsBody method) (ProvidesBody body),
 HttpMethod method, HttpResponse response, MonadHttp m) =>
method -> Url 'Https -> body -> Proxy response -> m response
rollbar POST
POST Url 'Https
url (Deploy -> ReqBodyJson Deploy
forall a. a -> ReqBodyJson a
ReqBodyJson Deploy
deploy) Proxy (JsonResponse (DataResponse DeployId))
forall a. Proxy (JsonResponse a)
jsonResponse)
  where
    url :: Url 'Https
url = Url 'Https
baseUrl Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"deploy"