servant-github 0.1.0.4 → 0.1.0.6
raw patch · 5 files changed
+521/−76 lines, 5 filesdep +bytestringdep +cryptonitedep +http-client-tlsdep ~servant-client
Dependencies added: bytestring, cryptonite, http-client-tls, http-media, jose, lens, mtl, time
Dependency ranges changed: servant-client
Files
- servant-github.cabal +13/−5
- src/Network/GitHub.hs +121/−9
- src/Network/GitHub/API.hs +45/−4
- src/Network/GitHub/Client.hs +153/−50
- src/Network/GitHub/Types.hs +189/−8
servant-github.cabal view
@@ -1,11 +1,11 @@ name: servant-github-version: 0.1.0.4+version: 0.1.0.6 synopsis: Bindings to GitHub API using servant. description: This package provides a servant-client based client for accessing the <https://developer.github.com/v3/ GitHub API v3>. . The github client is provided through the 'Network.GitHub.GitHub' monad,- which provides support for managing the user-agent (a requirement + which provides support for managing the user-agent (a requirement for github), an authentication token, and, pagination support when the resulting value is a list. .@@ -13,7 +13,7 @@ > import System.Environment > import Data.String > import Network.GitHub- > + > > main = do > token <- fmap fromString <$> lookupEnv "GITHUB_TOKEN" > result <- runGitHub userOrganisations token@@ -39,13 +39,21 @@ , Network.GitHub.Types build-depends: base >= 4.7 && < 5 , aeson+ , bytestring+ , cryptonite , http-api-data , http-client+ , http-client-tls , http-link-header+ , http-media+ , jose , servant- , servant-client >= 0.7 && < 1+ , servant-client >= 0.9 && < 0.12 , text+ , time , transformers+ , lens+ , mtl default-language: Haskell2010 executable test@@ -56,7 +64,7 @@ , transformers hs-source-dirs: app ghc-options: -Wall -fno-warn-name-shadowing -O3 -threaded- default-language: Haskell2010 + default-language: Haskell2010 test-suite servant-github-test type: exitcode-stdio-1.0
src/Network/GitHub.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-}@@ -8,34 +9,48 @@ -- License : BSD3 -- Maintainer : finlay.thompson@gmail.com -- Stability : experimental--- +-- -- The GitHub monad provides support for:--- +-- -- - Managing the authentication token. It can be Nothing, in which case -- no Authentication header is sent to the API,--- +-- -- - Setting the User-agent header string. This defaults to "servant-github", -- but can be set inside the GitHub monad using the 'setUserAgent', and--- --- - Keeping track of the pagination in the case of calls that return lists +--+-- - Keeping track of the pagination in the case of calls that return lists -- of objects. -module Network.GitHub - ( +module Network.GitHub+ ( -- * GitHub API calls -- $client userOrganisations+ , userOrganisationMemberships , organisationTeams , getTeam , teamMembers , teamRepositories , user+ , userByLogin , userRepositories+ , userInstallationRepositories+ , organisationRepositories+ , installationRepositories+ , appInstallations+ , userInstallations+ , repositoryCollaborators , getCommit , getContent+ , getIssues+ , integrationJWT+ , reqInstallationAccessToken -- * GitHub monad -- $github , GitHub+ , runGitHubClientM+ , runGitHubNotApiClientM+ , runGitHub' , runGitHub , AuthToken , setUserAgent@@ -51,15 +66,35 @@ ) where +import Control.Lens+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Except+ import Data.Proxy+import Data.Monoid ((<>))+import Data.Time.Clock (getCurrentTime, UTCTime(..), addUTCTime)+import Data.Time.Clock.POSIX+ (utcTimeToPOSIXSeconds, posixSecondsToUTCTime)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.ByteString.Lazy as B (toStrict) +import Servant.Client (client, ClientM)++import Crypto.Random (MonadRandom(..))+import Crypto.JOSE.JWK (JWK)+import qualified Crypto.JWT as JWT+import Crypto.JOSE.JWS (Alg(..), newJWSHeader)+import Crypto.JOSE.Compact (encodeCompact)+ import Network.GitHub.API import Network.GitHub.Types import Network.GitHub.Client -- $client ----- Functions that directly access the GitHub API. These functions all run +-- Functions that directly access the GitHub API. These functions all run -- in the 'GitHub' monad. -- @@ -67,6 +102,10 @@ userOrganisations :: GitHub [Organisation] userOrganisations = github (Proxy :: Proxy UserOrganisations) +-- | Get list of 'OrganisationMember' records for authorised user+userOrganisationMemberships :: GitHub [OrganisationMember]+userOrganisationMemberships = github (Proxy :: Proxy UserOrganisationMemberships)+ -- | Get list of 'Team' records, given the organisation login organisationTeams :: OrgLogin -> GitHub [Team] organisationTeams = github (Proxy :: Proxy OrganisationTeams)@@ -86,11 +125,39 @@ -- | Get the current user for the authorised user user :: GitHub User user = github (Proxy :: Proxy GetUser)---++-- | Lookup user by login+userByLogin :: Maybe String -> GitHub User+userByLogin = github (Proxy :: Proxy GetUserByLogin)+ -- | Get repositories for the authorised user userRepositories :: Maybe String -> GitHub [Repository] userRepositories = github (Proxy :: Proxy UserRepositories) +-- | List repositories that are accessible to the authenticated user for an installation.+userInstallationRepositories :: Int -> GitHub Repositories+userInstallationRepositories = github (Proxy :: Proxy UserInstallationRepositories)++-- | Get repositories for an organisation login+organisationRepositories :: OrgLogin -> GitHub [Repository]+organisationRepositories = github (Proxy :: Proxy OrganisationRepositories)++-- | Get repositories for the installation (current token should be an installation token)+installationRepositories :: GitHub Repositories+installationRepositories = github (Proxy :: Proxy InstallationRepositories)++-- | Get installations for the appliction+appInstallations :: GitHub [Installation]+appInstallations = github (Proxy :: Proxy AppInstallations)++-- | List installations that are accessible to the authenticated user.+userInstallations :: Maybe String -> GitHub Installations+userInstallations = github (Proxy :: Proxy UserInstallations)++-- | Get repositories for the installation (current token should be an installation token)+repositoryCollaborators :: OrgLogin -> RepoName -> GitHub [Member]+repositoryCollaborators = github (Proxy :: Proxy RepositoryCollaborators)+ -- | Get commit for repo and reference getCommit :: OrgLogin -> RepoName -> Sha -> GitHub Commit getCommit = github (Proxy :: Proxy GetCommit)@@ -98,6 +165,51 @@ -- | Get content for repo and reference and path getContent :: OrgLogin -> RepoName -> String -> Maybe String -> Maybe String -> GitHub Content getContent = github (Proxy :: Proxy GetContent)++-- | Get issuers for a repository+type GHOptions =[(String, String)]+getIssues :: GHOptions -> Owner -> RepoName -> GitHub [Issue]+getIssues opts owner repo+ = github (Proxy :: Proxy GetIssues) owner repo+ (lookup "milestone" opts)+ (lookup "state" opts)+ (lookup "assignee" opts)+ (lookup "creator" opts)+ (lookup "mentioned" opts)+ (lookup "labels" opts)+ (lookup "sort" opts)+ (lookup "direction" opts)+ (lookup "since" opts)++integrationJWT+ :: (MonadRandom m, MonadError e m, JWT.AsError e)+ => JWK+ -> Int+ -> UTCTime+ -> m Text+integrationJWT key integrationId now' = do+ let now = posixSecondsToUTCTime . fromInteger . round $ utcTimeToPOSIXSeconds now'+ claimsSet = JWT.emptyClaimsSet+ & JWT.claimIss .~ Just (review JWT.string $ show integrationId)+ & JWT.claimIat .~ Just (JWT.NumericDate now)+ & JWT.claimExp .~ Just (JWT.NumericDate $ addUTCTime 60 now)+ signed <- JWT.signClaims key (newJWSHeader ((), RS256)) claimsSet+ return . T.decodeUtf8 . B.toStrict $ encodeCompact signed++reqInstallationAccessToken+ :: JWK -> Int -> Int -> Maybe InstallationUser -> ClientM InstallationAccessToken+reqInstallationAccessToken key integrationId installationId mbUser = do+ now <- liftIO getCurrentTime+ jwtEth <- liftIO . runExceptT $ integrationJWT key integrationId now+ case jwtEth of+ Left (err :: JWT.Error) -> liftIO . fail $ show err+ Right jwt ->+ client (Proxy :: Proxy ReqInstallationAccessToken)+ installationId+ (Just "Gorbachev IO")+ (Just $ "Bearer " <> T.unpack jwt)+ mbUser+ -- $github --
src/Network/GitHub/API.hs view
@@ -6,7 +6,7 @@ -- License : BSD3 -- Maintainer : finlay.thompson@gmail.com -- Stability : experimental- + module Network.GitHub.API where @@ -17,6 +17,9 @@ -- | <https://developer.github.com/v3/orgs/#list-your-organizations> type UserOrganisations = "user" :> "orgs" :> Get '[JSON] [Organisation] +-- | <https://developer.github.com/v3/orgs/members/#list-your-organization-memberships>+type UserOrganisationMemberships = "user" :> "memberships" :> "orgs" :> Get '[JSON] [OrganisationMember]+ -- | <https://developer.github.com/v3/orgs/teams/#list-teams> type OrganisationTeams = "orgs" :> Capture "org" OrgLogin :> "teams" :> Get '[JSON] [Team] @@ -32,17 +35,55 @@ -- | <https://developer.github.com/v3/users/#get-the-authenticated-user> type GetUser = "user" :> Get '[JSON] User +-- | <https://developer.github.com/v3/users/#get-a-single-user>+type GetUserByLogin = "user" :> QueryParam "username" String :> Get '[JSON] User+ -- | <https://developer.github.com/v3/repos/#list-your-repositories> type UserRepositories = "user" :> "repos" :> QueryParam "type" String :> Get '[JSON] [Repository] +-- | <https://developer.github.com/v3/apps/installations/#list-repositories-accessible-to-the-user-for-an-installation>+type UserInstallationRepositories = "user" :> "installations" :> Capture "installation_id" Int :> "repositories" :> Get '[EarlyAccessJSON] Repositories++-- | <https://developer.github.com/v3/repos/#list-organization-repositories>+type OrganisationRepositories = "orgs" :> Capture "org" OrgLogin :> "repos" :> Get '[JSON] [Repository]++-- | <https://developer.github.com/early-access/integrations/integrations-vs-oauth-applications/#repository-discovery>+type InstallationRepositories = "installation" :> "repositories" :> Get '[EarlyAccessJSON] Repositories++-- | <https://developer.github.com/v3/apps/#find-installations>+type AppInstallations = "app" :> "installations" :> Get '[EarlyAccessJSON] [Installation]++-- | <https://developer.github.com/v3/apps/#list-installations-for-user>+type UserInstallations = "user" :> "installations" :> QueryParam "access_token" String :> Get '[EarlyAccessJSON] Installations++-- | <https://developer.github.com/v3/repos/collaborators/#list-collaborators>+type RepositoryCollaborators = "repos" :> Capture "org" OrgLogin :> Capture "repo" RepoName :> "collaborators" :> Get '[JSON] [Member]+ -- | <https://developer.github.com/v3/repos/commits/#get-a-single-commit> type GetCommit- = "repos" :> Capture "org" OrgLogin :> Capture "repo" RepoName + = "repos" :> Capture "org" OrgLogin :> Capture "repo" RepoName :> "commits" :> Capture "sha" Sha :> Get '[JSON] Commit -- | <https://developer.github.com/v3/repos/contents/#get-contents> -- GET /repos/:owner/:repo/contents/:path-type GetContent - = "repos" :> Capture "org" OrgLogin :> Capture "repo" RepoName +type GetContent+ = "repos" :> Capture "org" OrgLogin :> Capture "repo" RepoName :> "contents" :> Capture "path" String :> QueryParam "ref" String :> QueryParam "path" String :> Get '[JSON] Content++-- | https://developer.github.com/v3/issues/#list-issues-for-a-repository+-- GET /repos/:owner/:repo/issues+type GetIssues+ = "repos" :> Capture "owner" Owner :> Capture "repo" RepoName :> "issues"+ :> QueryParam "milestone" String :> QueryParam "state" String+ :> QueryParam "assignee" String :> QueryParam "creator" String+ :> QueryParam "mentioned" String :> QueryParam "labels" String+ :> QueryParam "sort" String :> QueryParam "direction" String+ :> QueryParam "since" String+ :> Get '[JSON] [Issue]++type ReqInstallationAccessToken = "installations" :> Capture "installation_id" Int :> "access_tokens"+ :> Header "User-Agent" String+ :> Header "Authorization" String+ :> ReqBody '[JSON] (Maybe InstallationUser)+ :> Post '[EarlyAccessJSON] InstallationAccessToken
src/Network/GitHub/Client.hs view
@@ -12,11 +12,14 @@ -- License : BSD3 -- Maintainer : finlay.thompson@gmail.com -- Stability : experimental- + module Network.GitHub.Client ( github , AuthToken , GitHub+ , runGitHubClientM+ , runGitHubNotApiClientM+ , runGitHub' , runGitHub , GitHubState(..) , HasGitHub@@ -44,15 +47,19 @@ import GHC.TypeLits import Data.String import Data.Text as T+import Data.Maybe (fromMaybe) -import Servant.API+import Servant.API hiding (Link) import Servant.Client import Web.HttpApiData-import Network.HTTP.Client (newManager, defaultManagerSettings, Manager)+import Network.HTTP.Client.TLS (tlsManagerSettings)+import Network.HTTP.Client (newManager, Manager) import Network.HTTP.Link.Types import Network.HTTP.Link.Parser (parseLinkHeaderBS) +import Network.GitHub.Types (CountedList(..))+ -- | Token used to authorize access to the GitHub API. -- see <https://developer.github.com/v3/oauth/> newtype AuthToken = AuthToken Text deriving (Eq)@@ -62,63 +69,100 @@ toQueryParam (AuthToken t) = T.concat ["token ", t] host :: BaseUrl-host = BaseUrl Https "api.github.com" 443 "/"+host = BaseUrl Https "api.github.com" 443 "" +hostNotApi :: BaseUrl+hostNotApi = BaseUrl Https "github.com" 443 ""+ -- | The 'GitHub' monad provides execution context-type GitHub = ReaderT (Maybe AuthToken) (StateT GitHubState (ExceptT ServantError IO))+type GitHub = ReaderT (Maybe AuthToken) (StateT GitHubState ClientM) +runGitHubClientM :: ClientM a -> IO (Either ServantError a)+runGitHubClientM comp = do+ manager <- newManager tlsManagerSettings+ runClientM comp (ClientEnv manager host)++-- | Most of the time we must use api.github.com, but calling+-- login/oauth/access_token only works if sent to github.com.+runGitHubNotApiClientM :: ClientM a -> IO (Either ServantError a)+runGitHubNotApiClientM comp = do+ manager <- newManager tlsManagerSettings+ runClientM comp (ClientEnv manager hostNotApi)++runGitHub' :: GitHub a -> Maybe AuthToken -> ClientM a+runGitHub' comp token = evalStateT (runReaderT comp token) defGitHubState+ -- | You need to provide a 'Maybe AuthToken' to lift a 'GitHub' computation--- into the 'IO' monad. +-- into the 'IO' monad. runGitHub :: GitHub a -> Maybe AuthToken -> IO (Either ServantError a)-runGitHub comp token = do- manager <- newManager defaultManagerSettings- runExceptT $ evalStateT (runReaderT comp token) (defGitHubState manager)+runGitHub comp token = runGitHubClientM $ runGitHub' comp token --- | Closed type family that adds standard headers to the incoming +-- | Closed type family that adds standard headers to the incoming -- servant API type. The extra headers are put after any arguments types. type family AddHeaders a :: * where- AddHeaders ((sym :: Symbol) :> last) + AddHeaders ((sym :: Symbol) :> last) = (sym :: Symbol) :> AddHeaders last AddHeaders (first :> last) = first :> AddHeaders last- AddHeaders last - = Header "User-Agent" Text - :> Header "Authorization" AuthToken + AddHeaders last+ = Header "User-Agent" Text+ :> Header "Authorization" AuthToken :> ReadHeaders last -- | Closed type family that adds headers necessary for pagination. In particular, -- it captures the "Link" header from the response. type family ReadHeaders a :: * where- ReadHeaders (Get cts [res]) - = QueryParam "page" Int :> QueryParam "per_page" Int + ReadHeaders (Get cts [res])+ = QueryParam "page" Int :> QueryParam "per_page" Int :> Get cts (Headers '[Header "Link" Text] [res])- ReadHeaders (Post cts [res]) - = QueryParam "page" Int :> QueryParam "per_page" Int + ReadHeaders (Post cts [res])+ = QueryParam "page" Int :> QueryParam "per_page" Int :> Post cts (Headers '[Header "Link" Text] [res])- ReadHeaders (Delete cts [res]) - = QueryParam "page" Int :> QueryParam "per_page" Int + ReadHeaders (Delete cts [res])+ = QueryParam "page" Int :> QueryParam "per_page" Int :> Delete cts (Headers '[Header "Link" Text] [res])- ReadHeaders (Put cts [res]) - = QueryParam "page" Int :> QueryParam "per_page" Int + ReadHeaders (Put cts [res])+ = QueryParam "page" Int :> QueryParam "per_page" Int :> Put cts (Headers '[Header "Link" Text] [res])- ReadHeaders (Patch cts [res]) - = QueryParam "page" Int :> QueryParam "per_page" Int + ReadHeaders (Patch cts [res])+ = QueryParam "page" Int :> QueryParam "per_page" Int :> Patch cts (Headers '[Header "Link" Text] [res])+ ReadHeaders (Get cts (CountedList name res))+ = QueryParam "page" Int :> QueryParam "per_page" Int+ :> Get cts (Headers '[Header "Link" Text] (CountedList name res))+ ReadHeaders (Post cts (CountedList name res))+ = QueryParam "page" Int :> QueryParam "per_page" Int+ :> Post cts (Headers '[Header "Link" Text] (CountedList name res))+ ReadHeaders (Delete cts (CountedList name res))+ = QueryParam "page" Int :> QueryParam "per_page" Int+ :> Delete cts (Headers '[Header "Link" Text] (CountedList name res))+ ReadHeaders (Put cts (CountedList name res))+ = QueryParam "page" Int :> QueryParam "per_page" Int+ :> Put cts (Headers '[Header "Link" Text] (CountedList name res))+ ReadHeaders (Patch cts (CountedList name res))+ = QueryParam "page" Int :> QueryParam "per_page" Int+ :> Patch cts (Headers '[Header "Link" Text] (CountedList name res)) ReadHeaders otherwise = otherwise -- | Client function that returns a single result-type Single a = Maybe Text -> Maybe AuthToken -> Manager -> BaseUrl- -> ExceptT ServantError IO a+type Single a = Maybe Text -> Maybe AuthToken+ -> ClientM a -- | Client function that returns a list of results, and is therefore paginated-type Paginated a = Maybe Text -> Maybe AuthToken +type Paginated a = Maybe Text -> Maybe AuthToken -> Maybe Int -> Maybe Int- -> Manager -> BaseUrl- -> ExceptT ServantError IO (Headers '[Header "Link" Text] [a])+ -> ClientM (Headers '[Header "Link" Text] [a]) +-- | Client function that returns a total count and list of results, and is therefore paginated+type CountedPaginated name a = Maybe Text -> Maybe AuthToken+ -> Maybe Int -> Maybe Int+ -> ClientM (Headers '[Header "Link" Text] (CountedList name a))++ -- | Closed type family for recursively defining the GitHub client funciton types type family EmbedGitHub a :: * where EmbedGitHub (Single a) = GitHub a EmbedGitHub (Paginated a) = GitHub [a]+ EmbedGitHub (CountedPaginated name a) = GitHub (CountedList name a) EmbedGitHub (a -> b) = a -> EmbedGitHub b -- | This class defines how the client code is actually called.@@ -130,35 +174,60 @@ token <- ask r <- lift $ gets recurse when r resetPagination- + let accumPages acc = do ua <- gets useragent p <- gets page pp <- gets perPage- m <- gets manager- hres <- lift $ comp (Just ua) token (Just p) (Just pp) m host+ hres <- lift $ comp (Just ua) token (Just p) (Just pp) case getHeaders hres of- [("Link", lks)] -> modify $ \pg -> pg {links = (parseLinkHeaderBS lks)}+ [("Link", lks)] -> modify $ \pg -> pg {links = parseLinkHeaderBS lks} _ -> return () let acc' = acc ++ getResponse hres rec <- gets recurse next <- gets hasNextLink- if rec && next + if rec && next then do modify $ \pg -> pg {page = p + 1} accumPages acc'- else return acc' + else return acc' lift $ accumPages [] +-- | Instance for the case where we have a total count and paginated results+instance HasGitHub (CountedPaginated name a) where+ embedGitHub comp = do+ token <- ask+ r <- lift $ gets recurse+ when r resetPagination++ let accumPages mbCount acc = do+ ua <- gets useragent+ p <- gets page+ pp <- gets perPage+ hres <- lift $ comp (Just ua) token (Just p) (Just pp)+ case getHeaders hres of+ [("Link", lks)] -> modify $ \pg -> pg {links = parseLinkHeaderBS lks}+ _ -> return ()+ let response = getResponse hres+ count = fromMaybe (totalCount response) mbCount+ acc' = acc ++ items response+ rec <- gets recurse+ next <- gets hasNextLink+ if rec && next+ then do+ modify $ \pg -> pg {page = p + 1}+ accumPages (Just count) acc'+ else return (CountedList count acc')+ lift $ accumPages Nothing []+ -- | Instance for the case where we have single result instance HasGitHub (Single a) where embedGitHub comp = do token <- ask- lift $ do + lift $ do ua <- gets useragent- m <- gets manager- lift $ comp (Just ua) token m host- + lift $ comp (Just ua) token+ -- This instance is a bit too literal. Should be possible to do it reursively instance HasGitHub (a -> Single b) where embedGitHub comp arg = embedGitHub (comp arg)@@ -181,10 +250,45 @@ embedGitHub comp arg = embedGitHub (comp arg) instance HasGitHub (a -> b -> c -> d -> e -> Paginated f) where embedGitHub comp arg = embedGitHub (comp arg)+instance HasGitHub (a -> b -> c -> d -> e -> g -> Paginated f) where+ embedGitHub comp arg = embedGitHub (comp arg)+instance HasGitHub (a -> b -> c -> d -> e -> g -> h -> Paginated f) where+ embedGitHub comp arg = embedGitHub (comp arg)+instance HasGitHub (a -> b -> c -> d -> e -> g -> h -> i -> Paginated f) where+ embedGitHub comp arg = embedGitHub (comp arg)+instance HasGitHub (a -> b -> c -> d -> e -> g -> h -> i -> k -> Paginated f) where+ embedGitHub comp arg = embedGitHub (comp arg)+instance HasGitHub (a -> b -> c -> d -> e -> g -> h -> i -> k -> l -> Paginated f) where+ embedGitHub comp arg = embedGitHub (comp arg)+instance HasGitHub (a -> b -> c -> d -> e -> g -> h -> i -> k -> l -> m -> Paginated f) where+ embedGitHub comp arg = embedGitHub (comp arg) --- | Wrapper around the servant 'client' function, that takes care of the +instance HasGitHub (a -> CountedPaginated name b) where+ embedGitHub comp arg = embedGitHub (comp arg)+instance HasGitHub (a -> b -> CountedPaginated name c) where+ embedGitHub comp arg = embedGitHub (comp arg)+instance HasGitHub (a -> b -> c -> CountedPaginated name d) where+ embedGitHub comp arg = embedGitHub (comp arg)+instance HasGitHub (a -> b -> c -> d -> CountedPaginated name e) where+ embedGitHub comp arg = embedGitHub (comp arg)+instance HasGitHub (a -> b -> c -> d -> e -> CountedPaginated name f) where+ embedGitHub comp arg = embedGitHub (comp arg)+instance HasGitHub (a -> b -> c -> d -> e -> g -> CountedPaginated name f) where+ embedGitHub comp arg = embedGitHub (comp arg)+instance HasGitHub (a -> b -> c -> d -> e -> g -> h -> CountedPaginated name f) where+ embedGitHub comp arg = embedGitHub (comp arg)+instance HasGitHub (a -> b -> c -> d -> e -> g -> h -> i -> CountedPaginated name f) where+ embedGitHub comp arg = embedGitHub (comp arg)+instance HasGitHub (a -> b -> c -> d -> e -> g -> h -> i -> k -> CountedPaginated name f) where+ embedGitHub comp arg = embedGitHub (comp arg)+instance HasGitHub (a -> b -> c -> d -> e -> g -> h -> i -> k -> l -> CountedPaginated name f) where+ embedGitHub comp arg = embedGitHub (comp arg)+instance HasGitHub (a -> b -> c -> d -> e -> g -> h -> i -> k -> l -> m -> CountedPaginated name f) where+ embedGitHub comp arg = embedGitHub (comp arg)++-- | Wrapper around the servant 'client' function, that takes care of the -- extra headers that required for the 'GitHub' monad.-github :: (HasClient (AddHeaders api), HasGitHub (Client (AddHeaders api))) +github :: (HasClient (AddHeaders api), HasGitHub (Client (AddHeaders api))) => Proxy api -> EmbedGitHub (Client (AddHeaders api)) github px = embedGitHub (clientWithHeaders px) @@ -194,17 +298,16 @@ -- | GitHubState options that control which headers are provided to the API -- and stores the 'Link' header result-data GitHubState - = GitHubState - { manager :: Manager -- ^ Network Manager- , perPage :: Int -- ^ The number of records returned per page+data GitHubState+ = GitHubState+ { perPage :: Int -- ^ The number of records returned per page , page :: Int -- ^ The page number returned , links :: Maybe [Link] -- ^ Contains the returned 'Link' header, if available. , recurse :: Bool -- ^ Flag to set the recursive mode on , useragent :: Text -- ^ Text to send as "User-agent" }-defGitHubState :: Manager -> GitHubState-defGitHubState manager = GitHubState manager 100 1 Nothing True "servant-github"+defGitHubState :: GitHubState+defGitHubState = GitHubState 100 1 Nothing True "servant-github" -- | Overide default value for User-agent header. -- Note, GitHub requires that a User-agent header be set.@@ -214,7 +317,7 @@ hasNextLink :: GitHubState -> Bool hasNextLink ghs = maybe False hnl (links ghs) where hnl = Prelude.any (\ln -> (Rel, "next") `elem` linkParams ln)- + -- | Set next page back to 1, and remove the links resetPagination :: GitHub () resetPagination = lift $ modify $ \ghs -> ghs { page = 1, links = Nothing }@@ -224,8 +327,8 @@ -- If recursive is on, paginated results will be automatically -- followed and concated together. recurseOff, recurseOn :: GitHub ()-recurseOff = lift $ modify $ \ghs -> ghs { recurse = False } -recurseOn = lift $ modify $ \ghs -> ghs { recurse = True } +recurseOff = lift $ modify $ \ghs -> ghs { recurse = False }+recurseOn = lift $ modify $ \ghs -> ghs { recurse = True } -- | The default number of records per page is set to 100. Smaller pages can be -- set, but not bigger than 100.
src/Network/GitHub/Types.hs view
@@ -1,4 +1,11 @@+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Network.GitHub.Types -- Copyright : (c) Finlay Thompson, 2015@@ -8,30 +15,67 @@ -- -- Most of the types only parse part of the data availble in the return -- values from the GitHub API. These will be added to as required.- + module Network.GitHub.Types- ( Organisation(..)+ ( CountedList(..)+ , Organisation(..)+ , OrganisationMember(..) , OrgLogin+ , Owner+ , UserLogin(..) , Team(..) , TeamId , Member(..) , MemberId , Repository(..)+ , Repositories(..)+ , Permission(..) , RepositoryName , User(..) , RepoName -- short version , Sha , Commit(..) , Content(..)+ , Issue(..)+ , Label(..)+ , Milestone(..)+ , EarlyAccessJSON+ , Installation(..)+ , Installations(..)+ , InstallationAccessToken(..)+ , InstallationUser(..) ) where import Control.Monad+import GHC.Generics+import GHC.TypeLits (KnownSymbol, symbolVal, Symbol)+ import Data.Aeson import Data.Text+import qualified Data.Text as T (pack)+import Data.Time+import Data.Proxy (Proxy(..))+import qualified Data.List.NonEmpty as NE (NonEmpty(..)) --- | Organisation -data Organisation = Organisation +import qualified Network.HTTP.Media as M ((//))++import Servant.API (JSON, Accept(..), MimeUnrender(..))++-- | List of results including a total count+data CountedList (name :: Symbol) a = CountedList+ { totalCount :: Int+ , items :: [a]+ }++instance (FromJSON a, KnownSymbol name) => FromJSON (CountedList name a) where+ parseJSON (Object o) =+ CountedList <$> o .: "total_count"+ <*> o .: T.pack (symbolVal (Proxy :: Proxy name))+ parseJSON _ = mzero++-- | Organisation+data Organisation = Organisation { orgLogin :: OrgLogin , orgId :: Int , orgDescription :: Maybe Text@@ -39,7 +83,9 @@ -- | Primary identifier for an organisation is the login type OrgLogin = Text +type Owner = Text + instance FromJSON Organisation where parseJSON (Object o) = Organisation <$> o .: "login"@@ -79,6 +125,22 @@ <*> o .: "login" parseJSON _ = mzero +-- | OrganisationMember+data OrganisationMember = OrganisationMember+ { orgmemberRole :: Text+ , orgmemberState :: Text+ , orgmemberOrganisation :: Organisation+ , orgmemberUser :: Member+ } deriving (Eq, Show)++instance FromJSON OrganisationMember where+ parseJSON (Object o) =+ OrganisationMember <$> o .: "role"+ <*> o .: "state"+ <*> o .: "organization"+ <*> o .: "user"+ parseJSON _ = mzero+ -- | Repository data Repository = Repository { repositoryName :: RepositoryName@@ -96,7 +158,7 @@ show Pull = "pull" show Admin = "admin" instance FromJSON Permission where- parseJSON (Object o) = do + parseJSON (Object o) = do admin <- o .: "admin" push <- o .: "push" return $ if admin then Admin@@ -113,7 +175,10 @@ <*> o .:? "permissions" parseJSON _ = mzero --- | Organisation +-- | Repositories+type Repositories = CountedList "repositories" Repository++-- | Organisation data User = User { userLogin :: Text , userId :: Int@@ -132,7 +197,7 @@ parseJSON _ = mzero instance ToJSON User where- toJSON u = + toJSON u = object [ "login" .= userLogin u , "id" .= userId u , "name" .= userName u@@ -158,7 +223,7 @@ parseJSON _ = mzero instance ToJSON Commit where- toJSON c = + toJSON c = let head_commit = object [ "message" .= commitMessage c , "url" .= commitUrl c ] in object [ "commits" .= toJSON [ head_commit ]@@ -183,4 +248,120 @@ <*> o .: "path" <*> o .: "content" parseJSON _ = mzero++newtype UserLogin = UserLogin Text deriving (Show, Eq)+instance FromJSON UserLogin where+ parseJSON (Object o) =+ UserLogin <$> o .: "login"+ parseJSON _ = mzero++data Milestone = Milestone+ { milestoneNumber :: Int+ , milestoneState :: Text+ , milestoneTitle :: Text+ , milestoneDescripiton :: Maybe Text+ , milestoneCreator :: UserLogin+ , milestoneOpenIssues :: Int+ , milestoneClosedIssues :: Int+ , milestoneCreated :: UTCTime+ , milestoneUpdated :: Maybe UTCTime+ , milestoneClosed :: Maybe UTCTime+ , milestoneDueOn :: Maybe UTCTime+ } deriving (Show, Eq)+instance FromJSON Milestone where+ parseJSON (Object o) =+ Milestone <$> o .: "number"+ <*> o .: "state"+ <*> o .: "title"+ <*> o .:? "description"+ <*> o .: "creator"+ <*> o .: "open_issues"+ <*> o .: "closed_issues"+ <*> o .: "created_at"+ <*> o .: "updated_at"+ <*> o .: "closed_at"+ <*> o .: "due_on"+ parseJSON _ = mzero++newtype Label = Label Text deriving (Eq, Show)+instance FromJSON Label where+ parseJSON (Object o) =+ Label <$> o .: "name"+ parseJSON _ = mzero++-- | Issue+data Issue = Issue+ { issueNumber :: Int+ , issueUrl :: Text+ , issueState :: Text+ , issueTitle :: Text+ , issueBody :: Text+ , issueUser :: UserLogin+ , issueAssignee :: Maybe UserLogin+ , issueMilestone :: Maybe Milestone+ , issueLabels :: [Label]+ , issueLocked :: Bool+ , issueComments :: Int+ , issueCreated :: UTCTime+ , issueUpdated :: UTCTime+ , issueClosed :: Maybe UTCTime+ } deriving (Generic, Eq, Show)++instance FromJSON Issue where+ parseJSON (Object o) =+ Issue <$> o .: "number"+ <*> o .: "html_url"+ <*> o .: "state"+ <*> o .: "title"+ <*> o .: "body"+ <*> o .: "user"+ <*> o .:? "assignee"+ <*> o .:? "milestone"+ <*> o .: "labels"+ <*> o .: "locked"+ <*> o .: "comments"+ <*> o .: "created_at"+ <*> o .: "updated_at"+ <*> o .: "closed_at"+ parseJSON _ = mzero++data EarlyAccessJSON++instance FromJSON t => MimeUnrender EarlyAccessJSON t where+ mimeUnrender _ = mimeUnrender (Proxy :: Proxy JSON)++instance Accept EarlyAccessJSON where+ contentTypes _ = "application" M.// "vnd.github.machine-man-preview+json" NE.:| ["application" M.// "json"]++-- | Installation+data Installation = Installation+ { installationId :: Int+ , installationAppId :: Int+ , installationTargetId :: Int+ , installationTargetType :: Text+ } deriving (Eq, Show)++instance FromJSON Installation where+ parseJSON (Object o) =+ Installation <$> o .: "id"+ <*> o .: "app_id"+ <*> o .: "target_id"+ <*> o .: "target_type"+ parseJSON _ = mzero++-- | IntegrationInstallations+type Installations = CountedList "integration_installations" Installation++data InstallationAccessToken = InstallationAccessToken+ { token :: Text+ } deriving (Eq, Show, Generic)+instance FromJSON InstallationAccessToken+instance ToJSON InstallationAccessToken++data InstallationUser = InstallationUser+ { user_id :: Int+ } deriving (Eq, Show, Generic)+instance FromJSON InstallationUser+instance ToJSON InstallationUser+