├── .github-sandbox ├── .gitignore ├── .travis.yml ├── LICENSE ├── README.md ├── Setup.hs ├── octohat.cabal ├── spec ├── Network │ └── Octohat │ │ ├── MembersSpec.hs │ │ ├── TestData.hs │ │ └── TestUtil.hs └── Spec.hs ├── src-demo └── Web │ └── GitHub │ └── CLI │ ├── Actions.hs │ ├── Main.hs │ ├── Messages.hs │ └── Options.hs └── src └── Network ├── Octohat.hs └── Octohat ├── Internal.hs ├── Keys.hs ├── Members.hs └── Types.hs /.github-sandbox: -------------------------------------------------------------------------------- 1 | SANDBOX_ORGANIZATION=octohat-test-organization 2 | TEST_ACCOUNT_ONE=jsantos-testaccount2 3 | TEST_ACCOUNT_TWO=octohat-test-1 4 | TEST_ACCOUNT_THREE=octohat-test-2 5 | TEST_ACCOUNT_FOUR=octohat-test-3 6 | TEST_REPO=octohat-test-repo 7 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | *.dyn_o 8 | *.dyn_hi 9 | .virtualenv 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | cabal.config 15 | *.prof 16 | *.aux 17 | *.hp 18 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | env: 2 | global: 3 | - secure: Cp+kl0j79zeXCj1zZN6gbU/8RZW7aXXDOlbKSNLa338Io0LwmSG+L2beazhhw7gkB4qFf9s9seJzjgx0jJaV1jkizcRunQC/iw7q6Y4wBr6jeQJqGKGyzaKyTY3dTwN20V/NnofRxKKL2v0QX1kUx5CB34wlprq/wO9nJeIDR1U= 4 | matrix: 5 | - GHC_VERSION=7.4.2 CABAL_VERSION=1.18 6 | - GHC_VERSION=7.6.3 CABAL_VERSION=1.20 7 | - GHC_VERSION=7.8.4 CABAL_VERSION=1.20 8 | - GHC_VERSION=7.10.1 CABAL_VERSION=1.22 9 | 10 | before_install: 11 | - sudo apt-add-repository -y ppa:hvr/ghc 12 | - sudo apt-get update 13 | - sudo apt-get install -y ghc-$GHC_VERSION cabal-install-$CABAL_VERSION 14 | - export PATH=/opt/ghc/$GHC_VERSION/bin:/opt/cabal/$CABAL_VERSION/bin:$PATH 15 | 16 | install: 17 | - cabal update 18 | - cabal sandbox init 19 | - cabal install --only-dependencies --enable-tests 20 | 21 | script: 22 | - cabal configure --enable-tests 23 | - cabal build 24 | - cabal test 25 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Justin Leitgeb 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Octohat 2 | [![Build Status](https://travis-ci.org/stackbuilders/octohat.svg?branch=master)](https://travis-ci.org/stackbuilders/octohat) 3 | [![Hackage](https://img.shields.io/hackage/v/octohat.svg)](http://hackage.haskell.org/package/octohat) 4 | 5 | A well tested, GitHub API client for Haskell using `wreq` as a backend. 6 | 7 | The project uses Stackage to maintain build stability. 8 | 9 | ## Currently supported endpoints 10 | 11 | ### Members 12 | 13 | `module Network.Octohat.Members` 14 | 15 | * Add teams to an organization 16 | `addTeamToOrganization` 17 | 18 | * Delete teams from an organization 19 | `deleteTeamFromOrganization` 20 | 21 | * List all members from an organization 22 | `membersForOrganization` 23 | 24 | * List all members from a team, using the team id 25 | `membersForTeam` 26 | 27 | * List all teams from an organization 28 | `teamsForOrganization` 29 | 30 | * Add members to a team 31 | `addMemberToTeam` 32 | 33 | * Delete members from a team 34 | `deleteMemberFromTeam` 35 | 36 | * List Public Keys for a user 37 | `publicKeysForUser` 38 | 39 | ## Instructions 40 | 41 | ### To install: 42 | ``` 43 | cabal sandbox init 44 | cabal install --only-dep --enable-test -jN 45 | ``` 46 | 47 | where N = \ 48 | 49 | ### To build: 50 | 51 | ``` 52 | cabal build 53 | ``` 54 | 55 | ### Then run the test suite: 56 | 57 | **CAUTION: Use tokens of a test user, not your own account since the test suite clears state on Github before it runs (i.e., it will delete everything in your github account).** 58 | 59 | You need to set some environment variables. 60 | 61 | Set `SANDBOX_ORGANIZATION` to an organization you don't care about, since the tests will delete all the teams within that organization 62 | 63 | Set `TEST_ACCOUNT_ONE` to a test account member of the Owners teams in `$SANDBOX_ORGANIZATION` 64 | 65 | Set `TEST_ACCOUNT_TWO` to another test account member of the Owners teams in `$SANDBOX_ORGANIZATION` 66 | 67 | Set `TEST_ACCOUNT_THREE` to yet another test account member of the Owners teams in `$SANDBOX_ORGANIZATION` 68 | 69 | Set `GITHUB_TOKEN` to an API token from `$TEST_ACCOUNT_ONE`. The token scopes should include full admin privileges and the ability to write public keys. 70 | 71 | You can these variables either directly or put them in `.GITHUB_SANDBOX`. Either way they must be set to run the tests. Finally run the tests with: 72 | 73 | ``` 74 | cabal test 75 | ``` 76 | 77 | ### Demo 78 | 79 | After you have built the binaries using `cabal build` you should have an executable file named `.dist/build/abc/abc`. This provides a rather basic interface to the GitHub API. The tool expects the environment variable `GITHUB_TOKEN` to be set to a GitHub token with permissions to modify an organization. Some of the operations supported: (each subcommand has its own `--help` page) 80 | 81 | `dist/build/abc/abc --help` 82 | 83 | ``` 84 | Some options 85 | 86 | Usage: abc COMMAND 87 | GitHub client to manage teams. Please specify your token as GITHUB_TOKEN 88 | 89 | Available options: 90 | -h,--help Show this help text 91 | 92 | Available commands: 93 | list-teams List teams in a organization 94 | members-in List members in team and organization 95 | add-to-team Add users to a team 96 | delete-user Delete a user from a team 97 | ``` 98 | 99 | ## License 100 | 101 | MIT, see the LICENSE file. 102 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /octohat.cabal: -------------------------------------------------------------------------------- 1 | Name: octohat 2 | Synopsis: A tested, minimal wrapper around GitHub's API. 3 | Description: A tested, minimal wrapper around GitHub's API. 4 | Version: 0.1.5.0 5 | License: MIT 6 | License-file: LICENSE 7 | Author: Stack Builders 8 | Maintainer: hackage@stackbuilders.com 9 | Stability: Experimental 10 | Category: Network 11 | Build-type: Simple 12 | Homepage: https://github.com/stackbuilders/octohat 13 | Bug-reports: https://github.com/stackbuilders/octohat/issues 14 | Cabal-version: >=1.10 15 | 16 | Library 17 | hs-source-dirs: src 18 | 19 | Build-depends: 20 | aeson == 0.8.* 21 | , base >= 4.4 && < 4.9 22 | , base-compat == 0.6.* 23 | , base16-bytestring == 0.1.1.* 24 | , base64-bytestring == 1.0.* 25 | , bytestring >= 0.9 26 | , containers >= 0.4 27 | , cryptohash == 0.11.* 28 | , dotenv == 0.1.* 29 | , either == 4.3.* 30 | , errors >= 1.4 && < 2.1 31 | , ghc-prim >= 0.2 32 | , http-client == 0.4.* 33 | , http-types == 0.8.* 34 | , lens >= 4.0 && < 4.10 35 | , mtl == 2.* 36 | , text == 1.2.* 37 | , time >= 1.4 && < 1.6 38 | , transformers >= 0.3 && < 0.5 39 | , unordered-containers == 0.2.* 40 | , wreq-sb == 0.4.* 41 | , xmlhtml == 0.2.* 42 | 43 | ghc-options: -Wall 44 | exposed-modules: Network.Octohat.Types 45 | , Network.Octohat.Members 46 | , Network.Octohat.Keys 47 | , Network.Octohat 48 | 49 | other-modules: Network.Octohat.Internal 50 | 51 | default-language: Haskell2010 52 | 53 | Executable abc 54 | hs-source-dirs: src-demo 55 | main-is: Web/GitHub/CLI/Main.hs 56 | 57 | Build-depends: 58 | aeson ==0.8.0.* 59 | , base >=4.4 && <4.9 60 | , text 61 | , optparse-applicative ==0.11.0.* 62 | , octohat 63 | , utf8-string >=0.3 && <=1 64 | , yaml >= 0.8 && < 0.9 65 | 66 | default-language: Haskell2010 67 | 68 | other-modules: Web.GitHub.CLI.Actions 69 | , Web.GitHub.CLI.Messages 70 | , Web.GitHub.CLI.Options 71 | 72 | ghc-options: -threaded -Wall 73 | 74 | test-suite spec 75 | ghc-options : -Wall 76 | type : exitcode-stdio-1.0 77 | hs-source-dirs : spec 78 | main-is : Spec.hs 79 | build-depends : base >= 4.4 && <4.9 80 | , base-compat == 0.6.* 81 | , hspec == 2.1.* 82 | , hspec-expectations == 0.6.* 83 | , text 84 | , dotenv == 0.1.* 85 | , transformers >= 0.3 && < 0.5 86 | , octohat 87 | other-modules: Network.Octohat.TestData, 88 | Network.Octohat.TestUtil 89 | default-language: Haskell2010 90 | 91 | source-repository head 92 | type: git 93 | location: https://github.com/stackbuilders/octohat 94 | -------------------------------------------------------------------------------- /spec/Network/Octohat/MembersSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Network.Octohat.MembersSpec where 4 | 5 | import Test.Hspec 6 | 7 | import Network.Octohat.Members 8 | import Network.Octohat.Types 9 | import Network.Octohat.Keys 10 | import Network.Octohat.TestData ( loadTestOrganizationName 11 | , loadTestAccountOne 12 | , loadTestAccountTwo 13 | , fingerprintFixture 14 | , loadTestAccountThree 15 | , loadTestAccountFour 16 | , loadTestRepo 17 | , loadOwnerTeam 18 | , publicKeyHostnameFixture 19 | , publicKeyFixture 20 | , fingerprintFixture) 21 | import Network.Octohat.TestUtil (setupToken, removeTeams) 22 | 23 | 24 | spec :: Spec 25 | spec = after removeTeams $ before setupToken $ do 26 | describe "add teams" $ do 27 | it "should add a team to an organization and then delete it" $ do 28 | testOrganization <- OrganizationName `fmap` loadTestOrganizationName 29 | Right ownerTeam <- runGitHub loadOwnerTeam 30 | 31 | Right newTeam <- runGitHub $ addTeamToOrganization (TeamName "A new team") 32 | "A description" PullAccess testOrganization 33 | Right teamsInOctohat <- runGitHub $ teamsForOrganization testOrganization 34 | teamsInOctohat `shouldBe` [ownerTeam, newTeam] 35 | Right deleteResult <- runGitHub $ deleteTeamFromOrganization (teamId newTeam) 36 | Right newTeamsInOctohat <- runGitHub $ teamsForOrganization testOrganization 37 | deleteResult `shouldBe` Deleted 38 | newTeamsInOctohat `shouldBe` [ownerTeam] 39 | 40 | it "should add a member to a new team and then delete it" $ do 41 | testOrganization <- OrganizationName `fmap` loadTestOrganizationName 42 | Right testAccountOne <- runGitHub loadTestAccountOne 43 | 44 | Right newTeam <- runGitHub $ addTeamToOrganization (TeamName "A new team") 45 | "A description" AdminAccess testOrganization 46 | let idForThisTeam = teamId newTeam 47 | Right addingStatus <- runGitHub $ addMemberToTeam (memberLogin testAccountOne) idForThisTeam 48 | addingStatus `shouldBe` Active 49 | Right membersInThisTeam <- runGitHub $ membersForTeam idForThisTeam 50 | membersInThisTeam `shouldBe` [testAccountOne] 51 | 52 | it "should get the public keys for a user" $ do 53 | -- This assumes the token belongs to testAccountOne 54 | Right testAccountOne <- runGitHub loadTestAccountOne 55 | _ <- runGitHub $ addPublicKey publicKeyFixture publicKeyHostnameFixture 56 | 57 | Right pubKey <- runGitHub $ publicKeysForUser (memberLogin testAccountOne) 58 | fmap (publicKeyFingerprint . fingerprintFor) pubKey `shouldBe` [fingerprintFixture] 59 | 60 | it "should delete a member from a team" $ do 61 | testOrganization <- OrganizationName `fmap` loadTestOrganizationName 62 | Right testAccount <- runGitHub loadTestAccountTwo 63 | 64 | Right newTeam <- runGitHub $ addTeamToOrganization (TeamName "Testing team") 65 | "Desc" PushAccess testOrganization 66 | Right addStatus <- runGitHub $ addMemberToTeam (memberLogin testAccount) (teamId newTeam) 67 | addStatus `shouldBe` Active 68 | 69 | Right membersInNewTeam <- runGitHub $ membersForTeam (teamId newTeam) 70 | [memberLogin $ head membersInNewTeam] `shouldBe` [memberLogin testAccount] 71 | 72 | Right deleteStatus <- runGitHub $ deleteMemberFromTeam (memberLogin testAccount) (teamId newTeam) 73 | [deleteStatus] `shouldBe` [Deleted] 74 | 75 | Right membersInNewTeamNow <- runGitHub $ membersForTeam (teamId newTeam) 76 | membersInNewTeamNow `shouldBe` [] 77 | 78 | it "should list all members in the organization" $ do 79 | Right testAccountOne <- runGitHub loadTestAccountOne 80 | Right testAccountTwo <- runGitHub loadTestAccountTwo 81 | Right testAccountThree <- runGitHub loadTestAccountThree 82 | Right testAccountFour <- runGitHub loadTestAccountFour 83 | testOrganization <- OrganizationName `fmap` loadTestOrganizationName 84 | 85 | Right members <- runGitHub $ membersForOrganization testOrganization 86 | members `shouldMatchList` [testAccountOne, testAccountTwo, testAccountThree, testAccountFour] 87 | 88 | -- List repositories 89 | describe "manage repo and membership of teams" $ do 90 | it "List all the organizations for the user" $ do 91 | testOrganization <- loadTestOrganizationName 92 | Right orgs <- runGitHub organizations 93 | map orgLogin orgs `shouldBe` [testOrganization] 94 | 95 | it "show add test repository to new team and then delete it" $ do 96 | testOrganization <- OrganizationName `fmap` loadTestOrganizationName 97 | Right testRepo <- runGitHub loadTestRepo 98 | Right newTeam <- runGitHub $ addTeamToOrganization (TeamName "Testing team") 99 | "Desc" PushAccess testOrganization 100 | let idForThisTeam = teamId newTeam 101 | _ <- runGitHub $ addRepoToTeam testOrganization (repoName testRepo) idForThisTeam 102 | 103 | Right reposInNewTeam <- runGitHub $ reposForTeam idForThisTeam 104 | reposInNewTeam `shouldBe` [testRepo] 105 | Right deleteResult <- runGitHub $ deleteTeamFromOrganization (teamId newTeam) 106 | deleteResult `shouldBe` Deleted 107 | 108 | -------------------------------------------------------------------------------- /spec/Network/Octohat/TestData.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Network.Octohat.TestData ( loadTestOrganizationName 4 | , loadOwnerTeam 5 | , loadTestAccountOne 6 | , loadTestAccountTwo 7 | , loadTestAccountThree 8 | , loadTestAccountFour 9 | , loadTestRepo 10 | , publicKeyFixture 11 | , publicKeyHostnameFixture 12 | , fingerprintFixture 13 | , fullPublicKeyFixture 14 | ) where 15 | 16 | import Network.Octohat.Types 17 | import Network.Octohat (teamForTeamNameInOrg) 18 | import Network.Octohat.Members (userForUsername, repoForReponame) 19 | 20 | import Control.Monad.IO.Class (liftIO) 21 | import Control.Arrow (second) 22 | import System.Environment.Compat (getEnvironment) 23 | import Configuration.Dotenv (loadFile) 24 | import Control.Applicative ((<$>), (<*>)) 25 | import qualified Data.Text as T 26 | 27 | data TestEnvironment = 28 | TestEnvironment { 29 | organization :: T.Text, 30 | accountOne :: T.Text, 31 | accountTwo :: T.Text, 32 | accountThree :: T.Text, 33 | accountFour :: T.Text, 34 | testRepo :: T.Text 35 | } 36 | 37 | readEnv :: [(String, String)] -> Maybe TestEnvironment 38 | readEnv environment = 39 | TestEnvironment <$> lookup "SANDBOX_ORGANIZATION" env 40 | <*> lookup "TEST_ACCOUNT_ONE" env 41 | <*> lookup "TEST_ACCOUNT_TWO" env 42 | <*> lookup "TEST_ACCOUNT_THREE" env 43 | <*> lookup "TEST_ACCOUNT_FOUR" env 44 | <*> lookup "TEST_REPO" env 45 | where env = map (second T.pack) environment 46 | 47 | loadEnv :: IO TestEnvironment 48 | loadEnv = do 49 | loadFile False ".github-sandbox" 50 | env <- getEnvironment 51 | case readEnv env of 52 | Just res -> return res 53 | Nothing -> fail "Environment variables not set correctly, please read README.md" 54 | 55 | loadTestOrganizationName :: IO T.Text 56 | loadTestOrganizationName = organization `fmap` loadEnv 57 | 58 | loadOwnerTeam :: GitHub Team 59 | loadOwnerTeam = liftIO (OrganizationName `fmap` (organization `fmap` loadEnv)) >>= flip teamForTeamNameInOrg (TeamName "Owners") 60 | 61 | loadTestAccountOne :: GitHub Member 62 | loadTestAccountOne = liftIO (accountOne `fmap` loadEnv) >>= userForUsername 63 | 64 | loadTestAccountTwo :: GitHub Member 65 | loadTestAccountTwo = liftIO (accountTwo `fmap` loadEnv) >>= userForUsername 66 | 67 | loadTestAccountThree :: GitHub Member 68 | loadTestAccountThree = liftIO (accountThree `fmap` loadEnv) >>= userForUsername 69 | 70 | loadTestAccountFour :: GitHub Member 71 | loadTestAccountFour = liftIO (accountFour `fmap` loadEnv) >>= userForUsername 72 | 73 | loadTestRepo :: GitHub Repo 74 | loadTestRepo = do 75 | org <- liftIO (organization `fmap` loadEnv) 76 | repo <- liftIO (testRepo `fmap` loadEnv) 77 | repoForReponame org repo 78 | 79 | publicKeyHostnameFixture :: T.Text 80 | publicKeyHostnameFixture = "octohat@stackbuilders" 81 | 82 | fingerprintFixture :: T.Text 83 | fingerprintFixture = "42:59:20:02:6f:df:b4:4a:1c:0e:fd:1b:86:58:f6:06" 84 | 85 | publicKeyFixture :: T.Text 86 | publicKeyFixture = "AAAAB3NzaC1yc2EAAAADAQABAAABAQC1Dopc3yxLWlzJwFqSoj0nAzRCU93R5DwNlogtRr/7NsnUVf443wl/vpRDRNscR0dV/VeNWYCqiZA0wGrXiVJ7HYi9XaWtHrUutLqrLe47aFFvAIdp15+RHkM0sXr963Kb9XMkmqswyXJ2TaZ0cgZfMNgl1ND248Y8fMDBx8elHwdZvyG2onG5aSVtOuKB4dWnmIb+uSQCN1K2kLYwHvQOjmqCiZ2XOP9u+ScphVdp6x4uAczH67CCRSUhI6U2fxSNf6YaDXyCWcqxj1agHUKdskb5rzxPaz5XZ2BgQscjoVo93M338HLmkyvbuP4yl2X6ZdLfE5mk2ZFfWQogxLGd" 87 | 88 | fullPublicKeyFixture :: T.Text 89 | fullPublicKeyFixture = T.concat ["ssh-rsa ", publicKeyFixture, " ", publicKeyHostnameFixture] 90 | -------------------------------------------------------------------------------- /spec/Network/Octohat/TestUtil.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Network.Octohat.TestUtil (findUserId, setupToken, removeTeams) where 4 | 5 | 6 | import Network.Octohat.Members 7 | import Network.Octohat.Types 8 | import Network.Octohat.TestData 9 | 10 | import Control.Monad.IO.Class (liftIO) 11 | import Configuration.Dotenv (loadFile) 12 | import qualified Data.Text as T 13 | 14 | findUserId :: T.Text -> GitHub Integer 15 | findUserId username = memberId `fmap` userForUsername username 16 | 17 | deleteAllTeams :: GitHub [DidDelete] 18 | deleteAllTeams = do 19 | testOrganization <- liftIO loadTestOrganizationName 20 | allTeams <- teamsForOrganization (OrganizationName testOrganization) 21 | let teamsToDelete = map teamId $ filter (\t -> teamName t /= "Owners") allTeams 22 | mapM deleteTeamFromOrganization teamsToDelete 23 | 24 | setupToken :: IO () 25 | setupToken = do 26 | loadFile False ".github-sandbox" 27 | result <- runGitHub deleteAllTeams 28 | case result of 29 | Left _ -> fail "Clean-up failed" 30 | Right _ -> return () 31 | 32 | removeTeams :: () -> IO () 33 | removeTeams _ = do 34 | result <- runGitHub deleteAllTeams 35 | case result of 36 | Left _ -> fail "Clean-up failed" 37 | Right _ -> return () 38 | -------------------------------------------------------------------------------- /spec/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /src-demo/Web/GitHub/CLI/Actions.hs: -------------------------------------------------------------------------------- 1 | module Web.GitHub.CLI.Actions 2 | ( findTeamsInOrganization 3 | , addUserToTeamInOrganization 4 | , deleteUserFromTeamInOrganization 5 | , findMembersInTeam) where 6 | 7 | import Web.GitHub.CLI.Messages 8 | import Network.Octohat.Members (teamsForOrganization, deleteMemberFromTeam) 9 | import Network.Octohat 10 | import Network.Octohat.Types 11 | import qualified Data.Text as T 12 | import Data.Yaml as Y 13 | import Data.List (find) 14 | import Data.ByteString.UTF8 (toString) 15 | import System.IO (hPutStrLn, stderr) 16 | import System.Exit (ExitCode(..), exitWith) 17 | 18 | findTeamsInOrganization :: OrganizationName -> IO () 19 | findTeamsInOrganization nameOfOrg = do 20 | teamListing <- runGitHub $ teamsForOrganization nameOfOrg 21 | case teamListing of 22 | Left status -> errorHandler $ commandMessage status 23 | Right teams -> putStrLn (toString $ Y.encode teams) 24 | 25 | addUserToTeamInOrganization :: String -> OrganizationName -> TeamName -> IO () 26 | addUserToTeamInOrganization nameOfUser nameOfOrg nameOfTeam = do 27 | addResult <- runGitHub $ addUserToTeam (T.pack nameOfUser) nameOfOrg nameOfTeam 28 | case addResult of 29 | Left status -> errorHandler $ commandMessage status 30 | Right Pending -> putStrLn "User invited to join team" 31 | Right Active -> putStrLn "User added to team" 32 | 33 | deleteUserFromTeamInOrganization :: String -> OrganizationName -> TeamName -> IO () 34 | deleteUserFromTeamInOrganization nameOfUser nameOfOrg nameOfTeam = do 35 | teamListing <- runGitHub $ teamsForOrganization nameOfOrg 36 | case teamListing of 37 | Left status -> errorHandler $ commandMessage status 38 | Right [] -> errorHandler "No teams found on this organization" 39 | Right teams -> getTheTeamAndDeleteUser nameOfUser nameOfTeam teams 40 | 41 | findMembersInTeam :: OrganizationName -> TeamName -> IO () 42 | findMembersInTeam nameOfOrg nameOfTeam = do 43 | memberListing <- runGitHub $ membersOfTeamInOrganization nameOfOrg nameOfTeam 44 | case memberListing of 45 | Left status -> errorHandler $ commandMessage status 46 | Right members -> putStrLn (toString $ Y.encode members) 47 | 48 | errorHandler :: String -> IO () 49 | errorHandler message = hPutStrLn stderr message >> exitWith (ExitFailure 1) 50 | 51 | getTheTeamAndDeleteUser :: String -> TeamName -> [Team] -> IO () 52 | getTheTeamAndDeleteUser nameOfUser nameOfTeam teams = 53 | case (getTeam teams) of 54 | Nothing -> errorHandler "There's no such team in that organization" 55 | Just team -> do 56 | result <- runGitHub $ deleteMemberFromTeam (T.pack nameOfUser) (teamId team) 57 | case result of 58 | Left status -> errorHandler $ commandMessage status 59 | Right NotDeleted -> errorHandler "The user could not be deleted from the team" 60 | Right Deleted -> putStrLn "The user was succesfully deleted from the team" 61 | where getTeam = find (\t -> (teamName t) == (unTeamName nameOfTeam)) 62 | -------------------------------------------------------------------------------- /src-demo/Web/GitHub/CLI/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Web.GitHub.CLI.Options 4 | import Web.GitHub.CLI.Actions 5 | 6 | import Options.Applicative 7 | import Network.Octohat.Types (OrganizationName(..), TeamName(..)) 8 | import qualified Data.Text as T (pack) 9 | 10 | accessBotCLI :: TeamOptions -> IO () 11 | accessBotCLI (TeamOptions (ListTeams nameOfOrg)) = 12 | findTeamsInOrganization (OrganizationName $ T.pack nameOfOrg) 13 | accessBotCLI (TeamOptions (ListMembers nameOfOrg nameOfTeam)) = 14 | findMembersInTeam (OrganizationName $ T.pack nameOfOrg) (TeamName $ T.pack nameOfTeam) 15 | accessBotCLI (TeamOptions (AddToTeam nameOfOrg nameOfTeam nameOfUser)) = 16 | addUserToTeamInOrganization nameOfUser 17 | (OrganizationName $ T.pack nameOfOrg) 18 | (TeamName $ T.pack nameOfTeam) 19 | accessBotCLI (TeamOptions (DeleteFromTeam nameOfOrg nameOfTeam nameOfUser)) = 20 | deleteUserFromTeamInOrganization nameOfUser 21 | (OrganizationName $ T.pack nameOfOrg) 22 | (TeamName $ T.pack nameOfTeam) 23 | 24 | main :: IO () 25 | main = execParser argumentsParser >>= accessBotCLI 26 | 27 | argumentsParser :: ParserInfo TeamOptions 28 | argumentsParser = info (helper <*> teamOptions) 29 | (fullDesc 30 | <> progDesc "GitHub client to manage teams. Please specify your token as GITHUB_TOKEN" 31 | <> header "Some options" 32 | ) 33 | -------------------------------------------------------------------------------- /src-demo/Web/GitHub/CLI/Messages.hs: -------------------------------------------------------------------------------- 1 | module Web.GitHub.CLI.Messages 2 | (commandMessage) where 3 | 4 | import Network.Octohat.Types 5 | 6 | commandMessage :: GitHubReturnStatus -> String 7 | commandMessage NotFound = "Organization or Team not found" 8 | commandMessage NotAllowed = "Not authorized" 9 | commandMessage RequiresAuthentication = "Credentials must be configured to use this function" 10 | commandMessage _ = "Internal application error" 11 | -------------------------------------------------------------------------------- /src-demo/Web/GitHub/CLI/Options.hs: -------------------------------------------------------------------------------- 1 | module Web.GitHub.CLI.Options ( TeamOptions(..) 2 | , TeamCommand(..) 3 | , teamOptions) where 4 | 5 | import Options.Applicative 6 | 7 | type OrganizationName = String 8 | type Username = String 9 | type TeamName = String 10 | 11 | data TeamCommand = ListTeams OrganizationName 12 | | ListMembers OrganizationName TeamName 13 | | AddToTeam OrganizationName TeamName Username 14 | | DeleteFromTeam OrganizationName TeamName Username 15 | 16 | data TeamOptions = TeamOptions TeamCommand 17 | 18 | teamOptions :: Parser TeamOptions 19 | teamOptions = TeamOptions <$> parseTeamCommand 20 | 21 | parseTeamCommand :: Parser TeamCommand 22 | parseTeamCommand = subparser $ 23 | command "list-teams" (info listTeams (progDesc "List teams in a organization" )) <> 24 | command "members-in" (info listMembers (progDesc "List members in team and organization" )) <> 25 | command "add-to-team" (info addToTeam (progDesc "Add users to a team")) <> 26 | command "delete-user" (info deleteFromTeam (progDesc "Delete a user from a team")) 27 | 28 | listTeams :: Parser TeamCommand 29 | listTeams = ListTeams <$> argument str (metavar "") 30 | 31 | listMembers :: Parser TeamCommand 32 | listMembers = ListMembers <$> argument str (metavar "") 33 | <*> argument str (metavar "") 34 | 35 | addToTeam :: Parser TeamCommand 36 | addToTeam = AddToTeam <$> argument str (metavar "") 37 | <*> argument str (metavar "") 38 | <*> argument str (metavar "") 39 | 40 | deleteFromTeam :: Parser TeamCommand 41 | deleteFromTeam = DeleteFromTeam <$> argument str (metavar "") 42 | <*> argument str (metavar "") 43 | <*> argument str (metavar "") 44 | -------------------------------------------------------------------------------- /src/Network/Octohat.hs: -------------------------------------------------------------------------------- 1 | -- | Convenience functions for some common operations with teams. Execute the result of these 2 | -- functions using 'runGitHub' or 'runGitHub'' 3 | 4 | module Network.Octohat ( addUserToTeam 5 | , membersOfTeamInOrganization 6 | , keysOfTeamInOrganization 7 | , teamForTeamNameInOrg) where 8 | 9 | import Control.Error.Safe (tryHead) 10 | import Control.Monad (liftM) 11 | import qualified Data.Text as T 12 | 13 | import Network.Octohat.Keys 14 | import Network.Octohat.Members 15 | import Network.Octohat.Types 16 | 17 | 18 | -- | Gets all the members of the organization 19 | membersOfTeamInOrganization :: OrganizationName -- ^ GitHub organization name 20 | -> TeamName -- ^ GitHub team name 21 | -> GitHub [Member] 22 | membersOfTeamInOrganization nameOfOrg nameOfTeam = teamId `liftM` teamForTeamNameInOrg nameOfOrg nameOfTeam >>= membersForTeam 23 | 24 | -- | Adds a user with @nameOfUser@ to the team named @nameOfTeam@ within the organization named `nameOfOrg` 25 | addUserToTeam :: T.Text -- ^ GitHub username 26 | -> OrganizationName -- ^ GitHub organization name 27 | -> TeamName -- ^ GitHub team name 28 | -> GitHub StatusInTeam 29 | addUserToTeam nameOfUser nameOfOrg nameOfTeam = teamId `liftM` teamForTeamNameInOrg nameOfOrg nameOfTeam >>= addMemberToTeam nameOfUser 30 | 31 | -- | Retrieves a list of members in a given team within an organization together with their public keys 32 | keysOfTeamInOrganization :: OrganizationName -- ^ GitHub organization name 33 | -> TeamName -- ^ GitHub team name 34 | -> GitHub [MemberWithKey] 35 | keysOfTeamInOrganization nameOfOrg nameOfTeam = do 36 | members <- membersOfTeamInOrganization nameOfOrg nameOfTeam 37 | pubKeys <- mapM keysForMember members 38 | let memberFingerprints = publicKeySetToFingerprints pubKeys 39 | return $ makeMembersWithKey members pubKeys memberFingerprints 40 | 41 | teamForTeamNameInOrg :: OrganizationName -- ^ Organization name 42 | -> TeamName -- ^ Team name 43 | -> GitHub Team 44 | teamForTeamNameInOrg nameOfOrg nameOfTeam = do 45 | teams <- teamsForOrganization nameOfOrg 46 | tryHead NotFound (teamsWithName (unTeamName nameOfTeam) teams) 47 | 48 | teamsWithName :: T.Text -> [Team] -> [Team] 49 | teamsWithName nameOfTeam = filter (hasName nameOfTeam) 50 | 51 | hasName :: T.Text -> Team -> Bool 52 | hasName name team = name == teamName team 53 | keysForMember :: Member -> GitHub [PublicKey] 54 | keysForMember = publicKeysForUser . memberLogin 55 | 56 | makeMembersWithKey :: [Member] -> [[PublicKey]] -> [[PublicKeyFingerprint]] -> [MemberWithKey] 57 | makeMembersWithKey = zipWith3 MemberWithKey 58 | 59 | publicKeySetToFingerprints :: [[PublicKey]] -> [[PublicKeyFingerprint]] 60 | publicKeySetToFingerprints = (map.map) fingerprintFor 61 | 62 | 63 | -------------------------------------------------------------------------------- /src/Network/Octohat/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ViewPatterns #-} 3 | 4 | module Network.Octohat.Internal 5 | ( putRequestTo 6 | , getRequestTo 7 | , resetPage 8 | , getRequestPaginatedTo 9 | , postRequestTo 10 | , deleteRequestTo 11 | , composeEndpoint) where 12 | 13 | import Control.Error.Safe 14 | import Control.Lens (set, view, preview) 15 | import Control.Monad.Reader 16 | import Control.Monad.State 17 | import Data.Monoid 18 | import Data.Aeson 19 | import Data.List 20 | import Data.Text.Encoding (encodeUtf8) 21 | import Network.Wreq 22 | import qualified Network.Wreq.Types as WT 23 | import qualified Data.ByteString.Lazy as BSL 24 | import qualified Data.Text as T 25 | 26 | import Network.Octohat.Types 27 | 28 | composeEndpoint :: [T.Text] -> T.Text 29 | composeEndpoint pathChunks = T.concat $ intersperse "/" ("https://api.github.com" : pathChunks) 30 | 31 | getResponseEntity :: FromJSON a => Response BSL.ByteString -> Either GitHubReturnStatus a 32 | getResponseEntity resp = 33 | case eitherDecode (view responseBody resp) of 34 | Left errorMessage -> Left (UnexpectedJSON errorMessage) 35 | Right decoded -> Right decoded 36 | 37 | requestOptions :: GitHub Options 38 | requestOptions = do 39 | bearerToken <- ask 40 | let opts = set auth (Just $ oauth2Bearer (encodeUtf8 $ unBearerToken bearerToken)) defaults 41 | let opts' = set checkStatus (Just (\_ _ _ -> Nothing)) opts 42 | let opts'' = set (header "User-Agent") ["octohat v0.1"] opts' 43 | return opts'' 44 | 45 | postRequestTo :: (ToJSON b, WT.Postable b, FromJSON a) => T.Text -> b -> GitHub a 46 | postRequestTo uri body = do 47 | opts <- requestOptions 48 | response <- liftIO $ postWith opts (T.unpack uri) (toJSON body) 49 | checkForStatus response 50 | tryRight $ getResponseEntity response 51 | 52 | getRequestTo :: FromJSON a => T.Text -> GitHub a 53 | getRequestTo uri = do 54 | opts <- requestOptions 55 | response <- liftIO $ getWith opts (T.unpack uri) 56 | checkForStatus response 57 | tryRight $ getResponseEntity response 58 | 59 | resetPage :: GitHub () 60 | resetPage = modify $ \pn -> pn { page = 1 } 61 | 62 | getRequestPaginatedTo :: (Monoid a, FromJSON a) => T.Text -> GitHub a 63 | getRequestPaginatedTo uri = do 64 | opts <- requestOptions 65 | let combinedResponse o acc = do 66 | page_no <- gets page 67 | per_page <- gets perPage 68 | let ps = set (param "page") [T.pack $ show page_no] . set (param "per_page") [T.pack $ show per_page] 69 | response <- liftIO $ getWith (ps o) (T.unpack uri) 70 | checkForStatus response 71 | let links' = Links 72 | { linkNext = preview (responseLink "rel" "next") response 73 | , linkLast = preview (responseLink "rel" "last") response 74 | , linkFirst = preview (responseLink "rel" "first") response 75 | , linkPrev = preview (responseLink "rel" "prev") response } 76 | modify $ \pn -> pn { links = links' } 77 | values <- tryRight $ getResponseEntity response 78 | recurse' <- gets recurse 79 | let acc' = acc <> values 80 | if recurse' 81 | then do 82 | case linkNext links' of 83 | Just _next -> do modify $ \pn -> pn { page = page_no + 1} 84 | combinedResponse o acc' 85 | Nothing -> return acc' 86 | else return acc' 87 | combinedResponse opts mempty 88 | 89 | 90 | putRequestTo :: FromJSON a => T.Text -> GitHub a 91 | putRequestTo uri = do 92 | opts <- requestOptions 93 | response <- liftIO $ putWith opts (T.unpack uri) EmptyBody 94 | checkForStatus response 95 | tryRight $ getResponseEntity response 96 | 97 | deleteRequestTo :: T.Text -> GitHub DidDelete 98 | deleteRequestTo uri = do 99 | opts <- requestOptions 100 | response <- liftIO $ deleteWith opts (T.unpack uri) 101 | checkForStatus response 102 | return $ isDeleted (viewResponse response) 103 | 104 | checkForStatus :: Response a -> GitHub () 105 | checkForStatus (viewResponse -> 404) = tryAssert NotFound False 106 | checkForStatus (viewResponse -> 403) = tryAssert NotAllowed False 107 | checkForStatus (viewResponse -> 401) = tryAssert RequiresAuthentication False 108 | checkForStatus (viewResponse -> 422) = tryAssert ValidationFailed False 109 | checkForStatus (viewResponse -> 500) = tryAssert InternalError False 110 | checkForStatus (viewResponse -> 400) = tryAssert InvalidJSON False 111 | checkForStatus (viewResponse -> _) = tryAssert AllOk True 112 | 113 | viewResponse :: Response a -> Int 114 | viewResponse = view (responseStatus . statusCode) 115 | 116 | isDeleted :: Int -> DidDelete 117 | isDeleted 204 = Deleted 118 | isDeleted 200 = Deleted 119 | isDeleted _ = NotDeleted 120 | -------------------------------------------------------------------------------- /src/Network/Octohat/Keys.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Network.Octohat.Keys (fingerprintFor) where 5 | 6 | import qualified Data.List as L 7 | import qualified Data.ByteString.Base64 as B64 8 | import qualified Data.ByteString.Base16 as B16 9 | import qualified Data.Text as T 10 | import qualified Data.Text.Encoding as TE 11 | import qualified Crypto.Hash.MD5 as MD5 -- eww 12 | 13 | import Network.Octohat.Types 14 | 15 | type RSAPublicKey = T.Text 16 | type Fingerprint = T.Text 17 | 18 | -- | Computes a fingerprint from its Base 64 encoded representation. Assumes leading @ssh-rsa @ (mind the space) 19 | -- prefix and no user@hostname suffix 20 | fingerprintFor :: PublicKey -> PublicKeyFingerprint 21 | fingerprintFor PublicKey{..} = PublicKeyFingerprint publicKeyId (digestToHex publicKey) 22 | 23 | digestToHex :: RSAPublicKey -> Fingerprint 24 | digestToHex = T.concat . 25 | L.intersperse ":" . 26 | T.chunksOf 2 . 27 | T.toLower . 28 | TE.decodeUtf8 . 29 | B16.encode . 30 | MD5.hash . 31 | B64.decodeLenient . 32 | TE.encodeUtf8 . 33 | T.replace "ssh-rsa " "" 34 | -------------------------------------------------------------------------------- /src/Network/Octohat/Members.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- | Execute the result of these functions using 'runGitHub' or 'runGitHub'' 4 | 5 | module Network.Octohat.Members 6 | ( membersForOrganization 7 | , teamsForOrganization 8 | , membersForTeam 9 | , reposForTeam 10 | , addMemberToTeam 11 | , addRepoToTeam 12 | , deleteMemberFromTeam 13 | , deleteTeamFromOrganization 14 | , publicKeysForUser 15 | , addTeamToOrganization 16 | , organizations 17 | , userForUsername 18 | , repoForReponame 19 | , addPublicKey 20 | , resetPage 21 | ) where 22 | 23 | import Network.Octohat.Internal 24 | import Network.Octohat.Types 25 | 26 | import qualified Data.Text as T 27 | import Data.Monoid ((<>)) 28 | 29 | -- | Takes a new team name, the description of a team and the organization where to create the team 30 | -- and creates a new team. Regular GitHub authorization/authentication applies. 31 | addTeamToOrganization :: TeamName -- ^ Name of new team 32 | -> T.Text -- ^ Description of new team 33 | -> TeamPermission -- ^ Permission setting for team (push, pull, or admin) 34 | -> OrganizationName -- ^ Organization name where the team will be created 35 | -> GitHub Team 36 | addTeamToOrganization (TeamName nameOfNewTeam) descOfTeam teamPerm (OrganizationName org) = 37 | postRequestTo (composeEndpoint ["orgs", org, "teams"]) (TeamCreateRequest nameOfNewTeam descOfTeam teamPerm) 38 | 39 | -- | Deletes a team from an organization using its team ID. 40 | deleteTeamFromOrganization :: Integer -- ^ ID of Team to delete 41 | -> GitHub DidDelete 42 | deleteTeamFromOrganization idOfTeam = deleteRequestTo (composeEndpoint ["teams", T.pack $ show idOfTeam]) 43 | 44 | -- | Returns a list of members of an organization with the given name. 45 | membersForOrganization :: OrganizationName -- ^ The organization name 46 | -> GitHub [Member] 47 | membersForOrganization (OrganizationName nameOfOrg) = getRequestPaginatedTo (composeEndpoint ["orgs", nameOfOrg, "members"]) 48 | 49 | -- | Returns a list of members of a team with the given team ID. 50 | membersForTeam :: Integer -- ^ The team ID 51 | -> GitHub [Member] 52 | membersForTeam idOfTeam = getRequestPaginatedTo (composeEndpoint ["teams", T.pack $ show idOfTeam, "members"]) 53 | 54 | -- | Returns a list of repos of a team with the given team ID. 55 | reposForTeam :: Integer -- ^ The team ID 56 | -> GitHub [Repo] 57 | reposForTeam idOfTeam = getRequestPaginatedTo (composeEndpoint ["teams", T.pack $ show idOfTeam, "repos"]) 58 | 59 | -- | Returns a list of teams for the organization with the given name 60 | teamsForOrganization :: OrganizationName -- ^ The organization name 61 | -> GitHub [Team] 62 | teamsForOrganization (OrganizationName nameOfOrg) = getRequestPaginatedTo (composeEndpoint ["orgs", nameOfOrg, "teams"]) 63 | 64 | -- | Returns a list of all organizations for the user 65 | organizations :: GitHub [Organization] 66 | organizations = getRequestPaginatedTo (composeEndpoint ["user", "orgs"]) 67 | 68 | -- | Adds a member to a team, might invite or add the member. Refer to 'StatusInTeam' 69 | addMemberToTeam :: T.Text -- ^ The GitHub username to add to a team 70 | -> Integer -- ^ The Team ID 71 | -> GitHub StatusInTeam 72 | addMemberToTeam nameOfUser idOfTeam = 73 | putRequestTo (composeEndpoint ["teams", T.pack $ show idOfTeam, "memberships", nameOfUser]) 74 | 75 | -- | Adds a repo to a team, might invite or add the member. Refer to 'StatusInTeam' 76 | addRepoToTeam :: OrganizationName -- ^ The GitHub organization name 77 | -> T.Text -- ^ The GitHub repo name 78 | -> Integer -- ^ The Team ID 79 | -> GitHub StatusInTeam 80 | addRepoToTeam (OrganizationName nameOfOrg) nameOfRepo idOfTeam = 81 | putRequestTo (composeEndpoint ["teams", T.pack $ show idOfTeam, "repos", nameOfOrg, nameOfRepo]) 82 | 83 | -- | Deletes a member with the given name from a team with the given ID. Might or might not delete 84 | deleteMemberFromTeam :: T.Text -- ^ GitHub username 85 | -> Integer -- ^ GitHub team ID 86 | -> GitHub DidDelete 87 | deleteMemberFromTeam nameOfUser idOfTeam = 88 | deleteRequestTo (composeEndpoint ["teams", T.pack $ show idOfTeam, "memberships", nameOfUser]) 89 | 90 | -- | Returns the public keys of the user with the given name 91 | publicKeysForUser :: T.Text -- ^ GitHub username 92 | -> GitHub [PublicKey] 93 | publicKeysForUser nameOfUser = getRequestPaginatedTo (composeEndpoint ["users", nameOfUser, "keys"]) 94 | 95 | -- | Finds a user ID given their username 96 | userForUsername :: T.Text -- ^ GitHub username 97 | -> GitHub Member 98 | userForUsername username = getRequestTo (composeEndpoint ["users", username]) 99 | 100 | -- | Finds a repo ID given their reponame 101 | repoForReponame :: T.Text -- ^ GitHub org 102 | -> T.Text -- ^ GitHub repo 103 | -> GitHub Repo 104 | repoForReponame org repo = getRequestTo (composeEndpoint ["repos", org, repo]) 105 | 106 | -- | Add a key for the currently authenticated user 107 | addPublicKey :: T.Text -- ^ Base64 RSA Key (ssh-rsa AA..) 108 | -> T.Text -- ^ Key title, e.g @octocat@stackbuilders@ 109 | -> GitHub PublicKey 110 | addPublicKey newKey newTitle = 111 | postRequestTo (composeEndpoint ["user", "keys"]) (AddPublicKeyRequest ("ssh-rsa " <> newKey) newTitle) 112 | -------------------------------------------------------------------------------- /src/Network/Octohat/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE CPP #-} 4 | 5 | module Network.Octohat.Types ( Member(..) 6 | , MemberWithKey(..) 7 | , Team(..) 8 | , TeamPermission(..) 9 | , Repo(..) 10 | , Organization(..) 11 | , BearerToken(..) 12 | , OrganizationName(..) 13 | , TeamName(..) 14 | , StatusInTeam(..) 15 | , EmptyBody(..) 16 | , DidDelete(..) 17 | , PublicKey(..) 18 | , PublicKeyFingerprint(..) 19 | , TeamCreateRequest(..) 20 | , GitHubReturnStatus(..) 21 | , DidAddKey(..) 22 | , AddPublicKeyRequest(..) 23 | , Links(..) 24 | , Pagination(..) 25 | , runGitHub 26 | , runGitHub' 27 | , GitHub) where 28 | import Control.Applicative 29 | import Control.Monad.Reader (ReaderT(..)) 30 | import Control.Monad.State (StateT(..), evalStateT) 31 | #if MIN_VERSION_errors(2,0,0) 32 | import Control.Monad.Trans.Except (ExceptT, runExceptT) 33 | #else 34 | import Control.Monad.Trans.Either 35 | #endif 36 | import Data.Aeson 37 | import Data.Aeson.TH 38 | import Data.Char (toLower) 39 | import Network.HTTP.Client 40 | import Network.Wreq.Types 41 | import System.Environment.Compat (lookupEnv) 42 | import qualified Data.HashMap.Strict as HS 43 | import qualified Data.Text as T 44 | 45 | -- | Represents a user in GitHub. Contains no more than login and user ID 46 | data Member = 47 | Member { memberLogin :: T.Text 48 | , memberId :: Integer 49 | } deriving (Show, Eq) 50 | 51 | -- | Represents the different permissions that a team can have in an organisation. 52 | data TeamPermission = OwnerAccess -- ^ Default team of owners. 53 | | PullAccess -- ^ This team will be able to view and clone its 54 | -- repositories. 55 | | PushAccess -- ^ This team will be able to read its 56 | -- repositories, as well as push to them. 57 | | AdminAccess -- ^ This team will be able to push/pull to its 58 | -- repositories, as well as add other 59 | -- collaborators to them. 60 | deriving (Show,Eq) 61 | 62 | -- | Represents a team in GitHub. Contains the team's ID, the team's name and an optional description 63 | data Team = 64 | Team { teamId :: Integer 65 | , teamName :: T.Text 66 | , teamDescription :: Maybe T.Text 67 | , teamPermission :: TeamPermission 68 | } deriving (Show, Eq) 69 | 70 | -- | Represents a request to create a new team within an organization. The rest of the paramaters 71 | -- are passed in the URL. Refer to 72 | data TeamCreateRequest = 73 | TeamCreateRequest { newTeamName :: T.Text 74 | , newTeamDescription :: T.Text 75 | , newTeamPermission :: TeamPermission 76 | } deriving (Show, Eq) 77 | 78 | -- | Represents an organisation in GitHub. Only has name and description 79 | data Organization = 80 | Organization 81 | { orgLogin :: T.Text 82 | , orgDescription :: Maybe T.Text 83 | } deriving (Show, Eq) 84 | 85 | -- | Represents a repo in GitHub. Contains the Name, Description, and Private status 86 | data Repo = 87 | Repo { repoName :: T.Text 88 | , repoDescription :: Maybe T.Text 89 | , repoPrivate :: Bool 90 | } deriving (Show, Eq) 91 | 92 | -- | Represents a GitHub user with its public keys and fingerprints. A GitHub user might or might not 93 | -- have any public keys 94 | data MemberWithKey = 95 | MemberWithKey { member :: Member 96 | , memberKey :: [PublicKey] 97 | , memberKeyFingerprint :: [PublicKeyFingerprint] 98 | } deriving (Show, Eq) 99 | 100 | -- | Represents a PublicKey within GitHub. It includes its ID and the public key encoded as base 64 101 | data PublicKey = 102 | PublicKey { publicKeyId :: Integer 103 | , publicKey :: T.Text 104 | } deriving (Show, Eq) 105 | 106 | -- | Represents a Fingerprint. The `fingerprintId` field should match the fingerprint's public key ID 107 | -- within GitHub 108 | data PublicKeyFingerprint = 109 | PublicKeyFingerprint { fingerprintId :: Integer 110 | , publicKeyFingerprint :: T.Text 111 | } deriving (Show, Eq) 112 | 113 | -- | Some Wreq functions expect a body, but often GitHub's API will request no body. The PUT verb 114 | -- and its implementation in Wreq is an example of this. 115 | data EmptyBody = EmptyBody deriving (Show, Eq) 116 | 117 | -- | When adding a user to a team GitHub will add it immediately if the user already belongs to the 118 | -- to the organization the team is in. Otherwise it will send an email for the user to accept the 119 | -- request to join the team. Functions related adding or removing teams will return either Active 120 | -- or Pending correspondingly. 121 | data StatusInTeam = Active | Pending deriving (Show, Eq) 122 | 123 | 124 | -- | Sum type to represent the success or failure of deletion of a resource within GitHub's API 125 | data DidDelete = Deleted | NotDeleted deriving (Show, Eq) 126 | 127 | instance FromJSON PublicKey where 128 | parseJSON (Object o) = PublicKey <$> o .: "id" <*> o .: "key" 129 | parseJSON _ = fail "Could not find public keys in document" 130 | 131 | data DidAddKey = KeyAdded | KeyNotAdded 132 | 133 | data AddPublicKeyRequest = 134 | AddPublicKeyRequest { 135 | addPublicKeyRequestKey :: T.Text, 136 | addPublicKeyRequestTitle :: T.Text 137 | } 138 | 139 | instance FromJSON StatusInTeam where 140 | parseJSON (Object o) = 141 | case HS.lookup "state" o of 142 | Just "active" -> pure Active 143 | Just "pending" -> pure Pending 144 | Just _ -> fail "\"state\" key not \"active\" or \"pending\"" 145 | Nothing -> (fail . maybe "No error message from GitHub" show) (HS.lookup "message" o) 146 | parseJSON _ = fail "Expected a membership document, got something else" 147 | 148 | instance FromJSON TeamPermission where 149 | parseJSON (String p) = 150 | case p of 151 | "pull" -> pure PullAccess 152 | "push" -> pure PushAccess 153 | "admin" -> pure AdminAccess 154 | "owner" -> pure OwnerAccess 155 | _ -> fail "Expected a valid team permission ?" 156 | parseJSON _ = fail "Expected a team permssion, got something else" 157 | 158 | instance ToJSON TeamPermission where 159 | toJSON p = 160 | case p of 161 | PullAccess -> String "pull" 162 | PushAccess -> String "push" 163 | AdminAccess -> String "admin" 164 | OwnerAccess -> String "owner" 165 | 166 | 167 | $(deriveJSON defaultOptions { fieldLabelModifier = drop 6 . map toLower } ''Member) 168 | $(deriveJSON defaultOptions { fieldLabelModifier = drop 4 . map toLower } ''Team) 169 | $(deriveJSON defaultOptions { fieldLabelModifier = drop 4 . map toLower } ''Repo) 170 | $(deriveJSON defaultOptions { fieldLabelModifier = drop 3 . map toLower } ''Organization) 171 | $(deriveJSON defaultOptions { fieldLabelModifier = drop 7 . map toLower } ''TeamCreateRequest) 172 | $(deriveJSON defaultOptions { fieldLabelModifier = drop 19 . map toLower } ''AddPublicKeyRequest) 173 | 174 | -- | Error codes GitHub might return when attempting to use an API endpoint 175 | data GitHubReturnStatus = InvalidJSON -- ^ GitHub could not parse the JSON document sent 176 | | ValidationFailed -- ^ Validation failed, an example of this error 177 | -- is trying to create teams with the same name 178 | -- within one organization 179 | | InternalError -- ^ In case GitHub returns 500 Internal Server Error 180 | -- to some request 181 | | NotFound -- ^ When a resource has not been found. It does not 182 | -- imply the resource does not exist 183 | | NotAllowed -- ^ Usually returned after GitHub replies with 403 Forbidden. 184 | -- The user might not have permission to access/modify 185 | -- that resource 186 | | AllOk -- ^ This should never be returned 187 | | RequiresAuthentication -- ^ Accesing this resource requires authentication 188 | | UnexpectedJSON String -- ^ This library has failed to fulfill its purpose and could not 189 | -- handle GitHub's response 190 | deriving (Show, Eq) 191 | 192 | -- | Instance that does not add anything to the body or headers of a PUT request 193 | instance Putable EmptyBody where 194 | putPayload EmptyBody req = return $ req {requestBody = RequestBodyLBS ""} 195 | 196 | instance Postable TeamCreateRequest where 197 | postPayload createRequest req = return $ req { requestBody = RequestBodyLBS (encode createRequest)} 198 | 199 | instance Postable AddPublicKeyRequest where 200 | postPayload createRequest req = return $ req { requestBody = RequestBodyLBS (encode createRequest)} 201 | 202 | -- | GitHub's OAuth 2.0 bearer token. This is simply added in an 203 | -- Authorization header 204 | newtype BearerToken = BearerToken { unBearerToken :: T.Text } deriving Show 205 | 206 | -- | OrganizationName is added in order to have type safety in functions where the 207 | -- Organization name and the Team name are both strings and may be confused 208 | newtype OrganizationName = OrganizationName { unOrganizationName :: T.Text } deriving Show 209 | 210 | -- | TeamName is added in order to have type safety in functions where the 211 | -- Team name and the Organization name are both strings and may be confused 212 | newtype TeamName = TeamName { unTeamName :: T.Text } deriving Show 213 | 214 | 215 | -- | Links are used in the Pagination object 216 | data Links = Links { linkNext :: Maybe Link, linkLast :: Maybe Link 217 | , linkFirst :: Maybe Link, linkPrev :: Maybe Link } deriving Show 218 | 219 | -- | Pagination options that can be set, including the page number, and the per_page 220 | data Pagination = Pagination { perPage :: Int, page :: Int, links :: Links, recurse :: Bool } deriving Show 221 | defPagination :: Pagination 222 | defPagination = Pagination 30 1 (Links Nothing Nothing Nothing Nothing) True 223 | 224 | -- | The monad transformer where all operations run. Supports initial configuration 225 | -- through a Reader monad and the possibility of failure through Either 226 | #if MIN_VERSION_errors(2,0,0) 227 | type GitHub = ExceptT GitHubReturnStatus (ReaderT BearerToken (StateT Pagination IO)) 228 | #else 229 | type GitHub = EitherT GitHubReturnStatus (ReaderT BearerToken (StateT Pagination IO)) 230 | #endif 231 | 232 | -- | Executes a computation built within the GitHub monad returning an Either within 233 | -- the IO data type using the provided token 234 | runGitHub' :: GitHub a -> BearerToken -> IO (Either GitHubReturnStatus a) 235 | #if MIN_VERSION_errors(2,0,0) 236 | runGitHub' comp token = evalStateT (runReaderT (runExceptT comp) token) defPagination 237 | #else 238 | runGitHub' comp token = evalStateT (runReaderT (runEitherT comp) token) defPagination 239 | #endif 240 | 241 | -- | Executes a computation built within the GitHub monad returning an Either within 242 | -- the IO data type. Reads an API token from an environment variable named GITHUB_TOKEN 243 | runGitHub :: GitHub a -> IO (Either GitHubReturnStatus a) 244 | runGitHub comp = do 245 | maybeToken <- lookupEnv "GITHUB_TOKEN" 246 | case maybeToken of 247 | Just acquiredToken -> runGitHub' comp (BearerToken $ T.pack acquiredToken) 248 | Nothing -> fail "Couldn't find GITHUB_TOKEN in environment" 249 | --------------------------------------------------------------------------------