diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Finlay Thompson (c) 2015 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import System.Exit +import System.Environment +import Control.Monad.IO.Class +import Control.Monad +import Data.Monoid +import Data.Maybe +import Data.String +import Data.Text as T +import Data.Text.IO as T + +import Network.GitHub + +main :: IO () +main = do + + -- Get AuthToken from environment variable + token <- fmap fromString <$> lookupEnv "GITHUB_TOKEN" + + -- Require the token for this to work + when (not $ isJust token) $ do + T.putStrLn "Please set the GITHUB_TOKEN env variable" + exitFailure + + -- Run GitHub computation, print errors if there are any + errors <- runGitHub (printTeams "dragonfly-science") token + case errors of + Left e -> liftIO $ print e + Right _ -> exitSuccess + +printOrgsAndTeams :: GitHub () +printOrgsAndTeams = do + os <- userOrganisations + forM_ os $ \o -> do + liftIO $ T.putStrLn (orgLogin o) + printTeams (orgLogin o) + +printTeams :: OrgLogin -> GitHub () +printTeams ol = do + teams <- organisationTeams ol + forM_ teams $ \t -> do + liftIO $ T.putStrLn $ " " <> teamName t + members <- teamMembers (teamId t) + liftIO $ T.putStrLn $ " " <> T.intercalate ", " [ memberLogin m | m <- members] + repos <- teamRepositories (teamId t) + liftIO $ T.putStrLn $ " " <> T.intercalate ", " [ repositoryName r | r <- repos] diff --git a/servant-github.cabal b/servant-github.cabal new file mode 100644 --- /dev/null +++ b/servant-github.cabal @@ -0,0 +1,74 @@ +name: servant-github +version: 0.1.0.0 +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 + for github), an authentication token, and, pagination + support when the resulting value is a list. + . + > + > import System.Environment + > import Network.Github + > + > main = do + > token <- fmap fromString <$> lookupEnv "GITHUB_TOKEN" + > result <- runGitHub userOrganisations token + > case result of + > Left e -> print e + > Right orgs -> mapM_ print orgs + > + +homepage: http://github.com/finlay/servant-github#readme +license: BSD3 +license-file: LICENSE +author: Finlay Thompson +maintainer: finlay.thompson@gmail.com +copyright: 2015 Finlay Thompson +category: Web +build-type: Simple +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Network.GitHub + , Network.GitHub.API + , Network.GitHub.Client + , Network.GitHub.Types + build-depends: base >= 4.7 && < 5 + , aeson + , either + , http-link-header + , servant + , servant-client + , text + , transformers + default-language: Haskell2010 + +executable servant-github-example + hs-source-dirs: app + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: base + , either + , text + , transformers + , servant-github + default-language: Haskell2010 + +test-suite servant-github-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , hspec + , QuickCheck + , servant-github + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/finlay/servant-github diff --git a/src/Network/GitHub.hs b/src/Network/GitHub.hs new file mode 100644 --- /dev/null +++ b/src/Network/GitHub.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Network.GitHub +-- Copyright : (c) Finlay Thompson, 2015 +-- 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 +-- of objects. + +module Network.GitHub + ( + -- * GitHub API calls + -- $client + userOrganisations + , organisationTeams + , getTeam + , teamMembers + , teamRepositories + -- * GitHub monad + -- $github + , GitHub + , runGitHub + , AuthToken + , setUserAgent + -- * Pagination + -- $pagination + , resetPagination + , recurseOff + , recurseOn + , pageSize + , getLinks + , module Network.GitHub.API + , module Network.GitHub.Types + ) +where + +import Data.Proxy + +import Network.GitHub.API +import Network.GitHub.Types +import Network.GitHub.Client + +-- $client +-- +-- Functions that directly access the GitHub API. These functions all run +-- in the 'GitHub' monad. +-- + +-- | Get list of 'Organisation' records for authorised user +userOrganisations :: GitHub [Organisation] +userOrganisations = github (Proxy :: Proxy UserOrganisations) + +-- | Get list of 'Team' records, given the organisation login +organisationTeams :: OrgLogin -> GitHub [Team] +organisationTeams = github (Proxy :: Proxy OrganisationTeams) + +-- | Get the 'Team' record associated to a TeamId +getTeam :: TeamId -> GitHub Team +getTeam = github (Proxy :: Proxy GetTeam) + +-- | Get list of 'Member' records assoctiated to 'Team' given by Team Id +teamMembers :: TeamId -> GitHub [Member] +teamMembers = github (Proxy :: Proxy TeamMembers) + +-- | Get list of 'Repository' records assoctiated to 'Team' given by Team Id +teamRepositories :: TeamId -> GitHub [Repository] +teamRepositories = github (Proxy :: Proxy TeamRepositories) + +-- $github +-- +-- Use the 'runGitHub' function to execute the 'GitHub' client function. + + +-- $pagination +-- +-- Functions for managing the pagination features of the GitHub API +-- diff --git a/src/Network/GitHub/API.hs b/src/Network/GitHub/API.hs new file mode 100644 --- /dev/null +++ b/src/Network/GitHub/API.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +-- | +-- Module : Network.GitHub.API +-- Copyright : (c) Finlay Thompson, 2015 +-- License : BSD3 +-- Maintainer : finlay.thompson@gmail.com +-- Stability : experimental + +module Network.GitHub.API +where + +import Servant.API + +import Network.GitHub.Types + +-- | +type UserOrganisations = "user" :> "orgs" :> Get '[JSON] [Organisation] + +-- | +type OrganisationTeams = "orgs" :> Capture "org" OrgLogin :> "teams" :> Get '[JSON] [Team] + +-- | +type TeamMembers = "teams" :> Capture "id" TeamId :> "members" :> Get '[JSON] [Member] + +-- | +type TeamRepositories = "teams" :> Capture "id" TeamId :> "repos" :> Get '[JSON] [Repository] + +-- | +type GetTeam = "teams" :> Capture "id" TeamId :> Get '[JSON] Team + diff --git a/src/Network/GitHub/Client.hs b/src/Network/GitHub/Client.hs new file mode 100644 --- /dev/null +++ b/src/Network/GitHub/Client.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +-- | +-- Module : Network.GitHub.Client +-- Copyright : (c) Finlay Thompson, 2015 +-- License : BSD3 +-- Maintainer : finlay.thompson@gmail.com +-- Stability : experimental + +module Network.GitHub.Client + ( github + , AuthToken + , GitHub + , runGitHub + , GitHubState(..) + , HasGitHub + , embedGitHub + , EmbedGitHub + , AddHeaders + , ReadHeaders + , Single + , Paginated + , setUserAgent + , resetPagination + , recurseOff + , recurseOn + , pageSize + , getLinks + ) +where + +import Control.Monad (when) +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State +import Control.Monad.Trans.Either +import Data.Proxy +import GHC.TypeLits +import Data.String +import Data.Text as T + +import Servant.API +import Servant.Client + +import Network.HTTP.Link.Types +import Network.HTTP.Link.Parser (parseLinkHeaderBS) + +-- | Token used to authorize access to the GitHub API. +-- see +newtype AuthToken = AuthToken Text deriving (Eq) +instance IsString AuthToken where + fromString s = AuthToken (fromString s) +instance ToText AuthToken where + toText (AuthToken t) = T.concat ["token ", t] + +host :: BaseUrl +host = BaseUrl Https "api.github.com" 443 + +-- | The 'GitHub' monad provides execution context +type GitHub = ReaderT (Maybe AuthToken) (StateT GitHubState (EitherT ServantError IO)) + +-- | You need to provide a 'Maybe AuthToken' to lift a 'GitHub' computation +-- into the 'IO' monad. +runGitHub :: GitHub a -> Maybe AuthToken -> IO (Either ServantError a) +runGitHub comp token = runEitherT $ evalStateT (runReaderT comp token) defGitHubState + +-- | 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) + = (sym :: Symbol) :> AddHeaders last + AddHeaders (first :> last) + = first :> AddHeaders last + 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 + :> Get cts (Headers '[Header "Link" Text] [res]) + 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 + :> Delete cts (Headers '[Header "Link" Text] [res]) + 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 + :> Patch cts (Headers '[Header "Link" Text] [res]) + ReadHeaders otherwise = otherwise + +-- | Client function that returns a single result +type Single a = Maybe Text -> Maybe AuthToken + -> EitherT ServantError IO a + +-- | Client function that returns a list of results, and is therefore paginated +type Paginated a = Maybe Text -> Maybe AuthToken + -> Maybe Int -> Maybe Int + -> EitherT ServantError IO (Headers '[Header "Link" Text] [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 (a -> b) = a -> EmbedGitHub b + +-- | This class defines how the client code is actually called. +class HasGitHub a where + embedGitHub :: a -> EmbedGitHub a +-- | Instance for the case where we have paginated results +instance HasGitHub (Paginated a) where + embedGitHub comp = do + token <- ask + r <- lift $ gets recurse + when r resetPagination + + let accumPages 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 acc' = acc ++ getResponse hres + rec <- gets recurse + next <- gets hasNextLink + if rec && next + then do + modify $ \pg -> pg {page = p + 1} + accumPages acc' + else return acc' + lift $ accumPages [] + +-- | Instance for the case where we have single result +instance HasGitHub (Single a) where + embedGitHub comp = do + token <- ask + lift $ do + ua <- gets useragent + 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) +instance HasGitHub (a -> b -> Single c) where + embedGitHub comp arg = embedGitHub (comp arg) +instance HasGitHub (a -> b -> c -> Single d) where + embedGitHub comp arg = embedGitHub (comp arg) +instance HasGitHub (a -> Paginated b) where + embedGitHub comp arg = embedGitHub (comp arg) +instance HasGitHub (a -> b -> Paginated c) where + embedGitHub comp arg = embedGitHub (comp arg) +instance HasGitHub (a -> b -> c -> Paginated d) 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))) + => Proxy api -> EmbedGitHub (Client (AddHeaders api)) +github px = embedGitHub (clientWithHeaders px) + +clientWithHeaders :: HasClient (AddHeaders api) => Proxy api -> Client (AddHeaders api) +clientWithHeaders (Proxy :: Proxy api) = client (Proxy :: Proxy (AddHeaders api)) host + + +-- | GitHubState options that control which headers are provided to the API +-- and stores the 'Link' header result +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" + } deriving Show +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. +setUserAgent :: Text -> GitHub () +setUserAgent ua = lift $ modify $ \ghs -> ghs { useragent = ua } + +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 } + +-- | Turn automatic recusive behaviour on and off. +-- +-- 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 } + +-- | The default number of records per page is set to 100. Smaller pages can be +-- set, but not bigger than 100. +pageSize :: Int -> GitHub () +pageSize ps = lift $ modify $ \ghs -> ghs { perPage = ps } + +-- | Return the 'Link' header. This is only set when there are futher pages. +getLinks :: GitHub (Maybe [Link]) +getLinks = lift $ gets links diff --git a/src/Network/GitHub/Types.hs b/src/Network/GitHub/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/GitHub/Types.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Network.GitHub.Types +-- Copyright : (c) Finlay Thompson, 2015 +-- License : BSD3 +-- Maintainer : finlay.thompson@gmail.com +-- Stability : experimental +-- +-- 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(..) + , OrgLogin + , Team(..) + , TeamId + , Member(..) + , MemberId + , Repository(..) + , RepositoryName + ) +where + +import Control.Monad +import Data.Aeson +import Data.Text + +-- | Organisation +data Organisation = Organisation + { orgLogin :: OrgLogin + , orgId :: Int + , orgDescription :: Maybe Text + } deriving (Eq, Show) +-- | Primary identifier for an organisation is the login +type OrgLogin = Text + + +instance FromJSON Organisation where + parseJSON (Object o) = + Organisation <$> o .: "login" + <*> o .: "id" + <*> o .: "description" + parseJSON _ = mzero + +-- | Team +data Team = Team + { teamId :: TeamId + , teamName :: Text + , teamDescription :: Maybe Text + , teamPermission :: Maybe Text + } deriving (Eq, Show) +-- | Identifier for a team id +type TeamId = Integer + +instance FromJSON Team where + parseJSON (Object o) = + Team <$> o .: "id" + <*> o .: "name" + <*> o .: "description" + <*> o .: "permission" + parseJSON _ = mzero + +-- | Member +data Member = Member + { memberId :: MemberId + , memberLogin :: Text + } deriving (Eq, Show) +-- | members are identified by ids +type MemberId = Integer + +instance FromJSON Member where + parseJSON (Object o) = + Member <$> o .: "id" + <*> o .: "login" + parseJSON _ = mzero + +-- | Repository +data Repository = Repository + { repositoryName :: RepositoryName + , repositoryDescription :: Maybe Text + , repositoryPrivate :: Bool + } deriving (Eq, Show) +-- | repositories are identified by their name +type RepositoryName = Text + +instance FromJSON Repository where + parseJSON (Object o) = + Repository <$> o .: "name" + <*> o .: "description" + <*> o .: "private" + parseJSON _ = mzero + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,7 @@ +import Test.Hspec + +main :: IO () +main = hspec $ do + describe "organiztions" $ do + it "Get a list of organizations" $ do + pendingWith "Not implemented"