{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | internal module to support modules in GitLab.API
module GitLab.WebRequests.GitLabWebCalls
  ( GitLabParam,
    gitlabGetOne,
    gitlabGetMany,
    gitlabPost,
    gitlabPut,
    gitlabDelete,
    gitlabUnsafe,
    gitlabGetByteStringResponse,
  )
where

import qualified Control.Exception as Exception
import Control.Monad.IO.Class
import qualified Control.Monad.Reader as MR
import Data.Aeson
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import Data.Maybe (isJust)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import GitLab.Types
import Network.HTTP.Conduit
import Network.HTTP.Types.Status
import Network.HTTP.Types.URI
import Text.Read

newtype GitLabException = GitLabException String
  deriving (GitLabException -> GitLabException -> Bool
(GitLabException -> GitLabException -> Bool)
-> (GitLabException -> GitLabException -> Bool)
-> Eq GitLabException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GitLabException -> GitLabException -> Bool
== :: GitLabException -> GitLabException -> Bool
$c/= :: GitLabException -> GitLabException -> Bool
/= :: GitLabException -> GitLabException -> Bool
Eq, Int -> GitLabException -> ShowS
[GitLabException] -> ShowS
GitLabException -> String
(Int -> GitLabException -> ShowS)
-> (GitLabException -> String)
-> ([GitLabException] -> ShowS)
-> Show GitLabException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GitLabException -> ShowS
showsPrec :: Int -> GitLabException -> ShowS
$cshow :: GitLabException -> String
show :: GitLabException -> String
$cshowList :: [GitLabException] -> ShowS
showList :: [GitLabException] -> ShowS
Show)

instance Exception.Exception GitLabException

type GitLabParam = (BS.ByteString, Maybe BS.ByteString)

gitlabGetOne ::
  (FromJSON a) =>
  -- | the URL to post to
  Text ->
  -- | the data to post
  [GitLabParam] ->
  GitLab (Either (Response BSL.ByteString) (Maybe a))
gitlabGetOne :: forall a.
FromJSON a =>
Text
-> [GitLabParam] -> GitLab (Either (Response ByteString) (Maybe a))
gitlabGetOne Text
urlPath [GitLabParam]
params =
  GitLab (Either (Response ByteString) (Maybe a))
request
  where
    request :: GitLab (Either (Response ByteString) (Maybe a))
request =
      ByteString
-> ByteString
-> Text
-> [GitLabParam]
-> [GitLabParam]
-> GitLab (Either (Response ByteString) (Maybe a))
forall a.
FromJSON a =>
ByteString
-> ByteString
-> Text
-> [GitLabParam]
-> [GitLabParam]
-> GitLab (Either (Response ByteString) (Maybe a))
gitlabHTTPOne
        ByteString
"GET"
        ByteString
"application/x-www-form-urlencoded"
        Text
urlPath
        [GitLabParam]
params
        []

gitlabGetMany ::
  (FromJSON a) =>
  -- | the URL to post to
  Text ->
  -- | the data to post
  [GitLabParam] ->
  GitLab (Either (Response BSL.ByteString) [a])
gitlabGetMany :: forall a.
FromJSON a =>
Text -> [GitLabParam] -> GitLab (Either (Response ByteString) [a])
gitlabGetMany Text
urlPath [GitLabParam]
params =
  ByteString
-> ByteString
-> Text
-> [GitLabParam]
-> [GitLabParam]
-> GitLab (Either (Response ByteString) [a])
forall a.
FromJSON a =>
ByteString
-> ByteString
-> Text
-> [GitLabParam]
-> [GitLabParam]
-> GitLab (Either (Response ByteString) [a])
gitlabHTTPMany
    ByteString
"GET"
    ByteString
"application/x-www-form-urlencoded"
    Text
urlPath
    [GitLabParam]
params
    []

gitlabPost ::
  (FromJSON a) =>
  -- | the URL to post to
  Text ->
  -- | the data to post
  [GitLabParam] ->
  GitLab (Either (Response BSL.ByteString) (Maybe a))
gitlabPost :: forall a.
FromJSON a =>
Text
-> [GitLabParam] -> GitLab (Either (Response ByteString) (Maybe a))
gitlabPost Text
urlPath [GitLabParam]
params = do
  GitLab (Either (Response ByteString) (Maybe a))
request
  where
    request :: GitLab (Either (Response ByteString) (Maybe a))
request =
      ByteString
-> ByteString
-> Text
-> [GitLabParam]
-> [GitLabParam]
-> GitLab (Either (Response ByteString) (Maybe a))
forall a.
FromJSON a =>
ByteString
-> ByteString
-> Text
-> [GitLabParam]
-> [GitLabParam]
-> GitLab (Either (Response ByteString) (Maybe a))
gitlabHTTPOne
        ByteString
"POST"
        ByteString
"application/x-www-form-urlencoded"
        Text
urlPath
        []
        [GitLabParam]
params

gitlabPut ::
  FromJSON a =>
  -- | the URL to post to
  Text ->
  -- | the data to post
  [GitLabParam] ->
  GitLab (Either (Response BSL.ByteString) (Maybe a))
gitlabPut :: forall a.
FromJSON a =>
Text
-> [GitLabParam] -> GitLab (Either (Response ByteString) (Maybe a))
gitlabPut Text
urlPath [GitLabParam]
params = do
  GitLab (Either (Response ByteString) (Maybe a))
request
  where
    request :: GitLab (Either (Response ByteString) (Maybe a))
request =
      ByteString
-> ByteString
-> Text
-> [GitLabParam]
-> [GitLabParam]
-> GitLab (Either (Response ByteString) (Maybe a))
forall a.
FromJSON a =>
ByteString
-> ByteString
-> Text
-> [GitLabParam]
-> [GitLabParam]
-> GitLab (Either (Response ByteString) (Maybe a))
gitlabHTTPOne
        ByteString
"PUT"
        ByteString
"application/x-www-form-urlencoded"
        Text
urlPath
        []
        [GitLabParam]
params

gitlabDelete ::
  FromJSON a =>
  -- | the URL to post to
  Text ->
  -- | the data to post
  [GitLabParam] ->
  GitLab (Either (Response BSL.ByteString) (Maybe a))
gitlabDelete :: forall a.
FromJSON a =>
Text
-> [GitLabParam] -> GitLab (Either (Response ByteString) (Maybe a))
gitlabDelete Text
urlPath [GitLabParam]
params = do
  GitLab (Either (Response ByteString) (Maybe a))
request
  where
    request :: GitLab (Either (Response ByteString) (Maybe a))
request =
      ByteString
-> ByteString
-> Text
-> [GitLabParam]
-> [GitLabParam]
-> GitLab (Either (Response ByteString) (Maybe a))
forall a.
FromJSON a =>
ByteString
-> ByteString
-> Text
-> [GitLabParam]
-> [GitLabParam]
-> GitLab (Either (Response ByteString) (Maybe a))
gitlabHTTPOne
        ByteString
"DELETE"
        ByteString
"application/x-www-form-urlencoded"
        Text
urlPath
        []
        [GitLabParam]
params

-- | Assumes that HTTP error code responses, e.g. 404, 409, won't be
-- returned as (Left response) value.
gitlabUnsafe :: GitLab (Either a (Maybe b)) -> GitLab b
gitlabUnsafe :: forall a b. GitLab (Either a (Maybe b)) -> GitLab b
gitlabUnsafe GitLab (Either a (Maybe b))
query = do
  Either a (Maybe b)
result <- GitLab (Either a (Maybe b))
query
  case Either a (Maybe b)
result of
    Left a
_err -> String -> GitLab b
forall a. HasCallStack => String -> a
error String
"gitlabUnsafe error"
    Right Maybe b
Nothing -> String -> GitLab b
forall a. HasCallStack => String -> a
error String
"gitlabUnsafe error"
    Right (Just b
x) -> b -> GitLab b
forall a. a -> GitLabT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return b
x

-- | Lower level query that returns the raw bytestring response from a
-- GitLab HTTP query. Useful for downloading project archives files.
gitlabGetByteStringResponse ::
  -- | the URL to post to
  Text ->
  -- | the data to post
  [GitLabParam] ->
  GitLab (Response BSL.ByteString)
gitlabGetByteStringResponse :: Text -> [GitLabParam] -> GitLab (Response ByteString)
gitlabGetByteStringResponse Text
urlPath [GitLabParam]
params =
  GitLab (Response ByteString)
request
  where
    request :: GitLab (Response ByteString)
request =
      ByteString
-> ByteString
-> Text
-> [GitLabParam]
-> [GitLabParam]
-> GitLab (Response ByteString)
gitlabHTTP
        ByteString
"GET"
        ByteString
"application/x-www-form-urlencoded"
        Text
urlPath
        [GitLabParam]
params
        []

---------------------
-- internal functions

gitlabHTTP ::
  -- | HTTP method (PUT, POST, DELETE, GET)
  BS.ByteString ->
  -- | Content type (content-type)
  BS.ByteString ->
  -- | the URL
  Text ->
  -- | the URL parameters for GET calls
  [GitLabParam] ->
  -- | the content paramters for POST, PUT and DELETE calls
  [GitLabParam] ->
  GitLab (Response BSL.ByteString)
gitlabHTTP :: ByteString
-> ByteString
-> Text
-> [GitLabParam]
-> [GitLabParam]
-> GitLab (Response ByteString)
gitlabHTTP ByteString
httpMethod ByteString
contentType Text
urlPath [GitLabParam]
urlParams [GitLabParam]
contentParams = do
  GitLabServerConfig
cfg <- (GitLabState -> GitLabServerConfig)
-> GitLabT IO GitLabServerConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
MR.asks GitLabState -> GitLabServerConfig
serverCfg
  Manager
manager <- (GitLabState -> Manager) -> GitLabT IO Manager
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
MR.asks GitLabState -> Manager
httpManager
  let url' :: Text
url' = GitLabServerConfig -> Text
url GitLabServerConfig
cfg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/api/v4" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
urlPath Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
T.decodeUtf8 (Bool -> [GitLabParam] -> ByteString
renderQuery Bool
True [GitLabParam]
urlParams)
  let authHeader :: (HeaderName, ByteString)
authHeader = case GitLabServerConfig -> AuthMethod
token GitLabServerConfig
cfg of
        AuthMethodToken Text
t -> (HeaderName
"PRIVATE-TOKEN", Text -> ByteString
T.encodeUtf8 Text
t)
        AuthMethodOAuth Text
t -> (HeaderName
"Authorization", ByteString
"Bearer " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
T.encodeUtf8 Text
t)
  let request' :: Request
request' = String -> Request
parseRequest_ (Text -> String
T.unpack Text
url')
      request :: Request
request =
        Request
request'
          { method = httpMethod,
            requestHeaders =
              [ authHeader,
                ("content-type", contentType)
              ],
            requestBody = RequestBodyBS (renderQuery False contentParams)
          }
  IO (Response ByteString) -> GitLab (Response ByteString)
forall a. IO a -> GitLabT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Response ByteString) -> GitLab (Response ByteString))
-> IO (Response ByteString) -> GitLab (Response ByteString)
forall a b. (a -> b) -> a -> b
$ Int
-> Request
-> Int
-> Manager
-> Maybe HttpException
-> IO (Response ByteString)
tryGitLab Int
0 Request
request (GitLabServerConfig -> Int
retries GitLabServerConfig
cfg) Manager
manager Maybe HttpException
forall a. Maybe a
Nothing

