{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
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)
data GerritClient = GerritClient
{ GerritClient -> Text
baseUrl :: Text,
GerritClient -> Manager
manager :: Manager,
GerritClient -> Maybe (Text, Text)
auth :: Maybe (Text, Text)
}
getClient :: Text -> Maybe (Text, Text) -> IO GerritClient
getClient :: Text -> Maybe (Text, Text) -> IO GerritClient
getClient Text
url Maybe (Text, Text)
auth = do
Manager
manager <- forall (m :: * -> *). MonadIO m => m Manager
newOpenSSLManager
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Manager -> Text -> Maybe (Text, Text) -> GerritClient
getClientWithManager Manager
manager Text
url Maybe (Text, Text)
auth
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 (forall a. Eq a => a -> a -> Bool
== Char
'/') Text
url forall a. Semigroup a => a -> a -> a
<> Text
"/"
in GerritClient {Maybe (Text, Text)
Text
Manager
baseUrl :: Text
auth :: Maybe (Text, Text)
manager :: Manager
auth :: Maybe (Text, Text)
manager :: Manager
baseUrl :: Text
..}
withClient ::
Text ->
Maybe (Text, Text) ->
(GerritClient -> IO a) ->
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 = forall a. IO a -> IO a
withOpenSSL 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 forall a. FromJSON a => ByteString -> Either [Char] a
eitherDecode forall a b. (a -> b) -> a -> b
$ Int64 -> ByteString -> ByteString
BSL.drop Int64
5 forall a b. (a -> b) -> a -> b
$ forall body. Response body -> body
responseBody Response ByteString
response of
Left [Char]
err -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Decoding of " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (forall body. Response body -> body
responseBody Response ByteString
response) forall a. Semigroup a => a -> a -> a
<> [Char]
" failed with: " forall a. Semigroup a => a -> a -> a
<> [Char]
err
Right a
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
auth :: Maybe (Text, Text)
manager :: Manager
baseUrl :: Text
auth :: GerritClient -> Maybe (Text, Text)
manager :: GerritClient -> Manager
baseUrl :: GerritClient -> 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)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadThrow m => [Char] -> m Request
parseUrlThrow (Text -> [Char]
unpack forall a b. (a -> b) -> a -> b
$ Text
baseUrl forall a. Semigroup a => a -> a -> a
<> Text
"a/" forall a. Semigroup a => a -> a -> a
<> Text
path)
Maybe (Text, Text)
Nothing -> forall (m :: * -> *). MonadThrow m => [Char] -> m Request
parseUrlThrow (Text -> [Char]
unpack forall a b. (a -> b) -> a -> b
$ Text
baseUrl 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
auth :: Maybe (Text, Text)
manager :: Manager
baseUrl :: Text
auth :: GerritClient -> Maybe (Text, Text)
manager :: GerritClient -> Manager
baseUrl :: GerritClient -> Text
..} =
do
Request
initRequest <- Text -> GerritClient -> IO Request
gerritRequest Text
path GerritClient
client
let request :: Request
request =
Request
initRequest
{ method :: ByteString
method = ByteString
"POST",
requestHeaders :: RequestHeaders
requestHeaders = Request -> RequestHeaders
requestHeaders Request
initRequest forall a. Semigroup a => a -> a -> a
<> [(HeaderName
"Content-Type", ByteString
"application/json; charset=UTF-8")],
requestBody :: RequestBody
requestBody = ByteString -> RequestBody
RequestBodyLBS forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
encode a
postData
}
Response ByteString
response <- Request -> Manager -> IO (Response ByteString)
httpLbs Request
request Manager
manager
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
auth :: Maybe (Text, Text)
manager :: Manager
baseUrl :: Text
auth :: GerritClient -> Maybe (Text, Text)
manager :: GerritClient -> Manager
baseUrl :: GerritClient -> 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
forall a (f :: * -> *).
(FromJSON a, Applicative f) =>
Response ByteString -> f a
gerritDecode Response ByteString
response