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

instance ToJSON Deploy where
  toJSON :: Deploy -> Value
toJSON Deploy{Maybe Text
Maybe Status
Revision
Environment
deployStatus :: Maybe Status
deployComment :: Maybe Text
deployLocalUsername :: Maybe Text
deployRollbarUsername :: Maybe Text
deployRevision :: Revision
deployEnvironment :: Environment
deployStatus :: Deploy -> Maybe Status
deployComment :: Deploy -> Maybe Text
deployLocalUsername :: Deploy -> Maybe Text
deployRollbarUsername :: Deploy -> Maybe Text
deployRevision :: Deploy -> Revision
deployEnvironment :: Deploy -> Environment
..} = [Pair] -> Value
object
    [ Key
"environment" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Environment
deployEnvironment
    , Key
"revision" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Revision
deployRevision
    , Key
"rollbar_username" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
deployRollbarUsername
    , Key
"local_username" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
deployLocalUsername
    , Key
"comment" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
deployComment
    , Key
"status" forall kv v. (KeyValue 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasSettings m => m Settings
getSettings
  Maybe Text
muser <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO (Maybe String)
lookupEnv String
"USER")
  forall (m :: * -> *) a. Monad m => a -> m a
return Deploy
    { deployEnvironment :: Environment
deployEnvironment = Environment
env
    , deployRevision :: Revision
deployRevision = Revision
revision
    , deployRollbarUsername :: Maybe Text
deployRollbarUsername = forall a. Maybe a
Nothing
    , deployLocalUsername :: Maybe Text
deployLocalUsername = Maybe Text
muser
    , deployComment :: Maybe Text
deployComment = forall a. Maybe a
Nothing
    , deployStatus :: Maybe Status
deployStatus = forall a. a -> Maybe a
Just Status
StatusSucceeded
    }

-- | Status of the deployment.
data Status
  = StatusStarted
  | StatusSucceeded
  | StatusFailed
  | StatusTimedOut
  deriving (Status -> Status -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Status -> Status -> Bool
$c/= :: Status -> Status -> Bool
== :: Status -> Status -> Bool
$c== :: Status -> Status -> Bool
Eq, Int -> Status -> ShowS
[Status] -> ShowS
Status -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Status] -> ShowS
$cshowList :: [Status] -> ShowS
show :: Status -> String
$cshow :: Status -> String
showsPrec :: Int -> Status -> ShowS
$cshowsPrec :: Int -> 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DeployId -> DeployId -> Bool
$c/= :: DeployId -> DeployId -> Bool
== :: DeployId -> DeployId -> Bool
$c== :: DeployId -> DeployId -> Bool
Eq, Integer -> DeployId
DeployId -> DeployId
DeployId -> DeployId -> DeployId
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> DeployId
$cfromInteger :: Integer -> DeployId
signum :: DeployId -> DeployId
$csignum :: DeployId -> DeployId
abs :: DeployId -> DeployId
$cabs :: DeployId -> DeployId
negate :: DeployId -> DeployId
$cnegate :: DeployId -> DeployId
* :: DeployId -> DeployId -> DeployId
$c* :: DeployId -> DeployId -> DeployId
- :: DeployId -> DeployId -> DeployId
$c- :: DeployId -> DeployId -> DeployId
+ :: DeployId -> DeployId -> DeployId
$c+ :: DeployId -> DeployId -> DeployId
Num, Eq 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
min :: DeployId -> DeployId -> DeployId
$cmin :: DeployId -> DeployId -> DeployId
max :: DeployId -> DeployId -> DeployId
$cmax :: DeployId -> DeployId -> DeployId
>= :: DeployId -> DeployId -> Bool
$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
compare :: DeployId -> DeployId -> Ordering
$ccompare :: DeployId -> DeployId -> Ordering
Ord, Int -> DeployId -> ShowS
[DeployId] -> ShowS
DeployId -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DeployId] -> ShowS
$cshowList :: [DeployId] -> ShowS
show :: DeployId -> String
$cshow :: DeployId -> String
showsPrec :: Int -> DeployId -> ShowS
$cshowsPrec :: Int -> DeployId -> ShowS
Show)

instance FromJSON DeployId where
  parseJSON :: Value -> Parser DeployId
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"DeployId" forall a b. (a -> b) -> a -> b
$ \Object
o ->
    Integer -> DeployId
DeployId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o 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 =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
    (forall a. DataResponse a -> a
unDataResponse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody)
    (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 (forall a. a -> ReqBodyJson a
ReqBodyJson Deploy
deploy) forall a. Proxy (JsonResponse a)
jsonResponse)
  where
    url :: Url 'Https
url = Url 'Https
baseUrl forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"deploy"