gitlabHTTPOne ::
  FromJSON a =>
  -- | HTTP method (PUT, POST, DELETE, GET)
  BS.ByteString ->
  -- | Content type (content-type)
  BS.ByteString ->
  -- | the URL
  Text ->
  -- | the URL query data for GET calls
  [GitLabParam] ->
  -- | the content parameters for POST, PUT and DELETE calls
  [GitLabParam] ->
  GitLab
    (Either (Response BSL.ByteString) (Maybe a))
gitlabHTTPOne :: forall a.
FromJSON a =>
ByteString
-> ByteString
-> Text
-> [GitLabParam]
-> [GitLabParam]
-> GitLab (Either (Response ByteString) (Maybe a))
gitlabHTTPOne ByteString
httpMethod ByteString
contentType Text
urlPath [GitLabParam]
urlParams [GitLabParam]
contentParams = do
  Response ByteString
response <-
    ByteString
-> ByteString
-> Text
-> [GitLabParam]
-> [GitLabParam]
-> GitLab (Response ByteString)
gitlabHTTP
      ByteString
httpMethod
      ByteString
contentType
      Text
urlPath
      [GitLabParam]
urlParams
      [GitLabParam]
contentParams
  if Status -> Bool
successStatus (Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
response)
    then Either (Response ByteString) (Maybe a)
