diff --git a/CHANGELOG.md b/CHANGELOG.md index cdc67227..8d776cb8 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -14,6 +14,12 @@ This reduces symbol bloat in the library. [#409](https://github.com/phadej/github/pull/409) - Update `Repo`, `NewRepo` and `EditRepo` data types [#407](https://github.com/phadej/github/pull/407) +- Add `executeRequestWithMgrAndRes` + [#421](https://github.com/phadej/github/pull/421) +- Add `limitsFromHttpResponse` + [#421](https://github.com/phadej/github/pull/421) +- Add label descriptions + [#418](https://github.com/phadej/github/pull/418) ## Changes for 0.23 diff --git a/github.cabal b/github.cabal index b3a18432..0e9a7335 100644 --- a/github.cabal +++ b/github.cabal @@ -165,7 +165,7 @@ library , deepseq >=1.3.0.2 && <1.5 , mtl >=2.1.3.1 && <2.2 || >=2.2.1 && <2.3 , text >=1.2.0.6 && <1.3 - , time >=1.4 && <1.10 + , time-compat >=1.9.2.2 && <1.10 , transformers >=0.3.0.0 && <0.6 -- other packages diff --git a/samples/Operational/Operational.hs b/samples/Operational/Operational.hs index 15833ece..4e669ff4 100644 --- a/samples/Operational/Operational.hs +++ b/samples/Operational/Operational.hs @@ -7,23 +7,26 @@ module Main (main) where import Common import Prelude () -import Control.Monad.Operational -import Control.Monad.Trans.Except (ExceptT (..), runExceptT) -import Network.HTTP.Client (Manager, newManager) +import Control.Exception (throw) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Operational (Program, ProgramViewT (..), singleton, view) +import Control.Monad.Trans.Except (ExceptT (..), runExceptT) +import Network.HTTP.Client (Manager, newManager, responseBody) -import qualified GitHub as GH +import qualified GitHub as GH data R a where R :: FromJSON a => GH.Request 'GH.RA a -> R a type GithubMonad a = Program R a -runMonad :: Manager -> GH.Auth -> GithubMonad a -> ExceptT GH.Error IO a +runMonad :: GH.AuthMethod auth => Manager -> auth -> GithubMonad a -> ExceptT GH.Error IO a runMonad mgr auth m = case view m of Return a -> return a R req :>>= k -> do - b <- ExceptT $ GH.executeRequestWithMgr mgr auth req - runMonad mgr auth (k b) + res <- ExceptT $ GH.executeRequestWithMgrAndRes mgr auth req + liftIO $ print $ GH.limitsFromHttpResponse res + runMonad mgr auth (k (responseBody res)) githubRequest :: FromJSON a => GH.Request 'GH.RA a -> GithubMonad a githubRequest = singleton . R @@ -33,9 +36,18 @@ main = GH.withOpenSSL $ do manager <- newManager GH.tlsManagerSettings auth' <- getAuth case auth' of - Nothing -> return () + Nothing -> do + (owner, rl) <- runExceptT (runMonad manager () script) >>= either throw return + print owner + print rl Just auth -> do - owner <- runExceptT $ runMonad manager auth $ do - repo <- githubRequest $ GH.repositoryR "phadej" "github" - githubRequest $ GH.ownerInfoForR (GH.simpleOwnerLogin . GH.repoOwner $ repo) + (owner, rl) <- runExceptT (runMonad manager auth script) >>= either throw return print owner + print rl + +script :: Program R (GH.Owner, GH.Limits) +script = do + repo <- githubRequest $ GH.repositoryR "phadej" "github" + owner <- githubRequest $ GH.ownerInfoForR (GH.simpleOwnerLogin . GH.repoOwner $ repo) + rl <- githubRequest GH.rateLimitR + return (owner, GH.rateLimitCore rl) diff --git a/src/GitHub/Auth.hs b/src/GitHub/Auth.hs index 7918c0af..432b2486 100644 --- a/src/GitHub/Auth.hs +++ b/src/GitHub/Auth.hs @@ -30,12 +30,18 @@ instance Binary Auth instance Hashable Auth -- | A type class for different authentication methods +-- +-- Note the '()' intance, which doee nothing, i.e. is unauthenticated. class AuthMethod a where -- | Custom API endpoint without trailing slash endpoint :: a -> Maybe Text -- | A function which sets authorisation on an HTTP request setAuthRequest :: a -> HTTP.Request -> HTTP.Request +instance AuthMethod () where + endpoint _ = Nothing + setAuthRequest _ = id + instance AuthMethod Auth where endpoint (BasicAuth _ _) = Nothing endpoint (OAuth _) = Nothing diff --git a/src/GitHub/Data/Deployments.hs b/src/GitHub/Data/Deployments.hs index 9e65485d..face7a52 100644 --- a/src/GitHub/Data/Deployments.hs +++ b/src/GitHub/Data/Deployments.hs @@ -21,7 +21,6 @@ import Control.Arrow (second) import Data.ByteString (ByteString) import Data.Maybe (catMaybes) import Data.Text (Text) -import Data.Time.Clock (UTCTime) import Data.Vector (Vector) import GitHub.Data.Definitions (SimpleUser) diff --git a/src/GitHub/Data/RateLimit.hs b/src/GitHub/Data/RateLimit.hs index 3fbd6211..2ba008f0 100644 --- a/src/GitHub/Data/RateLimit.hs +++ b/src/GitHub/Data/RateLimit.hs @@ -8,12 +8,17 @@ module GitHub.Data.RateLimit where import GitHub.Internal.Prelude import Prelude () +import Data.Time.Clock.System.Compat (SystemTime (..)) + +import qualified Data.ByteString.Char8 as BS8 +import qualified Network.HTTP.Client as HTTP + data Limits = Limits { limitsMax :: !Int , limitsRemaining :: !Int - , limitsReset :: !Int -- TODO: change to proper type + , limitsReset :: !SystemTime } - deriving (Show, Data, Typeable, Eq, Ord, Generic) + deriving (Show, {- Data, -} Typeable, Eq, Ord, Generic) instance NFData Limits where rnf = genericRnf instance Binary Limits @@ -22,14 +27,14 @@ instance FromJSON Limits where parseJSON = withObject "Limits" $ \obj -> Limits <$> obj .: "limit" <*> obj .: "remaining" - <*> obj .: "reset" + <*> fmap (\t -> MkSystemTime t 0) (obj .: "reset") data RateLimit = RateLimit { rateLimitCore :: Limits , rateLimitSearch :: Limits , rateLimitGraphQL :: Limits } - deriving (Show, Data, Typeable, Eq, Ord, Generic) + deriving (Show, {- Data, -} Typeable, Eq, Ord, Generic) instance NFData RateLimit where rnf = genericRnf instance Binary RateLimit @@ -41,3 +46,21 @@ instance FromJSON RateLimit where <$> resources .: "core" <*> resources .: "search" <*> resources .: "graphql" + +------------------------------------------------------------------------------- +-- Extras +------------------------------------------------------------------------------- + +-- | @since 0.24 +limitsFromHttpResponse :: HTTP.Response a -> Maybe Limits +limitsFromHttpResponse res = do + let hdrs = HTTP.responseHeaders res + m <- lookup "X-RateLimit-Limit" hdrs >>= readIntegral + r <- lookup "X-RateLimit-Remaining" hdrs >>= readIntegral + t <- lookup "X-RateLimit-Reset" hdrs >>= readIntegral + return (Limits m r (MkSystemTime t 0)) + where + readIntegral :: Num a => BS8.ByteString -> Maybe a + readIntegral bs = case BS8.readInt bs of + Just (n, bs') | BS8.null bs' -> Just (fromIntegral n) + _ -> Nothing diff --git a/src/GitHub/Internal/Prelude.hs b/src/GitHub/Internal/Prelude.hs index 07a748b3..8c4785c3 100644 --- a/src/GitHub/Internal/Prelude.hs +++ b/src/GitHub/Internal/Prelude.hs @@ -53,7 +53,7 @@ import Data.Maybe (catMaybes) import Data.Semigroup (Semigroup (..)) import Data.String (IsString (..)) import Data.Text (Text, pack, unpack) -import Data.Time (UTCTime) +import Data.Time.Compat (UTCTime) import Data.Time.ISO8601 (formatISO8601) import Data.Vector (Vector) import Data.Vector.Instances () diff --git a/src/GitHub/Request.hs b/src/GitHub/Request.hs index fc0fd7dd..b72d25be 100644 --- a/src/GitHub/Request.hs +++ b/src/GitHub/Request.hs @@ -46,6 +46,7 @@ module GitHub.Request ( -- * Request execution in IO executeRequest, executeRequestWithMgr, + executeRequestWithMgrAndRes, executeRequest', executeRequestWithMgr', executeRequestMaybe, @@ -66,7 +67,7 @@ module GitHub.Request ( -- | This always exist, independently of @openssl@ configuration flag. -- They change accordingly, to make use of the library simpler. withOpenSSL, - tlsManagerSettings, + tlsManagerSettings, ) where import GitHub.Internal.Prelude @@ -112,7 +113,7 @@ import qualified OpenSSL.Session as SSL import qualified OpenSSL.X509.SystemStore as SSL #endif -import GitHub.Auth (Auth, AuthMethod, endpoint, setAuthRequest) +import GitHub.Auth (AuthMethod, endpoint, setAuthRequest) import GitHub.Data (Error (..)) import GitHub.Data.PullRequests (MergeResult (..)) import GitHub.Data.Request @@ -206,6 +207,7 @@ lessFetchCount :: Int -> FetchCount -> Bool lessFetchCount _ FetchAll = True lessFetchCount i (FetchAtLeast j) = i < fromIntegral j + -- | Like 'executeRequest' but with provided 'Manager'. executeRequestWithMgr :: (AuthMethod am, ParseResponse mt a) @@ -213,26 +215,38 @@ executeRequestWithMgr -> am -> GenRequest mt rw a -> IO (Either Error a) -executeRequestWithMgr mgr auth req = runExceptT $ do +executeRequestWithMgr mgr auth req = + fmap (fmap responseBody) (executeRequestWithMgrAndRes mgr auth req) + +-- | Execute request and return the last received 'HTTP.Response'. +-- +-- @since 0.24 +executeRequestWithMgrAndRes + :: (AuthMethod am, ParseResponse mt a) + => Manager + -> am + -> GenRequest mt rw a + -> IO (Either Error (HTTP.Response a)) +executeRequestWithMgrAndRes mgr auth req = runExceptT $ do httpReq <- makeHttpRequest (Just auth) req performHttpReq httpReq req where - httpLbs' :: HTTP.Request -> ExceptT Error IO (Response LBS.ByteString) + httpLbs' :: HTTP.Request -> ExceptT Error IO (HTTP.Response LBS.ByteString) httpLbs' req' = lift (httpLbs req' mgr) `catch` onHttpException - performHttpReq :: forall rw mt b. ParseResponse mt b => HTTP.Request -> GenRequest mt rw b -> ExceptT Error IO b + performHttpReq :: forall rw mt b. ParseResponse mt b => HTTP.Request -> GenRequest mt rw b -> ExceptT Error IO (HTTP.Response b) performHttpReq httpReq Query {} = do res <- httpLbs' httpReq - unTagged (parseResponse httpReq res :: Tagged mt (ExceptT Error IO b)) + (<$ res) <$> unTagged (parseResponse httpReq res :: Tagged mt (ExceptT Error IO b)) performHttpReq httpReq (PagedQuery _ _ l) = - unTagged (performPagedRequest httpLbs' predicate httpReq :: Tagged mt (ExceptT Error IO b)) + unTagged (performPagedRequest httpLbs' predicate httpReq :: Tagged mt (ExceptT Error IO (HTTP.Response b))) where predicate v = lessFetchCount (V.length v) l performHttpReq httpReq (Command _ _ _) = do res <- httpLbs' httpReq - unTagged (parseResponse httpReq res :: Tagged mt (ExceptT Error IO b)) + (<$ res) <$> unTagged (parseResponse httpReq res :: Tagged mt (ExceptT Error IO b)) -- | Like 'executeRequest' but without authentication. executeRequest' :: ParseResponse mt a => GenRequest mt 'RO a -> IO (Either Error a) @@ -246,21 +260,7 @@ executeRequestWithMgr' => Manager -> GenRequest mt 'RO a -> IO (Either Error a) -executeRequestWithMgr' mgr req = runExceptT $ do - httpReq <- makeHttpRequest (Nothing :: Maybe Auth) req - performHttpReq httpReq req - where - httpLbs' :: HTTP.Request -> ExceptT Error IO (Response LBS.ByteString) - httpLbs' req' = lift (httpLbs req' mgr) `catch` onHttpException - - performHttpReq :: forall mt b. ParseResponse mt b => HTTP.Request -> GenRequest mt 'RO b -> ExceptT Error IO b - performHttpReq httpReq Query {} = do - res <- httpLbs' httpReq - unTagged (parseResponse httpReq res :: Tagged mt (ExceptT Error IO b)) - performHttpReq httpReq (PagedQuery _ _ l) = - unTagged (performPagedRequest httpLbs' predicate httpReq :: Tagged mt (ExceptT Error IO b)) - where - predicate v = lessFetchCount (V.length v) l +executeRequestWithMgr' mgr = executeRequestWithMgr mgr () -- | Helper for picking between 'executeRequest' and 'executeRequest''. -- @@ -302,9 +302,9 @@ class Accept mt => ParseResponse (mt :: MediaType *) a where -- | Parse API response. -- -- @ --- parseResponse :: 'FromJSON' a => 'Response' 'LBS.ByteString' -> 'Either' 'Error' a +-- parseResponse :: 'FromJSON' a => 'HTTP.Response' 'LBS.ByteString' -> 'Either' 'Error' a -- @ -parseResponseJSON :: (FromJSON a, MonadError Error m) => Response LBS.ByteString -> m a +parseResponseJSON :: (FromJSON a, MonadError Error m) => HTTP.Response LBS.ByteString -> m a parseResponseJSON res = case eitherDecode (responseBody res) of Right x -> return x Left err -> throwError . ParseError . T.pack $ err @@ -349,9 +349,9 @@ instance b ~ URI => ParseResponse 'MtRedirect b where -- | Helper for handling of 'RequestRedirect'. -- -- @ --- parseRedirect :: 'Response' 'LBS.ByteString' -> 'Either' 'Error' a +-- parseRedirect :: 'HTTP.Response' 'LBS.ByteString' -> 'Either' 'Error' a -- @ -parseRedirect :: MonadError Error m => URI -> Response LBS.ByteString -> m URI +parseRedirect :: MonadError Error m => URI -> HTTP.Response LBS.ByteString -> m URI parseRedirect originalUri rsp = do let status = responseStatus rsp when (statusCode status /= 302) $ @@ -501,7 +501,7 @@ makeHttpRequest auth r = case r of setBody body req = req { requestBody = RequestBodyLBS body } -- | Query @Link@ header with @rel=next@ from the request headers. -getNextUrl :: Response a -> Maybe URI +getNextUrl :: HTTP.Response a -> Maybe URI getNextUrl req = do linkHeader <- lookup "Link" (responseHeaders req) links <- parseLinkHeaderBS linkHeader @@ -516,25 +516,27 @@ getNextUrl req = do -- | Helper for making paginated requests. Responses, @a@ are combined monoidally. -- +-- The result is wrapped in the last received 'HTTP.Response'. +-- -- @ -- performPagedRequest :: ('FromJSON' a, 'Semigroup' a) --- => ('HTTP.Request' -> 'ExceptT' 'Error' 'IO' ('Response' 'LBS.ByteString')) +-- => ('HTTP.Request' -> 'ExceptT' 'Error' 'IO' ('HTTP.Response' 'LBS.ByteString')) -- -> (a -> 'Bool') -- -> 'HTTP.Request' --- -> 'ExceptT' 'Error' 'IO' a +-- -> 'ExceptT' 'Error' 'IO' ('HTTP.Response' a) -- @ performPagedRequest :: forall a m mt. (ParseResponse mt a, Semigroup a, MonadCatch m, MonadError Error m) - => (HTTP.Request -> m (Response LBS.ByteString)) -- ^ `httpLbs` analogue - -> (a -> Bool) -- ^ predicate to continue iteration - -> HTTP.Request -- ^ initial request - -> Tagged mt (m a) + => (HTTP.Request -> m (HTTP.Response LBS.ByteString)) -- ^ `httpLbs` analogue + -> (a -> Bool) -- ^ predicate to continue iteration + -> HTTP.Request -- ^ initial request + -> Tagged mt (m (HTTP.Response a)) performPagedRequest httpLbs' predicate initReq = Tagged $ do res <- httpLbs' initReq m <- unTagged (parseResponse initReq res :: Tagged mt (m a)) go m res initReq where - go :: a -> Response LBS.ByteString -> HTTP.Request -> m a + go :: a -> HTTP.Response LBS.ByteString -> HTTP.Request -> m (HTTP.Response a) go acc res req = case (predicate acc, getNextUrl res) of (True, Just uri) -> do @@ -542,7 +544,7 @@ performPagedRequest httpLbs' predicate initReq = Tagged $ do res' <- httpLbs' req' m <- unTagged (parseResponse req' res' :: Tagged mt (m a)) go (acc <> m) res' req' - (_, _) -> return acc + (_, _) -> return (acc <$ res) ------------------------------------------------------------------------------- -- Internal