github-rest 1.0.3 → 1.1.0

raw patch · 15 files changed

+462/−375 lines, 15 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• README.md +1/−1
• github-rest.cabal +3/−3
• src/GitHub/REST.hs +35/−28
• src/GitHub/REST/Auth.hs +23/−20
• src/GitHub/REST/Endpoint.hs +24/−22
• src/GitHub/REST/KeyValue.hs +11/−10
• src/GitHub/REST/Monad.hs +135/−79
• src/GitHub/REST/Monad/Class.hs +57/−65
• src/GitHub/REST/PageLinks.hs +32/−27
• test/Endpoint.hs +15/−14
• test/Main.hs +10/−7
• test/MockQuery.hs +79/−75
• test/PageLinks.hs +10/−7
• test/Query.hs +20/−17

@@ -1,5 +1,12 @@ ## Upcoming +## 1.1.0++* Rename `GitHubState` to `GitHubSettings`+* Remove `queryGitHubPage'` -- implement `queryGitHubPage` in `MonadGitHubREST` instead.+* Expose `queryGitHubPageIO` if users want to manually implement `MonadGitHubREST`+* Add `DecodeError` error+ ## 1.0.3  * Fix goldens after GitHub changed documentation URL

@@ -23,7 +23,7 @@ default (Text)  main = do-  let state = GitHubState+  let state = GitHubSettings         { token = Nothing           -- ^ An authentication token to use, if any.         , userAgent = "alice/my-project"

@@ -1,13 +1,13 @@ cabal-version: >= 1.10 --- This file has been generated from package.yaml by hpack version 0.33.0.+-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack ----- hash: 9626757e084e5f6d0d88ae12dee832d693aa6ae2dea9283634eb783be14cfe9f+-- hash: 800fa4f169210c967d917bacbc61e12d696ad192e8744af6798c68552fd8c05c  name:           github-rest-version:        1.0.3+version:        1.1.0 synopsis:       Query the GitHub REST API programmatically description:    Query the GitHub REST API programmatically, which can provide a more                 flexible and clear interface than if all of the endpoints and their types

@@ -1,4 +1,4 @@-{-|+{- | Module      :  GitHub.REST Maintainer  :  Brandon Chinn <brandon@leapyear.io> Stability   :  experimental@@ -6,38 +6,44 @@  Definitions for querying the GitHub REST API. See README.md for an example. -}--module GitHub.REST-  (+module GitHub.REST (   -- * Monad transformer and type-class for querying the GitHub REST API-    MonadGitHubREST(..)-  , GitHubT-  , GitHubState(..)-  , runGitHubT+  MonadGitHubREST (..),+  GitHubT,+  GitHubSettings (..),+  runGitHubT,+   -- * GitHub authentication-  , Token(..)+  Token (..),+   -- * GitHub Endpoints-  , GHEndpoint(..)-  , GitHubData-  , EndpointVals+  GHEndpoint (..),+  GitHubData,+  EndpointVals,+   -- * KeyValue pairs-  , KeyValue(..)+  KeyValue (..),+   -- * Helpers-  , githubTry-  , githubTry'-  , (.:)+  githubTry,+  githubTry',+  (.:),+   -- * Re-exports-  , StdMethod(..)-  ) where+  StdMethod (..),+) where  import Control.Monad.IO.Unlift (MonadUnliftIO)-import Data.Aeson (FromJSON, Value(..), decode, withObject)+import Data.Aeson (FromJSON, Value (..), decode, withObject) import Data.Aeson.Types (parseEither, parseField) import qualified Data.ByteString.Lazy as ByteStringL import Data.Text (Text)-import Network.HTTP.Client-    (HttpException(..), HttpExceptionContent(..), Response(..))-import Network.HTTP.Types (Status, StdMethod(..), status422)+import Network.HTTP.Client (+  HttpException (..),+  HttpExceptionContent (..),+  Response (..),+ )+import Network.HTTP.Types (Status, StdMethod (..), status422) import UnliftIO.Exception (handleJust)  import GitHub.REST.Auth@@ -47,12 +53,13 @@  {- HTTP exception handling -} --- | Handle 422 exceptions thrown by the GitHub REST API.------ Most client errors are 422, since we should always be sending valid JSON. If an endpoint--- throws different error codes, use githubTry'.------ https://developer.github.com/v3/#client-errors+{- | Handle 422 exceptions thrown by the GitHub REST API.++ Most client errors are 422, since we should always be sending valid JSON. If an endpoint+ throws different error codes, use githubTry'.++ https://developer.github.com/v3/#client-errors+-} githubTry :: MonadUnliftIO m => m a -> m (Either Value a) githubTry = githubTry' status422 

@@ -1,4 +1,8 @@-{-|+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++{- | Module      :  GitHub.REST.Auth Maintainer  :  Brandon Chinn <brandon@leapyear.io> Stability   :  experimental@@ -6,20 +10,18 @@  Definitions for handling authentication with the GitHub REST API. -}-{-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}+module GitHub.REST.Auth (+  Token (..),+  fromToken, -module GitHub.REST.Auth-  ( Token(..)-  , fromToken   -- * Helpers for using JWT tokens with the GitHub API-  , getJWTToken-  , loadSigner-  ) where+  getJWTToken,+  loadSigner,+) where  import Data.ByteString (ByteString) import qualified Data.ByteString as ByteString+ #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif@@ -31,10 +33,10 @@  -- | The token to use to authenticate with GitHub. data Token-  = AccessToken ByteString-    -- ^ https://developer.github.com/v3/#authentication-  | BearerToken ByteString-    -- ^ https://developer.github.com/apps/building-github-apps/authenticating-with-github-apps/#authenticating-as-a-github-app+  = -- | https://developer.github.com/v3/#authentication+    AccessToken ByteString+  | -- | https://developer.github.com/apps/building-github-apps/authenticating-with-github-apps/#authenticating-as-a-github-app+    BearerToken ByteString   deriving (Show)  fromToken :: Token -> ByteString@@ -55,12 +57,13 @@     signToken = JWT.encodeSigned #endif     mkToken now =-      let claims = mempty-            { JWT.iat = JWT.numericDate $ utcTimeToPOSIXSeconds now-            , JWT.exp = JWT.numericDate $ utcTimeToPOSIXSeconds now + (10 * 60)-            , JWT.iss = JWT.stringOrURI $ Text.pack $ show appId-            }-      in BearerToken . Text.encodeUtf8 $ signToken signer claims+      let claims =+            mempty+              { JWT.iat = JWT.numericDate $ utcTimeToPOSIXSeconds now+              , JWT.exp = JWT.numericDate $ utcTimeToPOSIXSeconds now + (10 * 60)+              , JWT.iss = JWT.stringOrURI $ Text.pack $ show appId+              }+       in BearerToken . Text.encodeUtf8 $ signToken signer claims     -- lose a second in the case of rounding     -- https://github.community/t5/GitHub-API-Development-and/quot-Expiration-time-claim-exp-is-too-far-in-the-future-quot/m-p/20457/highlight/true#M1127     getNow = addUTCTime (-1) <$> getCurrentTime

@@ -1,4 +1,8 @@-{-|+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++{- | Module      :  GitHub.REST.Endpoint Maintainer  :  Brandon Chinn <brandon@leapyear.io> Stability   :  experimental@@ -6,19 +10,16 @@  Define the 'GHEndpoint' helper type for defining a call to a GitHub API endpoint. -}-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}--module GitHub.REST.Endpoint-  ( GHEndpoint(..)-  , EndpointVals-  , GitHubData-  , endpointPath-  , renderMethod-  ) where+module GitHub.REST.Endpoint (+  GHEndpoint (..),+  EndpointVals,+  GitHubData,+  endpointPath,+  renderMethod,+) where  import Data.Maybe (fromMaybe)+ #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif@@ -33,16 +34,16 @@  -- | A call to a GitHub API endpoint. data GHEndpoint = GHEndpoint-  { method       :: StdMethod-  , endpoint     :: Text-    -- ^ The GitHub API endpoint, with colon-prefixed components that will be replaced; e.g.+  { method :: StdMethod+  , -- | The GitHub API endpoint, with colon-prefixed components that will be replaced; e.g.     -- @"\/users\/:username\/repos"@-  , endpointVals :: EndpointVals-    -- ^ Key-value pairs to replace colon-prefixed components in 'endpoint'; e.g.+    endpoint :: Text+  , -- | Key-value pairs to replace colon-prefixed components in 'endpoint'; e.g.     -- @[ "username" := ("alice" :: Text) ]@-  , ghData       :: GitHubData-    -- ^ Key-value pairs to send in the request body; e.g.+    endpointVals :: EndpointVals+  , -- | Key-value pairs to send in the request body; e.g.     -- @[ "sort" := ("created" :: Text), "direction" := ("asc" :: Text) ]@+    ghData :: GitHubData   }  -- | Return the endpoint path, populated by the values in 'endpointVals'.@@ -51,9 +52,10 @@   where     values = map kvToText endpointVals     populate t = case Text.uncons t of-      Just (':', key) -> fromMaybe-        (fail' $ "Could not find value for key '" <> key <> "'")-        $ lookup key values+      Just (':', key) ->+        fromMaybe+          (fail' $ "Could not find value for key '" <> key <> "'")+          $ lookup key values       _ -> t     fail' msg = error . Text.unpack $ msg <> ": " <> endpoint 

@@ -1,4 +1,7 @@-{-|+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}++{- | Module      :  GitHub.REST.KeyValue Maintainer  :  Brandon Chinn <brandon@leapyear.io> Stability   :  experimental@@ -6,16 +9,13 @@  Define the 'KeyValue' helper type. -}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}--module GitHub.REST.KeyValue-  ( KeyValue(..)-  , kvToValue-  , kvToText-  ) where+module GitHub.REST.KeyValue (+  KeyValue (..),+  kvToValue,+  kvToText,+) where -import Data.Aeson (ToJSON(..), Value(..), object)+import Data.Aeson (ToJSON (..), Value (..), object) import Data.Aeson.Types (Pair) import Data.Scientific (floatingOrInteger) import Data.Text (Text)@@ -24,6 +24,7 @@ -- | A type representing a key-value pair. data KeyValue where   (:=) :: (Show v, ToJSON v) => Text -> v -> KeyValue+ infixr 1 :=  instance Show KeyValue where

@@ -1,4 +1,11 @@-{-|+{-# LANGUAGE CPP #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}++{- | Module      :  GitHub.REST.Monad Maintainer  :  Brandon Chinn <brandon@leapyear.io> Stability   :  experimental@@ -7,67 +14,142 @@ Defines 'GitHubT' and 'MonadGitHubREST', a monad transformer and type class that gives a monad @m@ the capability to query the GitHub REST API. -}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TupleSections #-}+module GitHub.REST.Monad (+  -- * MonadGitHubREST API+  MonadGitHubREST (..),+  queryGitHubPageIO, -module GitHub.REST.Monad-  ( MonadGitHubREST(..)-  , GitHubT-  , GitHubState(..)-  , runGitHubT-  ) where+  -- * GitHubManager+  GitHubManager,+  initGitHubManager, -#if !MIN_VERSION_base(4,13,0)-import Control.Monad.Fail (MonadFail)-#endif-import Control.Monad.IO.Class (MonadIO(..))-import Control.Monad.IO.Unlift (MonadUnliftIO(..))+  -- * GitHubSettings+  GitHubSettings (..),++  -- * GitHubT+  GitHubT,+  runGitHubT,+) where++import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.IO.Unlift (MonadUnliftIO (..)) import Control.Monad.Reader (ReaderT, ask, runReaderT) import Control.Monad.Trans (MonadTrans)-import Data.Aeson (eitherDecode, encode)+import Data.Aeson (FromJSON, eitherDecode, encode) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as ByteStringL-#if !MIN_VERSION_base(4,11,0)-import Data.Monoid ((<>))-#endif+import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text-import Network.HTTP.Client-    ( Manager-    , Request(..)-    , RequestBody(..)-    , Response(..)-    , httpLbs-    , newManager-    , parseRequest_-    , throwErrorStatusCodes-    )+import Network.HTTP.Client (+  Manager,+  Request (..),+  RequestBody (..),+  Response (..),+  httpLbs,+  newManager,+  parseRequest_,+  throwErrorStatusCodes,+ ) import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.HTTP.Types (hAccept, hAuthorization, hUserAgent)+import UnliftIO.Exception (Exception, throwIO) +#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail (MonadFail)+#endif+#if !MIN_VERSION_base(4,11,0)+import Data.Monoid ((<>))+#endif+ import GitHub.REST.Auth (Token, fromToken)-import GitHub.REST.Endpoint (GHEndpoint(..), endpointPath, renderMethod)+import GitHub.REST.Endpoint (GHEndpoint (..), endpointPath, renderMethod) import GitHub.REST.KeyValue (kvToValue) import GitHub.REST.Monad.Class-import GitHub.REST.PageLinks (parsePageLinks)+import GitHub.REST.PageLinks (PageLinks, parsePageLinks) -data GitHubState = GitHubState-  { token      :: Maybe Token-    -- ^ The token to use to authenticate with the API.-  , userAgent  :: ByteString-    -- ^ The user agent to use when interacting with the API: https://developer.github.com/v3/#user-agent-required-  , apiVersion :: ByteString-    -- ^ The media type will be sent as: application/vnd.github.VERSION+json. For the standard+{- GitHubSettings -}++data GitHubSettings = GitHubSettings+  { -- | The token to use to authenticate with the API.+    token :: Maybe Token+  , -- | The user agent to use when interacting with the API: https://developer.github.com/v3/#user-agent-required+    userAgent :: ByteString+  , -- | The media type will be sent as: application/vnd.github.VERSION+json. For the standard     -- API endpoints, "v3" should be sufficient here. See https://developer.github.com/v3/media/+    apiVersion :: ByteString   } +{- GitHubManager -}++data GitHubManager = GitHubManager+  { ghSettings :: GitHubSettings+  , ghManager :: Manager+  }++-- | Initialize a 'GitHubManager'.+initGitHubManager :: GitHubSettings -> IO GitHubManager+initGitHubManager ghSettings = do+  ghManager <- newManager tlsManagerSettings+  return GitHubManager{..}++{- | Same as 'queryGitHubPage', except explicitly taking in 'GitHubManager' and running+ in IO.++ Useful for implementing 'MonadGitHubREST' outside of 'GitHubT'.+-}+queryGitHubPageIO :: FromJSON a => GitHubManager -> GHEndpoint -> IO (a, PageLinks)+queryGitHubPageIO GitHubManager{..} ghEndpoint = do+  let GitHubSettings{..} = ghSettings++  let request =+        (parseRequest_ $ Text.unpack $ ghUrl <> endpointPath ghEndpoint)+          { method = renderMethod ghEndpoint+          , requestHeaders =+              [ (hAccept, "application/vnd.github." <> apiVersion <> "+json")+              , (hUserAgent, userAgent)+              ]+                ++ maybe [] ((: []) . (hAuthorization,) . fromToken) token+          , requestBody = RequestBodyLBS $ encode $ kvToValue $ ghData ghEndpoint+          , checkResponse = throwErrorStatusCodes+          }++  response <- httpLbs request ghManager++  let body = responseBody response+      -- empty body always errors when decoding, even if the end user doesn't care about the+      -- result, like creating a branch, when the endpoint doesn't return anything.+      --+      -- In this case, pretend like the server sent back an encoded version of the unit type,+      -- so that `queryGitHub endpoint` would be typed to `m ()`.+      nonEmptyBody = if ByteStringL.null body then encode () else body+      pageLinks = maybe mempty parsePageLinks . lookupHeader "Link" $ response++  case eitherDecode nonEmptyBody of+    Right payload -> return (payload, pageLinks)+    Left e ->+      throwIO $+        DecodeError+          { decodeErrorMessage = Text.pack e+          , decodeErrorResponse = Text.decodeUtf8 $ ByteStringL.toStrict body+          }+  where+    ghUrl = "https://api.github.com"+    lookupHeader headerName = fmap Text.decodeUtf8 . lookup headerName . responseHeaders++data DecodeError = DecodeError+  { decodeErrorMessage :: Text+  , decodeErrorResponse :: Text+  }+  deriving (Show)++instance Exception DecodeError++{- GitHubT -}+ -- | A simple monad that can run REST calls. newtype GitHubT m a = GitHubT-  { unGitHubT :: ReaderT (Manager, GitHubState) m a+  { unGitHubT :: ReaderT GitHubManager m a   }   deriving     ( Functor@@ -84,42 +166,16 @@       inner (run . unGitHubT)  instance MonadIO m => MonadGitHubREST (GitHubT m) where-  queryGitHubPage' ghEndpoint = do-    (manager, GitHubState{..}) <- GitHubT ask--    let request = (parseRequest_ $ Text.unpack $ ghUrl <> endpointPath ghEndpoint)-          { method = renderMethod ghEndpoint-          , requestHeaders =-              [ (hAccept, "application/vnd.github." <> apiVersion <> "+json")-              , (hUserAgent, userAgent)-              ] ++ maybe [] ((:[]) . (hAuthorization,) . fromToken) token-          , requestBody = RequestBodyLBS $ encode $ kvToValue $ ghData ghEndpoint-          , checkResponse = throwErrorStatusCodes-          }--    response <- liftIO $ httpLbs request manager--    let body = responseBody response-        -- empty body always errors when decoding, even if the end user doesn't care about the-        -- result, like creating a branch, when the endpoint doesn't return anything.-        ---        -- In this case, pretend like the server sent back an encoded version of the unit type,-        -- so that `queryGitHub endpoint` would be typed to `m ()`.-        nonEmptyBody = if ByteStringL.null body then encode () else body-        pageLinks = maybe mempty parsePageLinks . lookupHeader "Link" $ response+  queryGitHubPage ghEndpoint = do+    manager <- GitHubT ask+    liftIO $ queryGitHubPageIO manager ghEndpoint -    return $ case eitherDecode nonEmptyBody of-      Right payload -> Right (payload, pageLinks)-      Left e -> Left (Text.pack e, Text.decodeUtf8 $ ByteStringL.toStrict body)-    where-      ghUrl = "https://api.github.com"-      lookupHeader headerName = fmap Text.decodeUtf8 . lookup headerName . responseHeaders+{- | Run the given 'GitHubT' action with the given token and user agent. --- | Run the given 'GitHubT' action with the given token and user agent.------ The token will be sent with each API request -- see 'Token'. The user agent is also required for--- each API request -- see https://developer.github.com/v3/#user-agent-required.-runGitHubT :: MonadIO m => GitHubState -> GitHubT m a -> m a-runGitHubT state action = do-  manager <- liftIO $ newManager tlsManagerSettings-  (`runReaderT` (manager, state)) . unGitHubT $ action+ The token will be sent with each API request -- see 'Token'. The user agent is also required for+ each API request -- see https://developer.github.com/v3/#user-agent-required.+-}+runGitHubT :: MonadIO m => GitHubSettings -> GitHubT m a -> m a+runGitHubT settings action = do+  manager <- liftIO $ initGitHubManager settings+  (`runReaderT` manager) . unGitHubT $ action

@@ -1,4 +1,7 @@-{-|+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeApplications #-}++{- | Module      :  GitHub.REST.Monad.Class Maintainer  :  Brandon Chinn <brandon@leapyear.io> Stability   :  experimental@@ -6,84 +9,73 @@  Defines 'MonadGitHubREST' that gives a monad @m@ the capability to query the GitHub REST API. -}-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeApplications #-}--module GitHub.REST.Monad.Class-  ( MonadGitHubREST(..)-  ) where+module GitHub.REST.Monad.Class (+  MonadGitHubREST (..),+) where -import Control.Monad (void, (<=<))+import Control.Monad (void) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (ExceptT) import Control.Monad.Trans.Identity (IdentityT) import Control.Monad.Trans.Maybe (MaybeT)-import Control.Monad.Trans.Reader (ReaderT) import qualified Control.Monad.Trans.RWS.Lazy as Lazy import qualified Control.Monad.Trans.RWS.Strict as Strict+import Control.Monad.Trans.Reader (ReaderT) import qualified Control.Monad.Trans.State.Lazy as Lazy import qualified Control.Monad.Trans.State.Strict as Strict import qualified Control.Monad.Trans.Writer.Lazy as Lazy import qualified Control.Monad.Trans.Writer.Strict as Strict import Data.Aeson (FromJSON, Value)+ #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif-import Data.Text (Text)-import qualified Data.Text as Text  import GitHub.REST.Endpoint-import GitHub.REST.PageLinks (PageLinks(..))+import GitHub.REST.PageLinks (PageLinks (..)) --- | A type class for monads that can query the GitHub REST API.------ Example:------ > -- create the "foo" branch--- > queryGitHub GHEndpoint--- >   { method = POST--- >   , endpoint = "/repos/:owner/:repo/git/refs"--- >   , endpointVals =--- >     [ "owner" := "alice"--- >     , "repo" := "my-project"--- >     ]--- >   , ghData =--- >     [ "ref" := "refs/heads/foo"--- >     , "sha" := "1234567890abcdef"--- >     ]--- >   }------ It's recommended that you create functions for the API endpoints you're using:------ > deleteBranch branch = queryGitHub GHEndpoint--- >   { method = DELETE--- >   , endpoint = "/repos/:owner/:repo/git/refs/:ref"--- >   , endpointVals =--- >     [ "owner" := "alice"--- >     , "repo" := "my-project"--- >     , "ref" := "heads/" <> branch--- >     ]--- >   , ghData = []--- >   }+{- | A type class for monads that can query the GitHub REST API.++ Example:++ > -- create the "foo" branch+ > queryGitHub GHEndpoint+ >   { method = POST+ >   , endpoint = "/repos/:owner/:repo/git/refs"+ >   , endpointVals =+ >     [ "owner" := "alice"+ >     , "repo" := "my-project"+ >     ]+ >   , ghData =+ >     [ "ref" := "refs/heads/foo"+ >     , "sha" := "1234567890abcdef"+ >     ]+ >   }++ It's recommended that you create functions for the API endpoints you're using:++ > deleteBranch branch = queryGitHub GHEndpoint+ >   { method = DELETE+ >   , endpoint = "/repos/:owner/:repo/git/refs/:ref"+ >   , endpointVals =+ >     [ "owner" := "alice"+ >     , "repo" := "my-project"+ >     , "ref" := "heads/" <> branch+ >     ]+ >   , ghData = []+ >   }+-} class Monad m => MonadGitHubREST m where-  {-# MINIMAL queryGitHubPage' #-}+  {-# MINIMAL queryGitHubPage #-} -  -- | Query GitHub, returning @Right (payload, links)@ if successful, where @payload@ is the+  -- | Query GitHub, returning @(payload, links)@ if successful, where @payload@ is the   -- response that GitHub sent back and @links@ containing any pagination links GitHub may have   -- sent back. If the response could not be decoded as JSON, returns   -- @Left (error message, response from server)@.   ---  -- Errors on network connection failures or if GitHub sent back an error message. Use `githubTry`-  -- if you wish to handle GitHub errors.-  queryGitHubPage' :: FromJSON a => GHEndpoint -> m (Either (Text, Text) (a, PageLinks))--  -- | 'queryGitHubPage'', except calls 'fail' if JSON decoding fails.+  -- Errors on network connection failures, if GitHub sent back an error message, or if the response+  -- could not be decoded as JSON. Use `githubTry` if you wish to handle GitHub errors.   queryGitHubPage :: FromJSON a => GHEndpoint -> m (a, PageLinks)-  queryGitHubPage = either fail' pure <=< queryGitHubPage'-    where-      fail' (message, response) =-        let ellipses s = if Text.length s > 100 then take 100 (Text.unpack s) ++ "..." else Text.unpack s-        in error $ "Could not decode response:\nmessage = " ++ ellipses message ++ "\nresponse = " ++ ellipses response    -- | 'queryGitHubPage', except ignoring pagination links.   queryGitHub :: FromJSON a => GHEndpoint -> m a@@ -96,7 +88,7 @@     (payload, pageLinks) <- queryGitHubPage ghEndpoint     case pageNext pageLinks of       Just next -> do-        rest <- queryGitHubAll ghEndpoint { endpoint = next, endpointVals = [] }+        rest <- queryGitHubAll ghEndpoint{endpoint = next, endpointVals = []}         return $ payload <> rest       Nothing -> return payload @@ -107,31 +99,31 @@ {- Instances for common monad transformers -}  instance MonadGitHubREST m => MonadGitHubREST (ReaderT r m) where-  queryGitHubPage' = lift . queryGitHubPage'+  queryGitHubPage = lift . queryGitHubPage  instance MonadGitHubREST m => MonadGitHubREST (ExceptT e m) where-  queryGitHubPage' = lift . queryGitHubPage'+  queryGitHubPage = lift . queryGitHubPage  instance MonadGitHubREST m => MonadGitHubREST (IdentityT m) where-  queryGitHubPage' = lift . queryGitHubPage'+  queryGitHubPage = lift . queryGitHubPage  instance MonadGitHubREST m => MonadGitHubREST (MaybeT m) where-  queryGitHubPage' = lift . queryGitHubPage'+  queryGitHubPage = lift . queryGitHubPage  instance (Monoid w, MonadGitHubREST m) => MonadGitHubREST (Lazy.RWST r w s m) where-  queryGitHubPage' = lift . queryGitHubPage'+  queryGitHubPage = lift . queryGitHubPage  instance (Monoid w, MonadGitHubREST m) => MonadGitHubREST (Strict.RWST r w s m) where-  queryGitHubPage' = lift . queryGitHubPage'+  queryGitHubPage = lift . queryGitHubPage  instance MonadGitHubREST m => MonadGitHubREST (Lazy.StateT s m) where-  queryGitHubPage' = lift . queryGitHubPage'+  queryGitHubPage = lift . queryGitHubPage  instance MonadGitHubREST m => MonadGitHubREST (Strict.StateT s m) where-  queryGitHubPage' = lift . queryGitHubPage'+  queryGitHubPage = lift . queryGitHubPage  instance (Monoid w, MonadGitHubREST m) => MonadGitHubREST (Lazy.WriterT w m) where-  queryGitHubPage' = lift . queryGitHubPage'+  queryGitHubPage = lift . queryGitHubPage  instance (Monoid w, MonadGitHubREST m) => MonadGitHubREST (Strict.WriterT w m) where-  queryGitHubPage' = lift . queryGitHubPage'+  queryGitHubPage = lift . queryGitHubPage

@@ -1,34 +1,38 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -module GitHub.REST.PageLinks-  ( PageLinks(..)-  , parsePageLinks-  ) where+module GitHub.REST.PageLinks (+  PageLinks (..),+  parsePageLinks,+) where  import Data.Maybe (fromMaybe)+ #if !MIN_VERSION_base(4,11,0) import Data.Semigroup (Semigroup(..)) #endif import Data.Text (Text) import qualified Data.Text as Text --- | Helper type for GitHub pagination.------ https://developer.github.com/v3/guides/traversing-with-pagination/+{- | Helper type for GitHub pagination.++ https://developer.github.com/v3/guides/traversing-with-pagination/+-} data PageLinks = PageLinks   { pageFirst :: Maybe Text-  , pagePrev  :: Maybe Text-  , pageNext  :: Maybe Text-  , pageLast  :: Maybe Text-  } deriving (Eq,Show)+  , pagePrev :: Maybe Text+  , pageNext :: Maybe Text+  , pageLast :: Maybe Text+  }+  deriving (Eq, Show)  instance Semigroup PageLinks where-  links1 <> links2 = PageLinks-    (pageFirst links1 <> pageFirst links2)-    (pagePrev links1 <> pagePrev links2)-    (pageNext links1 <> pageNext links2)-    (pageLast links1 <> pageLast links2)+  links1 <> links2 =+    PageLinks+      (pageFirst links1 <> pageFirst links2)+      (pagePrev links1 <> pagePrev links2)+      (pageNext links1 <> pageNext links2)+      (pageLast links1 <> pageLast links2)  instance Monoid PageLinks where   mempty = PageLinks Nothing Nothing Nothing Nothing@@ -44,18 +48,19 @@     resolve pageLinks "" = pageLinks     resolve pageLinks link =       let (rel, url) = parsePageLink link-      in case rel of-        "first" -> pageLinks { pageFirst = Just url }-        "prev" -> pageLinks { pagePrev = Just url }-        "next" -> pageLinks { pageNext = Just url }-        "last" -> pageLinks { pageLast = Just url }-        _ -> error $ "Unknown rel in page link: " ++ show link+       in case rel of+            "first" -> pageLinks{pageFirst = Just url}+            "prev" -> pageLinks{pagePrev = Just url}+            "next" -> pageLinks{pageNext = Just url}+            "last" -> pageLinks{pageLast = Just url}+            _ -> error $ "Unknown rel in page link: " ++ show link --- | Parse a single page link, like:------ <https://api.github.com/search/code?q=addClass+user%3Amozilla&page=2>; rel="next"------ Returns ("next", "/search/code?q=addClass+user%3Amozilla&page=2")+{- | Parse a single page link, like:++ <https://api.github.com/search/code?q=addClass+user%3Amozilla&page=2>; rel="next"++ Returns ("next", "/search/code?q=addClass+user%3Amozilla&page=2")+-} parsePageLink :: Text -> (Text, Text) parsePageLink link = fromMaybe (error $ "Unknown page link: " ++ show link) $ do   (linkUrl, linkRel) <- case split ";" link of

@@ -8,27 +8,27 @@ import Data.Function (on) import Data.List (nubBy) import Data.Maybe (fromMaybe)+ #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) import Data.Semigroup (Semigroup) #endif-import Data.String (IsString(..))+import Data.String (IsString (..)) import Data.Text (Text) import qualified Data.Text as Text-import Network.HTTP.Types (StdMethod(..))+import Network.HTTP.Types (StdMethod (..)) import Test.Tasty (TestTree) import Test.Tasty.QuickCheck  import GitHub.REST.Endpoint-import GitHub.REST.KeyValue (KeyValue(..))+import GitHub.REST.KeyValue (KeyValue (..))  tests :: [TestTree] tests =   [ testProperty "endpointPath with no substitutions" $       forAll (listOf genNoSubstitute) $ \endpointComponents ->         let ghEndpoint = mkGHEndpoint endpointComponents []-        in endpointPath ghEndpoint === concatComponents endpointComponents-+         in endpointPath ghEndpoint === concatComponents endpointComponents   , testProperty "endpointPath with substitutions" $       forAll (listOf genNoSubstitute) $ \withoutColons ->         forAll (listOf1 genSubstitute) $ \withColonAndVals' -> do@@ -47,26 +47,27 @@ {- Helpers -}  mkGHEndpoint :: [EndpointComponent] -> EndpointVals -> GHEndpoint-mkGHEndpoint endpointComponents endpointVals = GHEndpoint-  { method = GET-  , endpoint = concatComponents endpointComponents-  , endpointVals-  , ghData = []-  }+mkGHEndpoint endpointComponents endpointVals =+  GHEndpoint+    { method = GET+    , endpoint = concatComponents endpointComponents+    , endpointVals+    , ghData = []+    }  concatComponents :: [EndpointComponent] -> Text concatComponents = ("/" <>) . Text.intercalate "/" . map unComponent  -- | A component in an endpoint path; e.g. does not contain forward slashes.-newtype EndpointComponent = EndpointComponent { unComponent :: Text }-  deriving (Show,Eq,IsString,Monoid,Semigroup)+newtype EndpointComponent = EndpointComponent {unComponent :: Text}+  deriving (Show, Eq, IsString, Monoid, Semigroup)  -- | Generate a non-substitutionable EndpointComponent. genNoSubstitute :: Gen EndpointComponent genNoSubstitute = fmap fromString $ listOf1 $ elements allowedUrlCharacters   where     -- https://stackoverflow.com/a/41353282-    allowedUrlCharacters = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "-_.~"+    allowedUrlCharacters = ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] ++ "-_.~"  -- | Generate a substitutionable EndpointComponent and a value to interpolate. genSubstitute :: Gen (EndpointComponent, EndpointComponent)

@@ -7,10 +7,13 @@ import qualified Query  main :: IO ()-main = defaultMain $ testGroup "github-rest"-  [ testGroup "GitHub.REST (Helpers)" Helpers.tests-  , testGroup "GitHub.REST.Endpoint" Endpoint.tests-  , testGroup "GitHub.REST.Monad.Class" MockQuery.tests-  , testGroup "GitHub.REST.PageLinks" PageLinks.tests-  , testGroup "GitHub.REST (End-to-End)" Query.tests-  ]+main =+  defaultMain $+    testGroup+      "github-rest"+      [ testGroup "GitHub.REST (Helpers)" Helpers.tests+      , testGroup "GitHub.REST.Endpoint" Endpoint.tests+      , testGroup "GitHub.REST.Monad.Class" MockQuery.tests+      , testGroup "GitHub.REST.PageLinks" PageLinks.tests+      , testGroup "GitHub.REST (End-to-End)" Query.tests+      ]

@@ -7,109 +7,113 @@  import Control.Applicative ((<|>)) import Control.Exception (SomeException, try)+ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail (MonadFail) #endif import Control.Monad.State.Strict (StateT, evalStateT, get, put)-import Data.Aeson (Result(..), Value(..), fromJSON)+import Data.Aeson (Result (..), Value (..), fromJSON) import Data.Either (isLeft) import Data.List (uncons) import Data.Maybe (fromMaybe, isJust, isNothing) import Data.Text (Text)+import qualified Data.Text as Text import GHC.Exts (fromList)-import Network.HTTP.Types (StdMethod(..))+import Network.HTTP.Types (StdMethod (..)) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit -import GitHub.REST.Endpoint (GHEndpoint(..))+import GitHub.REST.Endpoint (GHEndpoint (..)) import GitHub.REST.Monad.Class-import GitHub.REST.PageLinks (PageLinks(..))+import GitHub.REST.PageLinks (PageLinks (..))  tests :: [TestTree] tests =-  [ testGroup "queryGitHubPage"-    [ testCase "success single" $ do-        (result, pageLinks) <- runMockREST (queryGitHubPage @_ @Text) [Right "a"]-        result @?= "a"-        isNothing (pageNext pageLinks) @? "PageLinks 'next' rel is not Nothing"-    , testCase "success multiple" $ do-        (result, pageLinks) <- runMockREST (queryGitHubPage @_ @Text) [Right "a", Right "b"]-        result @?= "a"-        isJust (pageNext pageLinks) @? "PageLinks 'next' rel is Nothing"-    , testCase "error single" $ do-        result <- try @SomeException $ runMockREST (queryGitHubPage @_ @Text) [Left "error message!"]-        isLeft result @? "query did not error"-    , testCase "success with error in second page" $ do-        (result, pageLinks) <- runMockREST (queryGitHubPage @_ @Text) [Right "a", Left "error message!"]-        result @?= "a"-        isJust (pageNext pageLinks) @? "PageLinks 'next' rel is Nothing"-    ]--  , testGroup "queryGitHub"-    [ testCase "success single" $ do-        result <- runMockREST (queryGitHub @_ @Text) [Right "a"]-        result @?= "a"-    , testCase "success multiple" $ do-        result <- runMockREST (queryGitHub @_ @Text) [Right "a", Right "b"]-        result @?= "a"-    , testCase "error single" $ do-        result <- try @SomeException $ runMockREST (queryGitHub @_ @Text) [Left "error message!"]-        isLeft result @? "query did not error"-    , testCase "success with error in second page" $ do-        result <- runMockREST (queryGitHub @_ @Text) [Right "a", Left "error message!"]-        result @?= "a"-    ]--  , testGroup "queryGitHubAll"-    [ testCase "success single" $ do-        result <- runMockREST (queryGitHubAll @_ @[Text]) [Right "a"]-        result @?= ["a"]-    , testCase "success multiple" $ do-        result <- runMockREST (queryGitHubAll @_ @[Text]) [Right "a", Right "b"]-        result @?= ["a", "b"]-    , testCase "error single" $ do-        result <- try @SomeException $ runMockREST (queryGitHubAll @_ @[Text]) [Left "error message!"]-        isLeft result @? "query did not error"-    , testCase "error in second page" $ do-        result <- try @SomeException $ runMockREST (queryGitHubAll @_ @[Text]) [Right "a", Left "error message!"]-        isLeft result @? "query did not error"-    ]--  , testGroup "queryGitHub_"-    [ testCase "success single" $-        runMockREST queryGitHub_ [Right "a"]-    , testCase "success multiple" $-        runMockREST queryGitHub_ [Right "a", Right "b"]-    , testCase "error single" $ do-        result <- try @SomeException $ runMockREST queryGitHub_ [Left "error message!"]-        isLeft result @? "query did not error"-    , testCase "success with error in second page" $-        runMockREST queryGitHub_ [Right "a", Left "error message!"]-    ]+  [ testGroup+      "queryGitHubPage"+      [ testCase "success single" $ do+          (result, pageLinks) <- runMockREST (queryGitHubPage @_ @Text) [Right "a"]+          result @?= "a"+          isNothing (pageNext pageLinks) @? "PageLinks 'next' rel is not Nothing"+      , testCase "success multiple" $ do+          (result, pageLinks) <- runMockREST (queryGitHubPage @_ @Text) [Right "a", Right "b"]+          result @?= "a"+          isJust (pageNext pageLinks) @? "PageLinks 'next' rel is Nothing"+      , testCase "error single" $ do+          result <- try @SomeException $ runMockREST (queryGitHubPage @_ @Text) [Left "error message!"]+          isLeft result @? "query did not error"+      , testCase "success with error in second page" $ do+          (result, pageLinks) <- runMockREST (queryGitHubPage @_ @Text) [Right "a", Left "error message!"]+          result @?= "a"+          isJust (pageNext pageLinks) @? "PageLinks 'next' rel is Nothing"+      ]+  , testGroup+      "queryGitHub"+      [ testCase "success single" $ do+          result <- runMockREST (queryGitHub @_ @Text) [Right "a"]+          result @?= "a"+      , testCase "success multiple" $ do+          result <- runMockREST (queryGitHub @_ @Text) [Right "a", Right "b"]+          result @?= "a"+      , testCase "error single" $ do+          result <- try @SomeException $ runMockREST (queryGitHub @_ @Text) [Left "error message!"]+          isLeft result @? "query did not error"+      , testCase "success with error in second page" $ do+          result <- runMockREST (queryGitHub @_ @Text) [Right "a", Left "error message!"]+          result @?= "a"+      ]+  , testGroup+      "queryGitHubAll"+      [ testCase "success single" $ do+          result <- runMockREST (queryGitHubAll @_ @[Text]) [Right "a"]+          result @?= ["a"]+      , testCase "success multiple" $ do+          result <- runMockREST (queryGitHubAll @_ @[Text]) [Right "a", Right "b"]+          result @?= ["a", "b"]+      , testCase "error single" $ do+          result <- try @SomeException $ runMockREST (queryGitHubAll @_ @[Text]) [Left "error message!"]+          isLeft result @? "query did not error"+      , testCase "error in second page" $ do+          result <- try @SomeException $ runMockREST (queryGitHubAll @_ @[Text]) [Right "a", Left "error message!"]+          isLeft result @? "query did not error"+      ]+  , testGroup+      "queryGitHub_"+      [ testCase "success single" $+          runMockREST queryGitHub_ [Right "a"]+      , testCase "success multiple" $+          runMockREST queryGitHub_ [Right "a", Right "b"]+      , testCase "error single" $ do+          result <- try @SomeException $ runMockREST queryGitHub_ [Left "error message!"]+          isLeft result @? "query did not error"+      , testCase "success with error in second page" $+          runMockREST queryGitHub_ [Right "a", Left "error message!"]+      ]   ]  {- Mock implementation -} -newtype MockREST a = MockREST { unMockREST :: StateT [Either Text Text] IO a }-  deriving (Functor,Applicative,Monad,MonadFail)+newtype MockREST a = MockREST {unMockREST :: StateT [Either Text Text] IO a}+  deriving (Functor, Applicative, Monad, MonadFail)  runMockREST :: (GHEndpoint -> MockREST a) -> [Either Text Text] -> IO a runMockREST f results = (`evalStateT` results) $ unMockREST $ f ghEndpoint   where-    ghEndpoint = GHEndpoint-      { method = GET-      , endpoint = "/"-      , endpointVals = []-      , ghData = []-      }+    ghEndpoint =+      GHEndpoint+        { method = GET+        , endpoint = "/"+        , endpointVals = []+        , ghData = []+        }  instance MonadGitHubREST MockREST where-  queryGitHubPage' _ = do+  queryGitHubPage _ = do     (curr, rest) <- fromMaybe (error "Did you forget to mock a query?") . uncons <$> MockREST get     MockREST $ put rest      case curr of-      Left e -> return $ Left (e, e)+      Left e -> error $ "Mocked error: " ++ Text.unpack e       Right v -> do         result <- case fromJSON (String v) <|> fromJSON (Array $ fromList [String v]) of           Success a -> return a@@ -117,6 +121,6 @@          let pageLinks = case rest of               [] -> mempty-              _ -> mempty { pageNext = Just "/" }+              _ -> mempty{pageNext = Just "/"} -        return $ Right (result, pageLinks)+        return (result, pageLinks)

@@ -5,6 +5,7 @@ module PageLinks (tests) where  import Data.Maybe (catMaybes)+ #if !MIN_VERSION_base(4,11,0) import Data.Monoid ((<>)) #endif@@ -19,12 +20,14 @@ tests =   [ testProperty "parsePageLinks" $       forAll genPageLinks $ \(pageFirst, pagePrev, pageNext, pageLast) -> do-        pageLinks <- shuffle $ catMaybes-          [ mkPageLink "first" <$> pageFirst-          , mkPageLink "prev" <$> pagePrev-          , mkPageLink "next" <$> pageNext-          , mkPageLink "last" <$> pageLast-          ]+        pageLinks <-+          shuffle $+            catMaybes+              [ mkPageLink "first" <$> pageFirst+              , mkPageLink "prev" <$> pagePrev+              , mkPageLink "next" <$> pageNext+              , mkPageLink "last" <$> pageLast+              ]          return $ parsePageLinks (Text.intercalate ", " pageLinks) === PageLinks{..}   ]@@ -37,4 +40,4 @@   where     genPageLink = liftArbitrary $ Text.pack <$> genUrl     genUrl = ('/' :) <$> listOf (elements urlChars)-    urlChars = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "-_.~?=+%&/"+    urlChars = ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] ++ "-_.~?=+%&/"

@@ -30,24 +30,27 @@ goldens :: TestName -> String -> GitHubT IO ByteString -> TestTree goldens name fp action = goldenVsString name ("test/goldens/" ++ fp) $ runGitHubT state action   where-    state = GitHubState-      { token = Nothing-      , userAgent = "github-rest"-      , apiVersion = "v3"-      }+    state =+      GitHubSettings+        { token = Nothing+        , userAgent = "github-rest"+        , apiVersion = "v3"+        }  showResult :: Monad m => m (Either Value Value) -> m ByteString-showResult m = m >>= \case-  Right v -> error $ "Got back invalid result: " ++ show v-  Left e -> return $ Char8.pack $ show e+showResult m =+  m >>= \case+    Right v -> error $ "Got back invalid result: " ++ show v+    Left e -> return $ Char8.pack $ show e  getGist :: Int -> String -> GHEndpoint-getGist gistId gistSha = GHEndpoint-  { method = GET-  , endpoint = "/gists/:gist_id/:sha"-  , endpointVals =-      [ "gist_id" := gistId-      , "sha" := gistSha-      ]-  , ghData = []-  }+getGist gistId gistSha =+  GHEndpoint+    { method = GET+    , endpoint = "/gists/:gist_id/:sha"+    , endpointVals =+        [ "gist_id" := gistId+        , "sha" := gistSha+        ]+    , ghData = []+    }