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

import Data.Aeson (FromJSON, ToJSON, decode, eitherDecode, encode)
import qualified Data.ByteString.Lazy as BSL
import Data.Maybe (fromJust, fromMaybe)
import qualified Data.Text as T
import Data.Text (Text, unpack)
import qualified Data.Text.Encoding as T
import Network.HTTP.Client
import Network.HTTP.Client.TLS (tlsManagerSettings)
import System.Environment (lookupEnv)

-- | 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)
      }

-- | Create the 'GerritClient'
withClient ::
  -- | The gerrit api url
  Text ->
  -- | A username (password is read from GERRIT_PASSWORD environment)
  Maybe Text ->
  -- | The callback
  (GerritClient -> IO ()) ->
  -- | withClient performs the IO
  IO ()
withClient :: Text -> Maybe Text -> (GerritClient -> IO ()) -> IO ()
withClient url :: Text
url username :: Maybe Text
username callBack :: GerritClient -> IO ()
callBack =
  do
    Manager
manager <- ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
    Maybe (Text, Text)
auth <- case Maybe Text
username of
      Just user :: Text
user -> do
        Maybe String
pass <- String -> IO (Maybe String)
lookupEnv "GERRIT_PASSWORD"
        Maybe (Text, Text) -> IO (Maybe (Text, Text))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Text, Text) -> IO (Maybe (Text, Text)))
-> Maybe (Text, Text) -> IO (Maybe (Text, Text))
forall a b. (a -> b) -> a -> b
$ (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
user, String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe "" Maybe String
pass)
      _ -> Maybe (Text, Text) -> IO (Maybe (Text, Text))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Text, Text)
forall a. Maybe a
Nothing
    GerritClient -> IO ()
callBack (GerritClient :: Text -> Manager -> Maybe (Text, Text) -> GerritClient
GerritClient {..})
  where
    baseUrl :: Text
baseUrl = (Char -> Bool) -> Text -> Text
T.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '/') Text
url Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "/"

gerritDecode :: (FromJSON a, Applicative f) => Response BSL.ByteString -> f a
gerritDecode :: Response ByteString -> f a
gerritDecode response :: Response ByteString
response = case ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecode (ByteString -> Either String a) -> ByteString -> Either String a
forall a b. (a -> b) -> a -> b
$ Int64 -> ByteString -> ByteString
BSL.drop 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 err :: String
err -> String -> f a
forall a. HasCallStack => String -> a
error (String -> f a) -> String -> f a
forall a b. (a -> b) -> a -> b
$ "Decoding of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show (Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
response) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> " failed with: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err
  Right a :: a
a -> a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

gerritPost :: (ToJSON a, FromJSON b) => Text -> a -> GerritClient -> IO b
gerritPost :: Text -> a -> GerritClient -> IO b
gerritPost path :: Text
path postData :: a
postData GerritClient {..} =
  do
    Request
initRequest <- case Maybe (Text, Text)
auth of
      Just (user :: Text
user, pass :: 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
<$> String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow (Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
baseUrl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "a/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path)
      Nothing -> String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow (Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
baseUrl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path)
    let request :: Request
request =
          Request
initRequest
            { method :: ByteString
method = "POST",
              requestHeaders :: RequestHeaders
requestHeaders = Request -> RequestHeaders
requestHeaders Request
initRequest RequestHeaders -> RequestHeaders -> RequestHeaders
forall a. Semigroup a => a -> a -> a
<> [("Content-Type", "application/json; charset=UTF-8")],
              requestBody :: RequestBody
requestBody = ByteString -> RequestBody
RequestBodyLBS (ByteString -> RequestBody) -> ByteString -> RequestBody
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. ToJSON a => a -> ByteString
encode a
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 :: Text -> GerritClient -> IO a
gerritGet path :: Text
path GerritClient {..} =
  do
    Request
request <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow (Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
baseUrl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path)
    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