-> GitLab (Either (Response ByteString) (Maybe a))
forall a. a -> GitLabT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> Either (Response ByteString) (Maybe a)
forall a b. b -> Either a b
Right (ByteString -> Maybe a
forall a. FromJSON a => ByteString -> Maybe a
parseOne (Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
response)))
    else Either (Response ByteString) (Maybe a)
-> GitLab (Either (Response ByteString) (Maybe a))
forall a. a -> GitLabT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Response ByteString -> Either (Response ByteString) (Maybe a)
forall a b. a -> Either a b
Left Response ByteString
response)

gitlabHTTPMany ::
  (FromJSON a) =>
  -- | HTTP method (PUT, POST, DELETE, GET)
  BS.ByteString ->
  -- | Content type (content-type)
  BS.ByteString ->
  -- | the URL
  Text ->
  -- | the URL query data for GET calls
  [GitLabParam] ->
  -- | the content parameters for POST, PUT and DELETE calls
  [GitLabParam] ->
  GitLab
    (Either (Response BSL.ByteString) [a])
gitlabHTTPMany :: forall a.
FromJSON a =>
ByteString
-> ByteString
-> Text
-> [GitLabParam]
-> [GitLabParam]
-> GitLab (Either (Response ByteString) [a])
gitlabHTTPMany ByteString
httpMethod ByteString
contentType Text
urlPath [GitLabParam]
urlParams [GitLabParam]
contentParams = do
  Int -> [a] -> GitLab (Either (Response ByteString) [a])
