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

-- | This module contains the internal gerrit REST client
module Gerrit.Client (
    GerritClient (baseUrl),
    withClient,
    gerritGet,
    gerritPost,
    getClient,
    getClientWithManager,
)
where

import Data.Aeson (FromJSON, ToJSON, eitherDecode, encode)
import qualified Data.ByteString.Lazy as BSL
import Data.Text (Text, unpack)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Network.HTTP.Client
import Network.HTTP.Client.OpenSSL (newOpenSSLManager, withOpenSSL)

-- | The GerritClient record, use 'withClient' to create
data GerritClient = GerritClient
    { GerritClient -> Text
baseUrl :: Text
    , GerritClient -> Manager
manager :: Manager
    , GerritClient -> Maybe (Text, Text)
auth :: Maybe (Text, Text)
    }

-- | Need to be call through withOpenSSL
getClient :: Text -> Maybe (Text, Text) -> IO GerritClient
getClient :: Text -> Maybe (Text, Text) -> IO GerritClient
getClient Text
url Maybe (Text, Text)
auth = do
    Manager
manager <- IO Manager
forall (m :: * -> *). MonadIO m => m Manager
newOpenSSLManager
    GerritClient -> IO GerritClient
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GerritClient -> IO GerritClient)
-> GerritClient -> IO GerritClient
forall a b. (a -> b) -> a -> b
$ Manager -> Text -> Maybe (Text, Text) -> GerritClient
getClientWithManager Manager
manager Text
url Maybe (Text, Text)
auth

-- | Creates a GerritClient with a provided http manager.
getClientWithManager :: Manager -> Text -> Maybe (Text, Text) -> GerritClient
getClientWithManager :: Manager -> Text -> Maybe (Text, Text) -> GerritClient
getClientWithManager Manager
manager Text
url Maybe (Text, Text)
auth =
    let baseUrl :: Text
baseUrl = (Char -> Bool) -> Text -> Text
T.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') Text
url Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/"
     in GerritClient{Maybe (Text, Text)
Text
Manager
baseUrl :: Text
manager :: Manager
auth :: Maybe (Text, Text)
manager :: Manager
auth :: Maybe (Text, Text)
baseUrl :: Text
..}

-- | Create the 'GerritClient'
withClient ::
    -- | The gerrit api url
    Text ->
    -- | Credentials (login, password) [Optional]
    Maybe (Text, Text) ->
    -- | The callback
    (GerritClient -> IO a) ->
    -- | withClient performs the IO
    IO a
withClient :: forall a.
Text -> Maybe (Text, Text) -> (GerritClient -> IO a) -> IO a
withClient Text
url Maybe (Text, Text)
creds GerritClient -> IO a
callBack = IO a -> IO a
forall a. IO a -> IO a
withOpenSSL (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
    GerritClient
client <- Text -> Maybe (Text, Text) -> IO GerritClient
getClient Text
url Maybe (Text, Text)
creds
    GerritClient -> IO a
callBack GerritClient
client

gerritDecode :: (FromJSON a, Applicative f) => Response BSL.ByteString -> f a
gerritDecode :: forall a (f :: * -> *).
(FromJSON a, Applicative f) =>
Response ByteString -> f a
gerritDecode Response ByteString
response = case ByteString -> Either [Char] a
forall a. FromJSON a => ByteString -> Either [Char] a
eitherDecode (ByteString -> Either [Char] a) -> ByteString -> Either [Char] a
forall a b. (a -> b) -> a -> b
$ Int64 -> ByteString -> ByteString
BSL.drop Int64
5 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
response of
    Left [Char]
err -> [Char] -> f a
forall a. HasCallStack => [Char] -> a
error ([Char] -> f a) -> [Char] -> f a
forall a b. (a -> b) -> a -> b
$ [Char]
"Decoding of " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> ByteString -> [Char]
forall a. Show a => a -> [Char]
show (Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
response) [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" failed with: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
err
    Right a
a -> a -> f a
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

gerritRequest :: Text -> GerritClient -> IO Request
gerritRequest :: Text -> GerritClient -> IO Request
gerritRequest Text
path GerritClient{Maybe (Text, Text)
Text
Manager
baseUrl :: GerritClient -> Text
manager :: GerritClient -> Manager
auth :: GerritClient -> Maybe (Text, Text)
baseUrl :: Text
manager :: Manager
auth :: Maybe (Text, Text)
..} =
    case Maybe (Text, Text)
auth of
        Just (Text
user, Text
pass) ->
            ByteString -> ByteString -> Request -> Request
applyBasicAuth (Text -> ByteString
T.encodeUtf8 Text
user) (Text -> ByteString
T.encodeUtf8 Text
pass)
                (Request -> Request) -> IO Request -> IO Request
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO Request
forall (m :: * -> *). MonadThrow m => [Char] -> m Request
parseUrlThrow (Text -> [Char]
unpack (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ Text
baseUrl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"a/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path)
        Maybe (Text, Text)
Nothing -> [Char] -> IO Request
forall (m :: * -> *). MonadThrow m => [Char] -> m Request
parseUrlThrow (Text -> [Char]
unpack (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ Text
baseUrl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path)

gerritPost :: (ToJSON a, FromJSON b) => Text -> a -> GerritClient -> IO b
gerritPost :: forall a b.
(ToJSON a, FromJSON b) =>
Text -> a -> GerritClient -> IO b
gerritPost Text
path a
postData client :: GerritClient
client@GerritClient{Maybe (Text, Text)
Text
Manager
baseUrl :: GerritClient -> Text
manager :: GerritClient -> Manager
auth :: GerritClient -> Maybe (Text, Text)
baseUrl :: Text
manager :: Manager
auth :: Maybe (Text, Text)
..} =
    do
        Request
initRequest <- Text -> GerritClient -> IO Request
gerritRequest Text
path GerritClient
client
        let request :: Request
request =
                Request
initRequest
                    { method = "POST"
                    , requestHeaders = requestHeaders initRequest <> [("Content-Type", "application/json; charset=UTF-8")]
                    , requestBody = RequestBodyLBS $ encode postData
                    }
        Response ByteString
response <- Request -> Manager -> IO (Response ByteString)
httpLbs Request
request Manager
manager
        Response ByteString -> IO b
forall a (f :: * -> *).
(FromJSON a, Applicative f) =>
Response ByteString -> f a
gerritDecode Response ByteString
response

gerritGet :: (FromJSON a) => Text -> GerritClient -> IO a
gerritGet :: forall a. FromJSON a => Text -> GerritClient -> IO a
gerritGet Text
path client :: GerritClient
client@GerritClient{Maybe (Text, Text)
Text
Manager
baseUrl :: GerritClient -> Text
manager :: GerritClient -> Manager
auth :: GerritClient -> Maybe (Text, Text)
baseUrl :: Text
manager :: Manager
auth :: Maybe (Text, Text)
..} =
    do
        Request
request <- Text -> GerritClient -> IO Request
gerritRequest Text
path GerritClient
client
        Response ByteString
response <- Request -> Manager -> IO (Response ByteString)
httpLbs Request
request Manager
manager
        Response ByteString -> IO a
forall a (f :: * -> *).
(FromJSON a, Applicative f) =>
Response ByteString -> f a
gerritDecode Response ByteString
response