servant-github 0.1.0.2 → 0.1.0.3
raw patch · 6 files changed
+201/−3 lines, 6 filesdep ~basenew-component:exe:test
Dependency ranges changed: base
Files
- app/Main.hs +48/−0
- servant-github.cabal +11/−1
- src/Network/GitHub.hs +20/−0
- src/Network/GitHub/API.hs +17/−0
- src/Network/GitHub/Client.hs +9/−0
- src/Network/GitHub/Types.hs +96/−2
+ app/Main.hs view
@@ -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]
servant-github.cabal view
@@ -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 <https://developer.github.com/v3/ GitHub API v3>.@@ -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
src/Network/GitHub.hs view
@@ -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 --
src/Network/GitHub/API.hs view
@@ -29,3 +29,20 @@ -- | <https://developer.github.com/v3/orgs/teams/#get-team> type GetTeam = "teams" :> Capture "id" TeamId :> Get '[JSON] Team +-- | <https://developer.github.com/v3/users/#get-the-authenticated-user>+type GetUser = "user" :> 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/repos/commits/#get-a-single-commit>+type GetCommit+ = "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 + :> "contents" :> Capture "path" String :> QueryParam "ref" String :> QueryParam "path" String+ :> Get '[JSON] Content
src/Network/GitHub/Client.hs view
@@ -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
src/Network/GitHub/Types.hs view
@@ -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