{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
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) =>
Text ->
[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) =>
Text ->
[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) =>
Text ->
[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 =>
Text ->
[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 =>
Text ->
[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
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
gitlabGetByteStringResponse ::
Text ->
[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
[]
gitlabHTTP ::
ByteString ->
ByteString ->
Text ->
[GitLabParam] ->
[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 =>
ByteString ->
ByteString ->
Text ->
[GitLabParam] ->
[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) =>
ByteString ->
ByteString ->
Text ->
[GitLabParam] ->
[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 ::
Int ->
Request ->
Int ->
Manager ->
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