{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
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) =>
Text ->
[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) =>
Text ->
[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) =>
Text ->
[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 =>
Text ->
[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 ::
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
[]
[]
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
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 (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 =>
ByteString ->
ByteString ->
Text ->
[GitLabParam] ->
[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) =>
ByteString ->
ByteString ->
Text ->
[GitLabParam] ->
[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
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 ::
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 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