{-# 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 Data.ByteString
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
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
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 :: 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 =
      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 =
  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 =
      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 =
      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 =
      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 -> forall a. HasCallStack => String -> a
error String
"gitlabUnsafe error"
    Right Maybe b
Nothing -> forall a. HasCallStack => String -> a
error String
"gitlabUnsafe error"
    Right (Just b
x) -> 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)
  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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
MR.ask
  Manager
manager <- GitLabState -> Manager
httpManager forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
MR.ask
  let url' :: Text
url' = GitLabServerConfig -> Text
url GitLabServerConfig
cfg forall a. Semigroup a => a -> a -> a
<> Text
"/api/v4" forall a. Semigroup a => a -> a -> a
<> Text
urlPath 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)
          }
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 forall a. Maybe a
Nothing

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 :: 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 (forall body. Response body -> Status
responseStatus Response ByteString
response)
    then forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right (forall a. FromJSON a => ByteString -> Maybe a
parseOne (forall body. Response body -> body
responseBody Response ByteString
response)))
    else forall (m :: * -> *) a. Monad m => a -> m a
return (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 :: 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
  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 forall a. Semigroup a => a -> a -> a
<> [(ByteString
"per_page", forall a. a -> Maybe a
Just ByteString
"100"), (ByteString
"page", forall a. a -> Maybe a
Just (Text -> ByteString
T.encodeUtf8 (String -> Text
T.pack (forall a. Show a => a -> String
show Int
pageNum))))])
          [GitLabParam]
contentParams
      if Status -> Bool
successStatus (forall body. Response body -> Status
responseStatus Response ByteString
response)
        then do
          case forall a. FromJSON a => ByteString -> Maybe [a]
parseMany (forall body. Response body -> body
responseBody Response ByteString
response) of
            Maybe [a]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right [a]
accum)
            Just [a]
moreResults -> do
              let accum' :: [a]
accum' = [a]
accum forall a. Semigroup a => a -> a -> a
<> [a]
moreResults
              if forall a. Response a -> Bool
hasNextPage Response ByteString
response
                then forall a.
FromJSON a =>
Int -> [a] -> GitLab (Either (Response ByteString) [a])
go (Int
pageNum forall a. Num a => a -> a -> a
+ Int
1) [a]
accum'
                else forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right [a]
accum')
        else forall (m :: * -> *) a. Monad m => a -> m a
return (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 :: RequestHeaders
hdrs = forall body. Response body -> RequestHeaders
responseHeaders Response a
resp
   in forall {a}. (Eq a, IsString a) => [(a, ByteString)] -> Bool
findPages RequestHeaders
hdrs
  where
    findPages :: [(a, ByteString)] -> Bool
findPages [] = Bool
False
    findPages ((a
"X-Next-Page", ByteString
bs) : [(a, ByteString)]
_) = forall a. Maybe a -> Bool
isJust 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 :: ByteString -> Maybe Int
    readNP :: ByteString -> Maybe Int
readNP ByteString
bs = 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 forall a. Ord a => a -> a -> Bool
>= Int
200 Bool -> Bool -> Bool
&& Int
n 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 forall a. Eq a => a -> a -> Bool
== Int
maxRetries = forall a. HasCallStack => String -> a
error (forall a. Show a => a -> String
show Maybe HttpException
lastException)
  | Bool
otherwise =
      forall (m :: * -> *).
MonadIO m =>
Request -> Manager -> m (Response ByteString)
httpLbs Request
request Manager
manager
        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 forall a. Num a => a -> a -> a
+ Int
1) Request
request Int
maxRetries Manager
manager (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 forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
bs of
    Left String
_err -> forall a. Maybe a
Nothing
    Right a
x -> 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 forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
bs of
    Left String
_err -> forall a. Maybe a
Nothing
    Right [a]
xs -> forall a. a -> Maybe a
Just [a]
xs