diff --git a/servant-github.cabal b/servant-github.cabal --- a/servant-github.cabal +++ b/servant-github.cabal @@ -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 . . 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 diff --git a/src/Network/GitHub.hs b/src/Network/GitHub.hs --- a/src/Network/GitHub.hs +++ b/src/Network/GitHub.hs @@ -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 -- diff --git a/src/Network/GitHub/API.hs b/src/Network/GitHub/API.hs --- a/src/Network/GitHub/API.hs +++ b/src/Network/GitHub/API.hs @@ -6,7 +6,7 @@ -- License : BSD3 -- Maintainer : finlay.thompson@gmail.com -- Stability : experimental - + module Network.GitHub.API where @@ -17,6 +17,9 @@ -- | type UserOrganisations = "user" :> "orgs" :> Get '[JSON] [Organisation] +-- | +type UserOrganisationMemberships = "user" :> "memberships" :> "orgs" :> Get '[JSON] [OrganisationMember] + -- | type OrganisationTeams = "orgs" :> Capture "org" OrgLogin :> "teams" :> Get '[JSON] [Team] @@ -32,17 +35,55 @@ -- | type GetUser = "user" :> Get '[JSON] User +-- | +type GetUserByLogin = "user" :> QueryParam "username" String :> Get '[JSON] User + -- | type UserRepositories = "user" :> "repos" :> QueryParam "type" String :> Get '[JSON] [Repository] +-- | +type UserInstallationRepositories = "user" :> "installations" :> Capture "installation_id" Int :> "repositories" :> Get '[EarlyAccessJSON] Repositories + +-- | +type OrganisationRepositories = "orgs" :> Capture "org" OrgLogin :> "repos" :> Get '[JSON] [Repository] + +-- | +type InstallationRepositories = "installation" :> "repositories" :> Get '[EarlyAccessJSON] Repositories + +-- | +type AppInstallations = "app" :> "installations" :> Get '[EarlyAccessJSON] [Installation] + +-- | +type UserInstallations = "user" :> "installations" :> QueryParam "access_token" String :> Get '[EarlyAccessJSON] Installations + +-- | +type RepositoryCollaborators = "repos" :> Capture "org" OrgLogin :> Capture "repo" RepoName :> "collaborators" :> Get '[JSON] [Member] + -- | type GetCommit - = "repos" :> Capture "org" OrgLogin :> Capture "repo" RepoName + = "repos" :> Capture "org" OrgLogin :> Capture "repo" RepoName :> "commits" :> Capture "sha" Sha :> Get '[JSON] Commit -- | -- 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 diff --git a/src/Network/GitHub/Client.hs b/src/Network/GitHub/Client.hs --- a/src/Network/GitHub/Client.hs +++ b/src/Network/GitHub/Client.hs @@ -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 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. diff --git a/src/Network/GitHub/Types.hs b/src/Network/GitHub/Types.hs --- a/src/Network/GitHub/Types.hs +++ b/src/Network/GitHub/Types.hs @@ -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 +