{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -O0 #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Hercules.CLI.Client where

-- TODO https://github.com/haskell-servant/servant/issues/986

import Data.Has (Has, getter)
import qualified Data.Text as T
import Hercules.API (ClientAPI (..), ClientAuth, servantClientApi, useApi)
import Hercules.API.Accounts (AccountsAPI)
import Hercules.API.Projects (ProjectsAPI)
import Hercules.API.Repos (ReposAPI)
import Hercules.API.State (ContentDisposition, ContentLength, RawBytes, StateAPI)
import Hercules.Error
import qualified Network.HTTP.Client.TLS
import Network.HTTP.Types.Status
import Protolude
import RIO (RIO)
import Servant.API
import Servant.Auth.Client (Token)
import qualified Servant.Client
import Servant.Client.Core (ClientError, ResponseF)
import qualified Servant.Client.Core as Client
import qualified Servant.Client.Core.ClientError as ClientError
import Servant.Client.Generic (AsClientT)
import Servant.Client.Streaming (ClientM, responseStatusCode, showBaseUrl)
import qualified Servant.Client.Streaming
import qualified System.Environment

-- | Bad instance to make it the client for State api compile. GHC seems to pick
-- the wrong overlappable instance.
instance
  FromSourceIO
    RawBytes
    ( Headers
        '[ContentLength, ContentDisposition]
        (SourceIO RawBytes)
    )
  where
  fromSourceIO :: SourceIO RawBytes
-> Headers '[ContentLength, ContentDisposition] (SourceIO RawBytes)
fromSourceIO = forall (h :: Symbol) v orig new.
AddHeader h v orig new =>
v -> orig -> new
addHeader (-Integer
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (h :: Symbol) v orig new.
AddHeader h v orig new =>
v -> orig -> new
addHeader Text
"" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall chunk a. FromSourceIO chunk a => SourceIO chunk -> a
fromSourceIO

client :: ClientAPI ClientAuth (AsClientT ClientM)
client :: ClientAPI ClientAuth (AsClientT ClientM)
client = forall (routes :: * -> *) mode.
GenericServant routes mode =>
ToServant routes mode -> routes mode
fromServant forall a b. (a -> b) -> a -> b
$ forall api.
HasClient ClientM api =>
Proxy api -> Client ClientM api
Servant.Client.Streaming.client (forall auth. Proxy (ClientServantAPI auth)
servantClientApi @ClientAuth)

accountsClient :: AccountsAPI ClientAuth (AsClientT ClientM)
accountsClient :: AccountsAPI ClientAuth (AsClientT ClientM)
accountsClient = forall (subapi :: * -> *) (api :: * -> *) mode.
(GenericServant api mode, GenericServant subapi mode) =>
(api mode -> ToServant subapi mode) -> api mode -> subapi mode
useApi forall auth f.
ClientAPI auth f -> f :- ToServantApi (AccountsAPI auth)
clientAccounts ClientAPI ClientAuth (AsClientT ClientM)
client

stateClient :: StateAPI ClientAuth (AsClientT ClientM)
stateClient :: StateAPI ClientAuth (AsClientT ClientM)
stateClient = forall (subapi :: * -> *) (api :: * -> *) mode.
(GenericServant api mode, GenericServant subapi mode) =>
(api mode -> ToServant subapi mode) -> api mode -> subapi mode
useApi forall auth f.
ClientAPI auth f -> f :- ToServantApi (StateAPI auth)
clientState ClientAPI ClientAuth (AsClientT ClientM)
client

projectsClient :: ProjectsAPI ClientAuth (AsClientT ClientM)
projectsClient :: ProjectsAPI ClientAuth (AsClientT ClientM)
projectsClient = forall (subapi :: * -> *) (api :: * -> *) mode.
(GenericServant api mode, GenericServant subapi mode) =>
(api mode -> ToServant subapi mode) -> api mode -> subapi mode
useApi forall auth f.
ClientAPI auth f -> f :- ToServantApi (ProjectsAPI auth)
clientProjects ClientAPI ClientAuth (AsClientT ClientM)
client

reposClient :: ReposAPI ClientAuth (AsClientT ClientM)
reposClient :: ReposAPI ClientAuth (AsClientT ClientM)
reposClient = forall (subapi :: * -> *) (api :: * -> *) mode.
(GenericServant api mode, GenericServant subapi mode) =>
(api mode -> ToServant subapi mode) -> api mode -> subapi mode
useApi forall auth f.
ClientAPI auth f -> f :- ToServantApi (ReposAPI auth)
clientRepos ClientAPI ClientAuth (AsClientT ClientM)
client

-- Duplicated from agent... create common lib?
determineDefaultApiBaseUrl :: IO Text
determineDefaultApiBaseUrl :: IO Text
determineDefaultApiBaseUrl = do
  Maybe String
maybeEnv <- String -> IO (Maybe String)
System.Environment.lookupEnv String
"HERCULES_CI_API_BASE_URL"
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
defaultApiBaseUrl forall a b. ConvertText a b => a -> b
toS Maybe String
maybeEnv

defaultApiBaseUrl :: Text
defaultApiBaseUrl :: Text
defaultApiBaseUrl = Text
"https://hercules-ci.com"

newtype HerculesClientEnv = HerculesClientEnv Servant.Client.ClientEnv

newtype HerculesClientToken = HerculesClientToken Token

runHerculesClient :: (NFData a, Has HerculesClientToken r, Has HerculesClientEnv r) => (Token -> Servant.Client.Streaming.ClientM a) -> RIO r a
runHerculesClient :: forall a r.
(NFData a, Has HerculesClientToken r, Has HerculesClientEnv r) =>
(Token -> ClientM a) -> RIO r a
runHerculesClient Token -> ClientM a
f = do
  HerculesClientToken Token
token <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a t. Has a t => t -> a
getter
  forall a r.
(NFData a, Has HerculesClientEnv r) =>
ClientM a -> RIO r a
runHerculesClient' forall a b. (a -> b) -> a -> b
$ Token -> ClientM a
f Token
token

runHerculesClientEither :: (NFData a, Has HerculesClientToken r, Has HerculesClientEnv r) => (Token -> Servant.Client.Streaming.ClientM a) -> RIO r (Either Servant.Client.Streaming.ClientError a)
runHerculesClientEither :: forall a r.
(NFData a, Has HerculesClientToken r, Has HerculesClientEnv r) =>
(Token -> ClientM a) -> RIO r (Either ClientError a)
runHerculesClientEither Token -> ClientM a
f = do
  HerculesClientToken Token
token <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a t. Has a t => t -> a
getter
  forall a r.
(NFData a, Has HerculesClientEnv r) =>
ClientM a -> RIO r (Either ClientError a)
runHerculesClientEither' forall a b. (a -> b) -> a -> b
$ Token -> ClientM a
f Token
token

runHerculesClientStream ::
  (Has HerculesClientToken r, Has HerculesClientEnv r) =>
  (Token -> Servant.Client.Streaming.ClientM a) ->
  (Either Servant.Client.Streaming.ClientError a -> IO b) ->
  RIO r b
runHerculesClientStream :: forall r a b.
(Has HerculesClientToken r, Has HerculesClientEnv r) =>
(Token -> ClientM a) -> (Either ClientError a -> IO b) -> RIO r b
runHerculesClientStream Token -> ClientM a
f Either ClientError a -> IO b
g = do
  HerculesClientToken Token
token <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a t. Has a t => t -> a
getter
  HerculesClientEnv ClientEnv
clientEnv <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a t. Has a t => t -> a
getter
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b.
ClientM a -> ClientEnv -> (Either ClientError a -> IO b) -> IO b
Servant.Client.Streaming.withClientM (Token -> ClientM a
f Token
token) ClientEnv
clientEnv Either ClientError a -> IO b
g

runHerculesClient' :: (NFData a, Has HerculesClientEnv r) => Servant.Client.Streaming.ClientM a -> RIO r a
runHerculesClient' :: forall a r.
(NFData a, Has HerculesClientEnv r) =>
ClientM a -> RIO r a
runHerculesClient' = forall a r.
(NFData a, Has HerculesClientEnv r) =>
ClientM a -> RIO r (Either ClientError a)
runHerculesClientEither' forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall exc (m :: * -> *) a.
(Exception exc, MonadThrow m) =>
Either exc a -> m a
escalate

runHerculesClientEither' :: (NFData a, Has HerculesClientEnv r) => Servant.Client.Streaming.ClientM a -> RIO r (Either Servant.Client.Streaming.ClientError a)
runHerculesClientEither' :: forall a r.
(NFData a, Has HerculesClientEnv r) =>
ClientM a -> RIO r (Either ClientError a)
runHerculesClientEither' ClientM a
m = do
  HerculesClientEnv ClientEnv
clientEnv <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a t. Has a t => t -> a
getter
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a.
NFData a =>
ClientM a -> ClientEnv -> IO (Either ClientError a)
Servant.Client.Streaming.runClientM ClientM a
m ClientEnv
clientEnv)

init :: IO HerculesClientEnv
init :: IO HerculesClientEnv
init = do
  Manager
manager <- forall (m :: * -> *). MonadIO m => m Manager
Network.HTTP.Client.TLS.newTlsManager
  Text
baseUrlText <- IO Text
determineDefaultApiBaseUrl
  BaseUrl
baseUrl <- forall (m :: * -> *). MonadThrow m => String -> m BaseUrl
Servant.Client.parseBaseUrl forall a b. (a -> b) -> a -> b
$ forall a b. ConvertText a b => a -> b
toS Text
baseUrlText
  let clientEnv :: Servant.Client.ClientEnv
      clientEnv :: ClientEnv
clientEnv = Manager -> BaseUrl -> ClientEnv
Servant.Client.mkClientEnv Manager
manager BaseUrl
baseUrl
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ClientEnv -> HerculesClientEnv
HerculesClientEnv ClientEnv
clientEnv

dieWithHttpError :: Client.ClientError -> IO a
dieWithHttpError :: forall a. ClientError -> IO a
dieWithHttpError (Client.FailureResponse RequestF () (BaseUrl, ByteString)
req Response
resp) = do
  let status :: Status
status = forall a. ResponseF a -> Status
responseStatusCode Response
resp
      (BaseUrl
base, ByteString
path) = forall body path. RequestF body path -> path
Client.requestPath RequestF () (BaseUrl, ByteString)
req
  forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText forall a b. (a -> b) -> a -> b
$
    Text
"hci: Request failed; "
      forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show (Status -> Int
statusCode Status
status)
      forall a. Semigroup a => a -> a -> a
<> Text
" "
      forall a. Semigroup a => a -> a -> a
<> OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (Status -> ByteString
statusMessage Status
status)
      forall a. Semigroup a => a -> a -> a
<> Text
" on: "
      forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertText a b => a -> b
toS (BaseUrl -> String
showBaseUrl BaseUrl
base)
      forall a. Semigroup a => a -> a -> a
<> Text
"/"
      forall a. Semigroup a => a -> a -> a
<> (Char -> Bool) -> Text -> Text
T.dropWhile (forall a. Eq a => a -> a -> Bool
== Char
'/') (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode ByteString
path)
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a. IO a
exitFailure
dieWithHttpError ClientError
e = do
  forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText forall a b. (a -> b) -> a -> b
$ Text
"hci: Request failed: " forall a. Semigroup a => a -> a -> a
<> forall a b. ConvertText a b => a -> b
toS (forall e. Exception e => e -> String
displayException ClientError
e)
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a. IO a
exitFailure

prettyPrintHttpErrors :: IO a -> IO a
prettyPrintHttpErrors :: forall a. IO a -> IO a
prettyPrintHttpErrors = forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle forall a. ClientError -> IO a
dieWithHttpError

-- | Low indicating the inclusiveness of the boundaries. Low is included. High is excluded.
-- A pair where `fst` > `snd` forms an empty range.
inLowRange :: Ord a => a -> (a, a) -> Bool
a
a inLowRange :: forall a. Ord a => a -> (a, a) -> Bool
`inLowRange` (a
p, a
q) = a
a forall a. Ord a => a -> a -> Bool
>= a
p Bool -> Bool -> Bool
&& a
a forall a. Ord a => a -> a -> Bool
< a
q

-- In a library, this should support 429 with Retry-After
shouldRetryResponse :: Either ClientError r -> Bool
shouldRetryResponse :: forall r. Either ClientError r -> Bool
shouldRetryResponse (Left ClientError
e) = ClientError -> Bool
shouldRetryClientError ClientError
e
shouldRetryResponse Either ClientError r
_ = Bool
False

code :: ResponseF a -> Int
code :: forall a. ResponseF a -> Int
code = Status -> Int
statusCode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ResponseF a -> Status
responseStatusCode

shouldRetryClientError :: ClientError -> Bool
shouldRetryClientError :: ClientError -> Bool
shouldRetryClientError (ClientError.FailureResponse RequestF () (BaseUrl, ByteString)
_ Response
resp) | forall a. ResponseF a -> Int
code Response
resp forall a. Eq a => a -> a -> Bool
== Int
501 = Bool
False -- 501 Not Implemented
shouldRetryClientError (ClientError.FailureResponse RequestF () (BaseUrl, ByteString)
_ Response
resp) | forall a. ResponseF a -> Int
code Response
resp forall a. Eq a => a -> a -> Bool
== Int
505 = Bool
False -- 505 HTTP Version Not Supported
shouldRetryClientError (ClientError.FailureResponse RequestF () (BaseUrl, ByteString)
_ Response
resp) | forall a. ResponseF a -> Int
code Response
resp forall a. Eq a => a -> a -> Bool
== Int
408 = Bool
True -- 408 Request Timeout
shouldRetryClientError (ClientError.FailureResponse RequestF () (BaseUrl, ByteString)
_ Response
resp) | forall a. ResponseF a -> Int
code Response
resp forall a. Ord a => a -> (a, a) -> Bool
`inLowRange` (Int
500, Int
600) = Bool
True
shouldRetryClientError (ClientError.DecodeFailure Text
_ Response
_) = Bool
False -- Server programming error or API incompatibility
shouldRetryClientError (ClientError.UnsupportedContentType MediaType
_ Response
_) = Bool
False
shouldRetryClientError (ClientError.InvalidContentTypeHeader Response
_) = Bool
False
shouldRetryClientError (ClientError.ConnectionError SomeException
_) = Bool
True
shouldRetryClientError ClientError
_ = Bool
False

-- | ClientError printer that won't leak sensitive info.
clientErrorSummary :: ClientError -> Text
clientErrorSummary :: ClientError -> Text
clientErrorSummary (ClientError.FailureResponse RequestF () (BaseUrl, ByteString)
_ Response
resp) = Text
"status " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show (forall a. ResponseF a -> Status
responseStatusCode Response
resp)
clientErrorSummary ClientError.DecodeFailure {} = Text
"decode failure"
clientErrorSummary ClientError.UnsupportedContentType {} = Text
"unsupported content type"
clientErrorSummary ClientError.InvalidContentTypeHeader {} = Text
"invalid content type header"
clientErrorSummary (ClientError.ConnectionError SomeException
e) = Text
"connection error: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show SomeException
e