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 --- a/servant-github.cabal +++ b/servant-github.cabal @@ -1,5 +1,5 @@ name: servant-github -version: 0.1.0.2 +version: 0.1.0.3 synopsis: Bindings to GitHub API using servant. description: This package provides a servant-client based client for accessing the . @@ -46,6 +46,16 @@ , text , transformers default-language: Haskell2010 + +executable test + main-is: Main.hs + build-depends: base + , servant-github + , text + , transformers + hs-source-dirs: app + ghc-options: -Wall -fno-warn-name-shadowing -O3 -threaded + 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 @@ -29,6 +29,10 @@ , getTeam , teamMembers , teamRepositories + , user + , userRepositories + , getCommit + , getContent -- * GitHub monad -- $github , GitHub @@ -78,6 +82,22 @@ -- | Get list of 'Repository' records assoctiated to 'Team' given by Team Id teamRepositories :: TeamId -> GitHub [Repository] teamRepositories = github (Proxy :: Proxy TeamRepositories) + +-- | Get the current user for the authorised user +user :: GitHub User +user = github (Proxy :: Proxy GetUser) +-- +-- | Get repositories for the authorised user +userRepositories :: Maybe String -> GitHub [Repository] +userRepositories = github (Proxy :: Proxy UserRepositories) + +-- | Get commit for repo and reference +getCommit :: OrgLogin -> RepoName -> Sha -> GitHub Commit +getCommit = github (Proxy :: Proxy GetCommit) + +-- | Get content for repo and reference and path +getContent :: OrgLogin -> RepoName -> String -> Maybe String -> Maybe String -> GitHub Content +getContent = github (Proxy :: Proxy GetContent) -- $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 @@ -29,3 +29,20 @@ -- | type GetTeam = "teams" :> Capture "id" TeamId :> Get '[JSON] Team +-- | +type GetUser = "user" :> Get '[JSON] User + +-- | +type UserRepositories = "user" :> "repos" :> QueryParam "type" String :> Get '[JSON] [Repository] + +-- | +type GetCommit + = "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 + :> "contents" :> Capture "path" String :> QueryParam "ref" String :> QueryParam "path" String + :> Get '[JSON] Content 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 @@ -159,11 +159,20 @@ embedGitHub comp arg = embedGitHub (comp arg) instance HasGitHub (a -> b -> c -> Single d) where embedGitHub comp arg = embedGitHub (comp arg) +instance HasGitHub (a -> b -> c -> d -> Single e) where + embedGitHub comp arg = embedGitHub (comp arg) +instance HasGitHub (a -> b -> c -> d -> e -> Single f) 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) +instance HasGitHub (a -> b -> c -> d -> Paginated e) where + embedGitHub comp arg = embedGitHub (comp arg) +instance HasGitHub (a -> b -> c -> d -> e -> Paginated f) where embedGitHub comp arg = embedGitHub (comp arg) -- | Wrapper around the servant 'client' function, that takes care of the 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 @@ -18,6 +18,11 @@ , MemberId , Repository(..) , RepositoryName + , User(..) + , RepoName -- short version + , Sha + , Commit(..) + , Content(..) ) where @@ -78,15 +83,104 @@ data Repository = Repository { repositoryName :: RepositoryName , repositoryDescription :: Maybe Text + , repositoryDefaultBranch :: Maybe Text , repositoryPrivate :: Bool + , repositoryPermissions :: Maybe Permission } deriving (Eq, Show) -- | repositories are identified by their name type RepositoryName = Text +data Permission = Push | Pull | Admin deriving (Eq) +instance Show Permission where + show Push = "push" + show Pull = "pull" + show Admin = "admin" +instance FromJSON Permission where + parseJSON (Object o) = do + admin <- o .: "admin" + push <- o .: "push" + return $ if admin then Admin + else if push then Push + else Pull + parseJSON _ = mzero + instance FromJSON Repository where parseJSON (Object o) = - Repository <$> o .: "name" - <*> o .: "description" + Repository <$> o .: "full_name" + <*> o .:? "description" + <*> o .:? "default_branch" <*> o .: "private" + <*> o .:? "permissions" parseJSON _ = mzero + +-- | Organisation +data User = User + { userLogin :: Text + , userId :: Int + , userName :: Maybe Text + , userCompany :: Maybe Text + , userEmail :: Maybe Text + } deriving (Eq, Show) + +instance FromJSON User where + parseJSON (Object o) = + User <$> o .: "login" + <*> o .: "id" + <*> o .: "name" + <*> o .: "company" + <*> o .: "email" + parseJSON _ = mzero + +instance ToJSON User where + toJSON u = + object [ "login" .= userLogin u + , "id" .= userId u + , "name" .= userName u + , "company" .= userCompany u + , "email" .= userEmail u + ] + +-- | Commit +type RepoName = Text +type Sha = Text +data Commit = Commit + { commitMessage :: Text + , commitUrl :: Text + } deriving (Eq, Show) + +-- TODO: fix this instance +instance FromJSON Commit where + parseJSON (Object o) = do + html_url <- o .: "html_url" + commit <- o .: "commit" + message <- commit .: "message" + return $ Commit message html_url + parseJSON _ = mzero + +instance ToJSON Commit where + toJSON c = + let head_commit = object [ "message" .= commitMessage c + , "url" .= commitUrl c ] + in object [ "commits" .= toJSON [ head_commit ] + , "head_commit" .= head_commit ] + +-- | Content +data Content = Content + { contentType :: Text + , contentEncoding :: Text + , contentSize :: Int + , contentName :: Text + , contentPath :: Text + , contentContent :: Text + } deriving (Eq, Show) + +instance FromJSON Content where + parseJSON (Object o) = + Content <$> o .: "type" + <*> o .: "encoding" + <*> o .: "size" + <*> o .: "name" + <*> o .: "path" + <*> o .: "content" + parseJSON _ = mzero