forall a.
FromJSON a =>
Int -> [a] -> GitLab (Either (Response ByteString) [a])
go Int
1 []
  where
    go :: FromJSON a => Int -> [a] -> GitLab (Either (Response BSL.ByteString) [a])
    go :: forall a.
FromJSON a =>
Int -> [a] -> GitLab (Either (Response ByteString) [a])
go Int
pageNum [a]
accum = do
      Response ByteString
response <-
        ByteString
-> ByteString
-> Text
-> [GitLabParam]
-> [GitLabParam]
-> GitLab (Response ByteString)
gitlabHTTP
          ByteString
httpMethod
          ByteString
contentType
          Text
urlPath
          ([GitLabParam]
urlParams [GitLabParam] -> [GitLabParam] -> [GitLabParam]
forall a. Semigroup a => a -> a -> a
<> [(ByteString
"per_page", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"100"), (ByteString
"page", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (Text -> ByteString
T.encodeUtf8 (String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
pageNum))))])
          [GitLabParam]
contentParams
      if Status -> Bool
successStatus (Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
response)
        then do
          case ByteString -> Maybe [a]
forall a. FromJSON a => ByteString -> Maybe [a]
parseMany (Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
response) of
            Maybe [a]
Nothing -> Either (Response ByteString) [a]
-> GitLab (Either (Response ByteString) [a])
forall a. a -> GitLabT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> Either (Response ByteString) [a]
forall a b. b -> Either a b
Right [a]
accum)
            Just [a]
moreResults -> do
              let accum' :: [a]
