Merge pull request haskell-github#421 from phadej/execute-with-req

phadej · web-flow · commit 09e17083a205 · 2019-12-20T16:08:03.000+02:00
Add executeRequestWithMgrAndRes
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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,33 +207,46 @@ 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)
     => Manager
     -> 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,33 +516,35 @@ 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
                 req' <- HTTP.setUri req uri
                 res' <- httpLbs' req'
                 m <- unTagged (parseResponse req' res' :: Tagged mt (m a))
                 go (acc <> m) res' req'
-            (_, _)           -> return acc
+            (_, _)           -> return (acc <$ res)
 
 -------------------------------------------------------------------------------
 -- Internal
