{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module GitLab.WebRequests.GitLabWebCalls
( gitlab,
gitlabUnsafe,
gitlabWithAttrs,
gitlabWithAttrsUnsafe,
gitlabOne,
gitlabWithAttrsOne,
gitlabPost,
gitlabReqText,
gitlabReqByteString,
)
where
import qualified Control.Exception as Exception
import Control.Monad.IO.Class
import Control.Monad.Trans.Reader
import Data.Aeson
import qualified Data.ByteString.Lazy as BSL
import Data.ByteString.Lazy.Char8 as C
import Data.Either
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
newtype GitLabException = GitLabException String
deriving (Eq, Show)
instance Exception.Exception GitLabException
gitlabPost ::
(MonadIO m, FromJSON b) =>
Text ->
Text ->
GitLab m (Either Status b)
gitlabPost urlPath dataBody = do
cfg <- serverCfg <$> ask
manager <- httpManager <$> ask
let url' = url cfg <> "/api/v4" <> urlPath
let request' = parseRequest_ (T.unpack url')
request =
request'
{ method = "POST",
requestHeaders =
[("PRIVATE-TOKEN", T.encodeUtf8 (token cfg))],
requestBody = RequestBodyBS (T.encodeUtf8 dataBody)
}
resp <- liftIO $ tryGitLab 0 request (retries cfg) manager Nothing
if successStatus (responseStatus resp)
then
return
( case parseBSOne (responseBody resp) of
Just x -> Right x
Nothing ->
Left $
mkStatus 409 "unable to parse POST response"
)
else return (Left (responseStatus resp))
tryGitLab ::
Int ->
Request ->
Int ->
Manager ->
Maybe HttpException ->
IO (Response BSL.ByteString)
tryGitLab i request maxRetries manager lastException
| i == maxRetries = error (show lastException)
| otherwise =
httpLbs request manager
`Exception.catch` \ex -> tryGitLab (i + 1) request maxRetries manager (Just ex)
parseBSOne :: FromJSON a => BSL.ByteString -> Maybe a
parseBSOne bs =
case eitherDecode bs of
Left _err -> Nothing
Right xs -> Just xs
parseBSMany :: FromJSON a => BSL.ByteString -> IO [a]
parseBSMany bs =
case eitherDecode bs of
Left s -> Exception.throwIO $ GitLabException s
Right xs -> return xs
gitlabReqJsonMany :: (MonadIO m, FromJSON a) => Text -> Text -> GitLab m (Either Status [a])
gitlabReqJsonMany urlPath attrs =
go 1 []
where
go i accum = do
cfg <- serverCfg <$> ask
manager <- httpManager <$> ask
let url' =
url cfg
<> "/api/v4"
<> urlPath
<> "?per_page=100"
<> "&page="
<> T.pack (show i)
<> T.decodeUtf8 (urlEncode False (T.encodeUtf8 attrs))
let request' = parseRequest_ (T.unpack url')
request =
request'
{ requestHeaders =
[("PRIVATE-TOKEN", T.encodeUtf8 (token cfg))],
responseTimeout = responseTimeoutMicro (timeout cfg)
}
resp <- liftIO $ tryGitLab 0 request (retries cfg) manager Nothing
if successStatus (responseStatus resp)
then do
moreResults <- liftIO $ parseBSMany (responseBody resp)
let numPages = totalPages resp
accum' = accum ++ moreResults
if numPages == i
then return (Right accum')
else go (i + 1) accum'
else return (Left (responseStatus resp))
gitlabReqOne :: (MonadIO m) => (BSL.ByteString -> output) -> Text -> Text -> GitLab m (Either Status output)
gitlabReqOne parser urlPath attrs = go
where
go = do
cfg <- serverCfg <$> ask
manager <- httpManager <$> ask
let url' =
url cfg
<> "/api/v4"
<> urlPath
<> "?per_page=100"
<> "&page=1"
<> attrs
let request' = parseRequest_ (T.unpack url')
request =
request'
{ requestHeaders =
[("PRIVATE-TOKEN", T.encodeUtf8 (token cfg))],
responseTimeout = responseTimeoutMicro (timeout cfg)
}
resp <- liftIO $ tryGitLab 0 request (retries cfg) manager Nothing
if successStatus (responseStatus resp)
then return (Right (parser (responseBody resp)))
else return (Left (responseStatus resp))
gitlabReqJsonOne :: (MonadIO m, FromJSON a) => Text -> Text -> GitLab m (Either Status (Maybe a))
gitlabReqJsonOne =
gitlabReqOne parseBSOne
gitlabReqText :: (MonadIO m) => Text -> GitLab m (Either Status String)
gitlabReqText urlPath = gitlabReqOne C.unpack urlPath ""
gitlabReqByteString :: (MonadIO m) => Text -> GitLab m (Either Status BSL.ByteString)
gitlabReqByteString urlPath = gitlabReqOne Prelude.id urlPath ""
gitlab :: (MonadIO m, FromJSON a) => Text -> GitLab m (Either Status [a])
gitlab addr = gitlabReqJsonMany addr ""
gitlabUnsafe :: (MonadIO m, FromJSON a) => Text -> GitLab m [a]
gitlabUnsafe addr =
fromRight (error "gitlabUnsafe error") <$> gitlab addr
gitlabOne :: (MonadIO m, FromJSON a) => Text -> GitLab m (Either Status (Maybe a))
gitlabOne addr = gitlabReqJsonOne addr ""
gitlabWithAttrs :: (MonadIO m, FromJSON a) => Text -> Text -> GitLab m (Either Status [a])
gitlabWithAttrs = gitlabReqJsonMany
gitlabWithAttrsUnsafe :: (MonadIO m, FromJSON a) => Text -> Text -> GitLab m [a]
gitlabWithAttrsUnsafe gitlabURL attrs =
fromRight (error "gitlabWithAttrsUnsafe error") <$> gitlabReqJsonMany gitlabURL attrs
gitlabWithAttrsOne :: (MonadIO m, FromJSON a) => Text -> Text -> GitLab m (Either Status (Maybe a))
gitlabWithAttrsOne = gitlabReqJsonOne
totalPages :: Response a -> Int
totalPages resp =
let hdrs = responseHeaders resp
in findPages hdrs
where
findPages [] = 1
findPages (("X-Total-Pages", bs) : _) = read (T.unpack (T.decodeUtf8 bs))
findPages (_ : xs) = findPages xs
successStatus :: Status -> Bool
successStatus (Status n _msg) =
n >= 200 && n <= 226