module GitHub.Request (
Request(..),
CommandMethod(..),
toMethod,
Paths,
QueryString,
executeRequest,
executeRequestWithMgr,
executeRequest',
executeRequestWithMgr',
executeRequestMaybe,
unsafeDropAuthRequirements,
makeHttpRequest,
parseResponse,
parseStatus,
getNextUrl,
performPagedRequest,
) where
import Prelude ()
import Prelude.Compat
#if MIN_VERSION_mtl(2,2,0)
import Control.Monad.Except (MonadError (..))
#else
import Control.Monad.Error (MonadError (..))
#endif
import Control.Monad.Catch (MonadCatch (..), MonadThrow)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
import Data.Aeson.Compat (FromJSON, eitherDecode)
import Data.List (find, intercalate)
import Data.Semigroup (Semigroup (..))
import Data.Text (Text)
import Data.Vector.Instances ()
import Network.HTTP.Client (CookieJar, HttpException (..), Manager,
RequestBody (..), Response (..),
applyBasicAuth, checkStatus, httpLbs,
method, newManager, parseUrl, requestBody,
requestHeaders, setQueryString)
import Network.HTTP.Client.Internal (setUri)
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.HTTP.Link.Parser (parseLinkHeaderBS)
import Network.HTTP.Link.Types (Link (..), LinkParam (..), href,
linkParams)
import Network.HTTP.Types (Method, RequestHeaders, ResponseHeaders,
Status (..))
import Network.URI (URI)
import qualified Control.Exception as E
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Text as T
import qualified Data.Vector as V
import qualified Network.HTTP.Client as HTTP
import GitHub.Auth (Auth (..))
import GitHub.Data (Error (..))
import GitHub.Data.Request
executeRequest :: Auth -> Request k a -> IO (Either Error a)
executeRequest auth req = do
manager <- newManager tlsManagerSettings
x <- executeRequestWithMgr manager auth req
#if !MIN_VERSION_http_client(0, 4, 18)
closeManager manager
#endif
pure x
executeRequestWithMgr :: Manager
-> Auth
-> Request k a
-> IO (Either Error a)
executeRequestWithMgr mgr auth req = runExceptT $
case req of
Query {} -> do
httpReq <- makeHttpRequest (Just auth) req
res <- httpLbs' httpReq
parseResponse res
PagedQuery _ _ l -> do
httpReq <- makeHttpRequest (Just auth) req
performPagedRequest httpLbs' predicate httpReq
where
predicate = maybe (const True) (\l' -> (< l') . V.length ) l
Command m _ _ -> do
httpReq <- makeHttpRequest (Just auth) req
res <- httpLbs' httpReq
case m of
Delete -> pure ()
_ -> parseResponse res
StatusQuery sm _ -> do
httpReq <- makeHttpRequest (Just auth) req
res <- httpLbs' httpReq
parseStatus sm . responseStatus $ res
where
httpLbs' :: HTTP.Request -> ExceptT Error IO (Response LBS.ByteString)
httpLbs' req' = lift (httpLbs req' mgr) `catch` onHttpException
executeRequest' :: Request 'False a -> IO (Either Error a)
executeRequest' req = do
manager <- newManager tlsManagerSettings
x <- executeRequestWithMgr' manager req
#if !MIN_VERSION_http_client(0, 4, 18)
closeManager manager
#endif
pure x
executeRequestWithMgr' :: Manager
-> Request 'False a
-> IO (Either Error a)
executeRequestWithMgr' mgr req = runExceptT $
case req of
Query {} -> do
httpReq <- makeHttpRequest Nothing req
res <- httpLbs' httpReq
parseResponse res
PagedQuery _ _ l -> do
httpReq <- makeHttpRequest Nothing req
performPagedRequest httpLbs' predicate httpReq
where
predicate = maybe (const True) (\l' -> (< l') . V.length) l
StatusQuery sm _ -> do
httpReq <- makeHttpRequest Nothing req
res <- httpLbs' httpReq
parseStatus sm . responseStatus $ res
where
httpLbs' :: HTTP.Request -> ExceptT Error IO (Response LBS.ByteString)
httpLbs' req' = lift (httpLbs req' mgr) `catch` onHttpException
executeRequestMaybe :: Maybe Auth -> Request 'False a
-> IO (Either Error a)
executeRequestMaybe = maybe executeRequest' executeRequest
unsafeDropAuthRequirements :: Request 'True a -> Request k a
unsafeDropAuthRequirements (Query ps qs) = Query ps qs
unsafeDropAuthRequirements r =
error $ "Trying to drop authenatication from" ++ show r
makeHttpRequest :: MonadThrow m
=> Maybe Auth
-> Request k a
-> m HTTP.Request
makeHttpRequest auth r = case r of
StatusQuery sm req -> do
req' <- makeHttpRequest auth req
return $ setCheckStatus (Just sm) req'
Query paths qs -> do
req <- parseUrl $ url paths
return $ setReqHeaders
. setCheckStatus Nothing
. setAuthRequest auth
. setQueryString qs
$ req
PagedQuery paths qs _ -> do
req <- parseUrl $ url paths
return $ setReqHeaders
. setCheckStatus Nothing
. setAuthRequest auth
. setQueryString qs
$ req
Command m paths body -> do
req <- parseUrl $ url paths
return $ setReqHeaders
. setCheckStatus Nothing
. setAuthRequest auth
. setBody body
. setMethod (toMethod m)
$ req
where
url :: Paths -> String
url paths = baseUrl ++ '/' : intercalate "/" paths
baseUrl :: String
baseUrl = case auth of
Just (EnterpriseOAuth endpoint _) -> endpoint
_ -> "https://api.github.com"
setReqHeaders :: HTTP.Request -> HTTP.Request
setReqHeaders req = req { requestHeaders = reqHeaders <> requestHeaders req }
setCheckStatus :: Maybe (StatusMap a) -> HTTP.Request -> HTTP.Request
setCheckStatus sm req = req { checkStatus = successOrMissing sm }
setMethod :: Method -> HTTP.Request -> HTTP.Request
setMethod m req = req { method = m }
reqHeaders :: RequestHeaders
reqHeaders = maybe [] getOAuthHeader auth
<> [("User-Agent", "github.hs/0.7.4")]
<> [("Accept", "application/vnd.github.preview")]
setBody :: LBS.ByteString -> HTTP.Request -> HTTP.Request
setBody body req = req { requestBody = RequestBodyLBS body }
setAuthRequest :: Maybe Auth -> HTTP.Request -> HTTP.Request
setAuthRequest (Just (BasicAuth user pass)) = applyBasicAuth user pass
setAuthRequest _ = id
getOAuthHeader :: Auth -> RequestHeaders
getOAuthHeader (OAuth token) = [("Authorization", "token " <> token)]
getOAuthHeader (EnterpriseOAuth _ token) = [("Authorization", "token " <> token)]
getOAuthHeader _ = []
successOrMissing :: Maybe (StatusMap a) -> Status -> ResponseHeaders -> CookieJar -> Maybe E.SomeException
successOrMissing sm s@(Status sci _) hs cookiejar
| check = Nothing
| otherwise = Just $ E.toException $ StatusCodeException s hs cookiejar
where
check = case sm of
Nothing -> 200 <= sci && sci < 300
Just StatusOnlyOk -> sci == 204 || sci == 404
Just StatusMerge -> sci `elem` [204, 405, 409]
getNextUrl :: Response a -> Maybe URI
getNextUrl req = do
linkHeader <- lookup "Link" (responseHeaders req)
links <- parseLinkHeaderBS linkHeader
nextURI <- find isRelNext links
return $ href nextURI
where
isRelNext :: Link -> Bool
isRelNext = any (== relNextLinkParam) . linkParams
relNextLinkParam :: (LinkParam, Text)
relNextLinkParam = (Rel, "next")
parseResponse :: (FromJSON a, MonadError Error m) => Response LBS.ByteString -> m a
parseResponse res = case eitherDecode (responseBody res) of
Right x -> return x
Left err -> throwError . ParseError . T.pack $ err
parseStatus :: MonadError Error m => StatusMap a -> Status -> m a
parseStatus StatusOnlyOk (Status sci _)
| sci == 204 = return True
| sci == 404 = return False
| otherwise = throwError $ JsonError $ "invalid status: " <> T.pack (show sci)
parseStatus StatusMerge (Status sci _)
| sci == 204 = return MergeSuccessful
| sci == 405 = return MergeCannotPerform
| sci == 409 = return MergeConflict
| otherwise = throwError $ JsonError $ "invalid status: " <> T.pack (show sci)
performPagedRequest :: forall a m. (FromJSON a, Semigroup a, MonadCatch m, MonadError Error m)
=> (HTTP.Request -> m (Response LBS.ByteString))
-> (a -> Bool)
-> HTTP.Request
-> m a
performPagedRequest httpLbs' predicate initReq = do
res <- httpLbs' initReq
m <- parseResponse res
go m res initReq
where
go :: a -> Response LBS.ByteString -> HTTP.Request -> m a
go acc res req =
case (predicate acc, getNextUrl res) of
(True, Just uri) -> do
req' <- setUri req uri
res' <- httpLbs' req'
m <- parseResponse res'
go (acc <> m) res' req'
(_, _) -> return acc
onHttpException :: MonadError Error m => HttpException -> m a
onHttpException = throwError . HTTPError