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

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

import qualified Control.Exception as Exception
import Control.Monad.IO.Class
import Control.Monad.Trans.Reader
import Data.Aeson
import Data.ByteString
import qualified Data.ByteString.Lazy as BSL
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
/= :: GitLabException -> GitLabException -> Bool
$c/= :: GitLabException -> GitLabException -> Bool
== :: GitLabException -> GitLabException -> Bool
$c== :: 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
showList :: [GitLabException] -> ShowS
$cshowList :: [GitLabException] -> ShowS
show :: GitLabException -> String
$cshow :: GitLabException -> String
showsPrec :: Int -> GitLabException -> ShowS
$cshowsPrec :: Int -> GitLabException -> ShowS
Show)

instance Exception.Exception GitLabException

type GitLabParam = (ByteString, Maybe ByteString)

gitlabGetOne ::
  (FromJSON a) =>
  -- | the URL to post to
  Text ->
  -- | the data to post
  [GitLabParam] ->
  GitLab (Either (Response BSL.ByteString) (Maybe a))
gitlabGetOne :: 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 :: 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 :: 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 :: 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 ::
  -- | the URL to post to
  Text ->
  GitLab (Either (Response BSL.ByteString) (Maybe ()))
gitlabDelete :: Text -> GitLab (Either (Response ByteString) (Maybe ()))
gitlabDelete Text
urlPath = do
  Either (Response ByteString) (Maybe ())
result <- GitLab (Either (Response ByteString) (Maybe ()))
request
  case Either (Response ByteString) (Maybe ())
result of
    Right (Just ()
_) -> Either (Response ByteString) (Maybe ())
-> GitLab (Either (Response ByteString) (Maybe ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe () -> Either (Response ByteString) (Maybe ())
forall a b. b -> Either a b
Right (() -> Maybe ()
forall a. a -> Maybe a
Just ()))
    Either (Response ByteString) (Maybe ())
x -> Either (Response ByteString) (Maybe ())
-> GitLab (Either (Response ByteString) (Maybe ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Either (Response ByteString) (Maybe ())
x
  where
    request :: GitLab (Either (Response ByteString) (Maybe ()))
request =
      ByteString
-> ByteString
-> Text
-> [GitLabParam]
-> [GitLabParam]
-> GitLab (Either (Response ByteString) (Maybe ()))
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
        []
        []

-- | 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 :: 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 (m :: * -> *) a. Monad m => a -> m a
return b
x

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

gitlabHTTP ::
  -- | HTTP method (PUT, POST, DELETE, GET)
  ByteString ->
  -- | Content type (content-type)
  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
serverCfg (GitLabState -> GitLabServerConfig)
-> ReaderT GitLabState IO GitLabState
-> ReaderT GitLabState IO GitLabServerConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT GitLabState IO GitLabState
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  Manager
manager <- GitLabState -> Manager
httpManager (GitLabState -> Manager)
-> ReaderT GitLabState IO GitLabState
-> ReaderT GitLabState IO Manager
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT GitLabState IO GitLabState
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  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 request' :: Request
request' = String -> Request
parseRequest_ (Text -> String
T.unpack Text
url')
      request :: Request
request =
        Request
request'
          { method :: ByteString
method = ByteString
httpMethod,
            requestHeaders :: RequestHeaders
requestHeaders =
              [ (HeaderName
"PRIVATE-TOKEN", Text -> ByteString
T.encodeUtf8 (GitLabServerConfig -> Text
token GitLabServerConfig
cfg)),
                (HeaderName
"content-type", ByteString
contentType)
              ],
            requestBody :: RequestBody
requestBody = ByteString -> RequestBody
RequestBodyBS (Bool -> [GitLabParam] -> ByteString
renderQuery Bool
False [GitLabParam]
contentParams)
          }
  Response ByteString
response <- IO (Response ByteString) -> GitLab (Response ByteString)
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
  Response ByteString -> GitLab (Response ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return Response ByteString
response

gitlabHTTPOne ::
  FromJSON a =>
  -- | HTTP method (PUT, POST, DELETE, GET)
  ByteString ->
  -- | Content type (content-type)
  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 :: 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 (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 (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)
  ByteString ->
  -- | Content type (content-type)
  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 :: 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 :: 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 (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 numPages :: Int
numPages = Response ByteString -> Int
forall a. Response a -> Int
totalPages Response ByteString
response
                  accum' :: [a]
accum' = [a]
accum [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> [a]
moreResults
              if Int
pageNum Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
numPages
                then Either (Response ByteString) [a]
-> GitLab (Either (Response ByteString) [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 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 (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)

totalPages :: Response a -> Int
totalPages :: Response a -> Int
totalPages Response a
resp =
  let hdrs :: RequestHeaders
hdrs = Response a -> RequestHeaders
forall body. Response body -> RequestHeaders
responseHeaders Response a
resp
   in RequestHeaders -> Int
forall p a.
(Num p, Eq a, IsString a, Read p) =>
[(a, ByteString)] -> p
findPages RequestHeaders
hdrs
  where
    findPages :: [(a, ByteString)] -> p
findPages [] = p
1 -- error "cannot find X-Total-Pages in header"
    findPages ((a
"X-Total-Pages", ByteString
bs) : [(a, ByteString)]
_) =
      case String -> Maybe p
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
T.unpack (ByteString -> Text
T.decodeUtf8 ByteString
bs)) of
        Just p
s -> p
s
        Maybe p
Nothing -> String -> p
forall a. HasCallStack => String -> a
error String
"cannot find X-Total-Pages in header"
    findPages ((a, ByteString)
_ : [(a, ByteString)]
xs) = [(a, ByteString)] -> p
findPages [(a, ByteString)]
xs

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 :: 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 :: 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