accum' = [a]
accum [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> [a]
moreResults
              if Response ByteString -> Bool
forall a. Response a -> Bool
hasNextPage Response ByteString
response
                then Int -> [a] -> GitLab (Either (Response ByteString) [a])
forall a.
FromJSON a =>
Int -> [a] -> GitLab (Either (Response ByteString) [a])
go (Int
pageNum Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [a]
accum'
                else Either (Response ByteString) [a]
-> GitLab (Either (Response ByteString) [a])
forall a. a -> GitLabT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> Either (Response ByteString) [a]
forall a b. b -> Either a b
Right [a]
accum')
        else Either (Response ByteString) [a]
-> GitLab (Either (Response ByteString) [a])
forall a. a -> GitLabT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Response ByteString -> Either (Response ByteString) [a]
forall a b. a -> Either a b
Left Response ByteString
response)

hasNextPage :: Response a -> Bool
hasNextPage :: forall a. Response a -> Bool
hasNextPage Response a
resp =
  let hdrs :: [(HeaderName, ByteString)]
hdrs = Response a -> [(HeaderName, ByteString)]
forall body. Response body -> [(HeaderName, ByteString)]
responseHeaders Response a
resp
   in [(HeaderName, ByteString)] -> Bool
forall {a}. (Eq a, IsString a) => [(a, ByteString)] -> Bool
findPages [(HeaderName, ByteString)]
hdrs
  where
    findPages :: [(a, ByteString)] -> Bool
findPages [] = Bool
False
    findPages ((a
"X-Next-Page", ByteString
bs) : [(a, ByteString)]
_) = Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Int -> Bool) -> Maybe Int -> Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe Int
readNP ByteString
bs
    findPages ((a, ByteString)
_ : [(a, ByteString)]
xs) = [(a, ByteString)] -> Bool
findPages [(a, ByteString)]
xs
    readNP :: BS.ByteString -> Maybe Int
    readNP :: ByteString -> Maybe Int
readNP ByteString
bs = String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
T.unpack (ByteString -> Text
T.decodeUtf8 ByteString
bs))

successStatus :: Status -> Bool
successStatus :: Status -> Bool
successStatus (Status Int
n ByteString
_msg) =
  Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
200 Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
226

tryGitLab ::
  -- | the current retry count
  Int ->
  -- | the GitLab request
  Request ->
  -- | maximum number of retries permitted
  Int ->
  -- | HTTP manager
  Manager ->
  -- | the exception to report if maximum retries met
  Maybe HttpException ->
  IO (Response BSL.ByteString)
tryGitLab :: Int
-> Request
-> Int
-> Manager
-> Maybe HttpException
-> IO (Response ByteString)
tryGitLab Int
i Request
request Int
maxRetries Manager
manager Maybe HttpException
lastException
  | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
maxRetries = String -> IO (Response ByteString)
forall a. HasCallStack => String -> a
error (Maybe HttpException -> String
forall a. Show a => a -> String
show Maybe HttpException
lastException)
  | Bool
otherwise =
      Request -> Manager -> IO (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> Manager -> m (Response ByteString)
httpLbs Request
request Manager
manager
        IO (Response ByteString)
-> (HttpException -> IO (Response ByteString))
-> IO (Response ByteString)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exception.catch` \HttpException
ex -> Int
-> Request
-> Int
-> Manager
-> Maybe HttpException
-> IO (Response ByteString)
tryGitLab (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Request
request Int
maxRetries Manager
manager (HttpException -> Maybe HttpException
forall a. a -> Maybe a
Just HttpException
ex)

parseOne :: FromJSON a => BSL.ByteString -> Maybe a
parseOne :: forall a. FromJSON a => ByteString -> Maybe a
parseOne ByteString
bs =
  case ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
bs of
    Left String
_err -> Maybe a
forall a. Maybe a
Nothing
    Right a
x -> a -> Maybe a
forall a. a -> Maybe a
Just a
x

parseMany :: FromJSON a => BSL.ByteString -> Maybe [a]
parseMany :: forall a. FromJSON a => ByteString -> Maybe [a]
parseMany ByteString
bs =
  case ByteString -> Either String [a]
forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
bs of
    Left String
_err -> Maybe [a]
forall a. Maybe a
Nothing
    Right [a]
xs -> [a] -> Maybe [a]
forall a. a -> Maybe a
Just [a]
xs