diff --git a/Github/Data.hs b/Github/Data.hs index f5887ce2..74f9115c 100644 --- a/Github/Data.hs +++ b/Github/Data.hs @@ -4,23 +4,29 @@ -- instances of @FromJSON@ to it. If you wish to use the data without the -- instances, use the @Github.Data.Definitions@ module instead. -module Github.Data (module Github.Data.Definitions) where +module Github.Data (module X) where -import Data.Time import Control.Applicative + +import Data.Time.Format (parseTimeM) +import Data.Time.Locale.Compat (defaultTimeLocale) + import Control.Monad import qualified Data.Text as T import Data.Aeson.Types -import System.Locale (defaultTimeLocale) + import qualified Data.Vector as V import qualified Data.HashMap.Lazy as Map import Data.Hashable (Hashable) -import Github.Data.Definitions +import Github.Data.Definitions as X +import Github.Data.Teams as X + +import Prelude instance FromJSON GithubDate where parseJSON (String t) = - case parseTime defaultTimeLocale "%FT%T%Z" (T.unpack t) of + case parseTimeM True defaultTimeLocale "%FT%T%Z" (T.unpack t) of Just d -> pure $ GithubDate d _ -> fail "could not parse Github datetime" parseJSON _ = fail "Given something besides a String" @@ -48,7 +54,7 @@ instance FromJSON GitTree where parseJSON (Object o) = GitTree <$> o .: "type" <*> o .: "sha" - <*> o .: "url" + <*> o .:? "url" <*> o .:? "size" <*> o .: "path" <*> o .: "mode" @@ -128,6 +134,24 @@ instance ToJSON NewComment where instance ToJSON EditComment where toJSON (EditComment b) = object [ "body" .= b ] +instance ToJSON NewLabel where + toJSON (NewLabel n c) = + object [ + "name" .= n + , "color" .= c + ] + +instance ToJSON Assignees where + toJSON (Assignees as) = + object [ + "assignees" .= toJSON as + ] + +instance FromJSON Assignee where + parseJSON (Object o) = + Assignee + <$> o .: "login" + instance FromJSON Diff where parseJSON (Object o) = Diff <$> o .: "status" @@ -211,7 +235,7 @@ instance FromJSON Issue where <*> o .:? "closed_by" <*> o .: "labels" <*> o .: "number" - <*> o .:? "assignee" + <*> o .: "assignees" <*> o .: "user" <*> o .: "title" <*> o .:? "pull_request" @@ -404,6 +428,12 @@ instance FromJSON SearchReposResult where <*> o .:< "items" parseJSON _ = fail "Could not build a SearchReposResult" +instance FromJSON SearchIssuesResult where + parseJSON (Object o) = + SearchIssuesResult <$> o .: "total_count" + <*> o .:< "items" + parseJSON _ = fail "Could not build a SearchIssuesResult" + instance FromJSON Repo where parseJSON (Object o) = Repo <$> o .: "ssh_url" @@ -431,8 +461,8 @@ instance FromJSON Repo where <*> o .:? "has_wiki" <*> o .:? "has_issues" <*> o .:? "has_downloads" - <*> o .:? "parent" - <*> o .:? "source" + <*> o .:? "parent" + <*> o .:? "source" parseJSON _ = fail "Could not build a Repo" instance FromJSON RepoRef where @@ -520,6 +550,24 @@ instance FromJSON DetailedOwner where parseJSON _ = fail "Could not build a DetailedOwner" +instance FromJSON Hook where + parseJSON (Object o) = Hook <$> o .: "id" + <*> o .: "config" + <*> o .: "active" + <*> o .: "events" + <*> o .: "name" + <*> o .: "created_at" + <*> o .: "updated_at" + parseJSON _ = fail "Could not build a Hook" + +instance FromJSON Team where + parseJSON (Object o) = + Team + <$> (TeamName <$> o .: "name") + <*> o .: "id" + parseJSON _ = + fail "Could not build a Team" + -- | A slightly more generic version of Aeson's @(.:?)@, using `mzero' instead -- of `Nothing'. (.:<) :: (FromJSON a) => Object -> T.Text -> Parser [a] diff --git a/Github/Data/Definitions.hs b/Github/Data/Definitions.hs index acf65e17..ea0acf98 100644 --- a/Github/Data/Definitions.hs +++ b/Github/Data/Definitions.hs @@ -5,6 +5,7 @@ module Github.Data.Definitions where import Data.Time import Data.Data import qualified Control.Exception as E +import qualified Data.Map as M -- | Errors have been tagged according to their source, so you can more easily -- dispatch and handle them. @@ -39,7 +40,8 @@ data Tree = Tree { data GitTree = GitTree { gitTreeType :: String ,gitTreeSha :: String - ,gitTreeUrl :: String + -- Can be empty for submodule + ,gitTreeUrl :: Maybe String ,gitTreeSize :: Maybe Int ,gitTreePath :: String ,gitTreeMode :: String @@ -190,7 +192,7 @@ data Issue = Issue { ,issueClosedBy :: Maybe GithubOwner ,issueLabels :: [IssueLabel] ,issueNumber :: Int - ,issueAssignee :: Maybe GithubOwner + ,issueAssignee :: [GithubOwner] ,issueUser :: GithubOwner ,issueTitle :: String ,issuePullRequest :: Maybe PullRequestReference @@ -263,7 +265,7 @@ data EventType = | Referenced -- ^ The issue was referenced from a commit message. The commit_id attribute is the commit SHA1 of where that happened. | Merged -- ^ The issue was merged by the actor. The commit_id attribute is the SHA1 of the HEAD commit that was merged. | Assigned -- ^ The issue was assigned to the actor. - | Closed -- ^ The issue was closed by the actor. When the commit_id is present, it identifies the commit that closed the issue using “closes / fixes #NN” syntax. + | Closed -- ^ The issue was closed by the actor. When the commit_id is present, it identifies the commit that closed the issue using “closes / fixes #NN” syntax. | Reopened -- ^ The issue was reopened by the actor. deriving (Show, Data, Typeable, Eq, Ord) @@ -369,6 +371,11 @@ data SearchReposResult = SearchReposResult { ,searchReposRepos :: [ Repo ] } deriving (Show, Data, Typeable, Eq, Ord) +data SearchIssuesResult = SearchIssuesResult { + searchIssuesTotalCount :: Int + ,searchIssuesIssues :: [ Issue ] +} deriving (Show, Data, Typeable, Eq, Ord) + data Repo = Repo { repoSshUrl :: String ,repoDescription :: Maybe String @@ -475,3 +482,68 @@ data DetailedOwner = DetailedUser { ,detailedOwnerHtmlUrl :: String ,detailedOwnerLogin :: String } deriving (Show, Data, Typeable, Eq, Ord) + +data Hook = Hook { + hookId :: Integer + ,hookConfig :: M.Map String String + ,hookActive :: Bool + ,hookEvents :: [String] + ,hookName :: String + ,hookCreatedAt :: GithubDate + ,hookUpdatedAt :: GithubDate +} deriving (Show, Data, Typeable, Eq, Ord) + +data Protection = + Protection { + requiredStatusChecks :: Maybe RequiredStatusChecks + , pushRestrictions :: Maybe PushRestrictions + } deriving (Show, Data, Typeable, Eq, Ord) + +data RequiredStatusChecks = + RequiredStatusChecks { + enforcementLevel :: EnforcementLevel + , strict :: Bool + , context :: [String] + } deriving (Show, Data, Typeable, Eq, Ord) + +data EnforcementLevel = + Everyone + | NotAdmins + deriving (Show, Data, Typeable, Eq, Ord) + +data PushRestrictions = + PushRestrictions [User] [TeamName] + deriving (Show, Data, Typeable, Eq, Ord) + +newtype User = + User { + user :: String + } deriving (Show, Data, Typeable, Eq, Ord) + +data Team = + Team { + teamName :: TeamName + , teamId :: Integer + } deriving (Show, Data, Typeable, Eq, Ord) + +newtype TeamName = + TeamName { + team :: String + } deriving (Show, Data, Typeable, Eq, Ord) + +-- https://developer.github.com/v3/issues/labels/#create-a-label +data NewLabel = + NewLabel { + newLabelName :: String + , newLabelColor :: String + } deriving (Show, Data, Typeable, Eq, Ord) + +newtype Assignees = + Assignees { + assignees :: [String] + } deriving (Show, Data, Typeable, Eq, Ord) + +newtype Assignee = + Assignee { + assigneeLogin :: String + } deriving (Show, Data, Typeable, Eq, Ord) diff --git a/Github/Data/Teams.hs b/Github/Data/Teams.hs new file mode 100644 index 00000000..b6599df3 --- /dev/null +++ b/Github/Data/Teams.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE OverloadedStrings #-} +module Github.Data.Teams ( + Permission (..) + ) where + +import Data.Aeson + +import Data.Text (Text) + +data Permission = + PermissionPull + | PermissionPush + | PermissionAdmin + deriving (Show, Enum, Bounded, Eq, Ord) + +-- https://developer.github.com/v3/orgs/teams/#add-or-update-team-repository +renderPermission :: Permission -> Text +renderPermission p = + case p of + PermissionPull -> + "pull" + PermissionPush -> + "push" + PermissionAdmin -> + "admin" + +instance ToJSON Permission where + toJSON p = + object [ + "permission" .= renderPermission p + ] diff --git a/Github/GitData/Trees.hs b/Github/GitData/Trees.hs index ce7d04c2..8ebe2052 100644 --- a/Github/GitData/Trees.hs +++ b/Github/GitData/Trees.hs @@ -19,7 +19,7 @@ tree user reqRepoName sha = -- | A recursively-nested tree for a SHA1. -- -- > nestedTree "thoughtbot" "paperclip" "fe114451f7d066d367a1646ca7ac10e689b46844" -nestedTree :: String -> String -> String -> IO (Either Error Tree) -nestedTree user reqRepoName sha = - githubGetWithQueryString ["repos", user, reqRepoName, "git", "trees", sha] +nestedTree :: Maybe GithubAuth -> String -> String -> String -> IO (Either Error Tree) +nestedTree auth user reqRepoName sha = + githubGetWithQueryString' auth ["repos", user, reqRepoName, "git", "trees", sha] "recursive=1" diff --git a/Github/Issues.hs b/Github/Issues.hs index 88bea3fa..8875f906 100644 --- a/Github/Issues.hs +++ b/Github/Issues.hs @@ -16,9 +16,9 @@ module Github.Issues ( import Github.Data import Github.Private import Data.List (intercalate) -import Data.Time.Format (formatTime) -import System.Locale (defaultTimeLocale) import Data.Time.Clock (UTCTime(..)) +import Data.Time.Format (formatTime) +import Data.Time.Locale.Compat (defaultTimeLocale) -- | A data structure for describing how to filter issues. This is used by -- @issuesForRepo@. diff --git a/Github/Issues/Assignees.hs b/Github/Issues/Assignees.hs new file mode 100644 index 00000000..9b3836f8 --- /dev/null +++ b/Github/Issues/Assignees.hs @@ -0,0 +1,23 @@ +-- | The Github issues assignees events API, which is described on +-- +module Github.Issues.Assignees ( + listAssignees +,addAssignee +,removeAssignee +,module Github.Data +) where + +import Github.Data +import Github.Private + +listAssignees :: GithubAuth -> String -> String -> IO (Either Error [Assignee]) +listAssignees auth user reqRepoName = + githubGet' (Just auth) ["repos", user, reqRepoName, "assignees"] + +addAssignee :: GithubAuth -> String -> String -> String -> Assignees -> IO (Either Error Issue) +addAssignee auth user reqRepoName issueNumber assignees = + githubPost auth ["repos", user, reqRepoName, "issues", issueNumber, "assignees"] assignees + +removeAssignee :: GithubAuth -> String -> String -> String -> Assignees -> IO (Either Error Issue) +removeAssignee auth user reqRepoName issueNumber assignees = + githubDeleteBody auth ["repos", user, reqRepoName, "issues", issueNumber, "assignees"] assignees diff --git a/Github/Issues/Labels.hs b/Github/Issues/Labels.hs index 44db680e..48726b78 100644 --- a/Github/Issues/Labels.hs +++ b/Github/Issues/Labels.hs @@ -3,8 +3,14 @@ module Github.Issues.Labels ( label ,labelsOnRepo +,labelsOnRepo' ,labelsOnIssue ,labelsOnMilestone +,createLabel +,applyLabels +,listLabels +,removeLabels +,removeAllLabels ,module Github.Data ) where @@ -17,6 +23,10 @@ import Github.Private labelsOnRepo :: String -> String -> IO (Either Error [IssueLabel]) labelsOnRepo user reqRepoName = githubGet ["repos", user, reqRepoName, "labels"] +labelsOnRepo' :: GithubAuth -> String -> String -> IO (Either Error [IssueLabel]) +labelsOnRepo' auth user reqRepoName = + githubGet' (Just auth) ["repos", user, reqRepoName, "labels"] + -- | The labels on an issue in a repo. -- -- > labelsOnIssue "thoughtbot" "paperclip" 585 @@ -37,3 +47,26 @@ labelsOnMilestone user reqRepoName milestoneId = label :: String -> String -> String -> IO (Either Error IssueLabel) label user reqRepoName reqLabelName = githubGet ["repos", user, reqRepoName, "labels", reqLabelName] + +-- https://developer.github.com/v3/issues/labels/#create-a-label +createLabel :: GithubAuth -> String -> String -> NewLabel -> IO (Either Error IssueLabel) +createLabel auth user reqRepoName label = + githubPost auth ["repos", user, reqRepoName, "labels"] label + +-- https://developer.github.com/v3/issues/labels/#add-labels-to-an-issue +applyLabels :: GithubAuth -> String -> String -> String -> [String] -> IO (Either Error [IssueLabel]) +applyLabels auth user reqRepoName issueNumber l = + githubPost auth ["repos", user, reqRepoName, "issues", issueNumber, "labels"] l + +listLabels :: GithubAuth -> String -> String -> String -> IO (Either Error [IssueLabel]) +listLabels auth user reqRepoName issueNumber = + githubGet' (Just auth) ["repos", user, reqRepoName, "issues", issueNumber, "labels"] + +-- https://developer.github.com/v3/issues/labels/#remove-a-label-from-an-issue +--removeLabels :: GithubAuth -> String -> String -> String -> String -> IO (Either SomeException (Response LBS.ByteString)) +removeLabels auth user reqRepoName issueNumber l = + githubDelete auth ["repos", user, reqRepoName, "issues", issueNumber, "labels", l] + +--removeAllLabels :: GithubAuth -> String -> String -> String -> IO (Either SomeException (Response LBS.ByteString)) +removeAllLabels auth user reqRepoName issueNumber = + githubDelete auth ["repos", user, reqRepoName, "issues", issueNumber, "labels"] diff --git a/Github/Organizations.hs b/Github/Organizations.hs index db42dec3..9e17435a 100644 --- a/Github/Organizations.hs +++ b/Github/Organizations.hs @@ -4,6 +4,7 @@ module Github.Organizations ( ,publicOrganizationsFor' ,publicOrganization ,publicOrganization' +,addTeamToRepo ,module Github.Data ) where @@ -33,3 +34,8 @@ publicOrganization' auth reqOrganizationName = githubGet' auth ["orgs", reqOrgan -- > publicOrganization "thoughtbot" publicOrganization :: String -> IO (Either Error Organization) publicOrganization = publicOrganization' Nothing + +-- PUT /teams/:id/repos/:org/:repo +--addTeamToRepo :: Int +addTeamToRepo auth teamId orgName projectName permission = do + githubPutBody auth ["teams", show teamId, "repos", orgName, projectName] permission diff --git a/Github/Organizations/Members.hs b/Github/Organizations/Members.hs index 1506d433..465af101 100644 --- a/Github/Organizations/Members.hs +++ b/Github/Organizations/Members.hs @@ -2,6 +2,7 @@ -- . module Github.Organizations.Members ( membersOf +,membersOf' ,module Github.Data ) where @@ -13,3 +14,6 @@ import Github.Private -- > membersOf "thoughtbot" membersOf :: String -> IO (Either Error [GithubOwner]) membersOf organization = githubGet ["orgs", organization, "members"] + +membersOf' :: Maybe GithubAuth -> String -> IO (Either Error [GithubOwner]) +membersOf' auth organization = githubGet' auth ["orgs", organization, "members"] diff --git a/Github/Organizations/Teams.hs b/Github/Organizations/Teams.hs new file mode 100644 index 00000000..fa874e0e --- /dev/null +++ b/Github/Organizations/Teams.hs @@ -0,0 +1,18 @@ +-- | The organization members API as described on +-- . +module Github.Organizations.Teams ( + listTeams' +,listTeamMembers' +,module Github.Data +) where + +import Github.Data +import Github.Private + +listTeams' :: Maybe GithubAuth -> String -> IO (Either Error [Team]) +listTeams' auth organization = + githubGet' auth ["orgs", organization, "teams"] + +listTeamMembers' :: Maybe GithubAuth -> Integer -> IO (Either Error [GithubOwner]) +listTeamMembers' auth teamId = + githubGet' auth ["teams", show teamId, "members"] diff --git a/Github/Private.hs b/Github/Private.hs index 97e515b4..c8624684 100644 --- a/Github/Private.hs +++ b/Github/Private.hs @@ -1,19 +1,24 @@ -{-# LANGUAGE OverloadedStrings, StandaloneDeriving, DeriveDataTypeable #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings, StandaloneDeriving, DeriveDataTypeable, FlexibleContexts #-} module Github.Private where import Github.Data + +import Control.Applicative import Data.Aeson import Data.Attoparsec.ByteString.Lazy import Data.Data import Data.Monoid -import Control.Applicative import Data.List +import qualified Data.Text as T +import Data.Tuple (swap) import Data.CaseInsensitive (mk) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS import Network.HTTP.Types (Status(..)) import Network.HTTP.Conduit + +import Prelude + -- import Data.Conduit (ResourceT) import qualified Control.Exception as E import Data.Maybe (fromMaybe) @@ -29,6 +34,7 @@ githubGet = githubGet' Nothing githubGet' :: (FromJSON b, Show b) => Maybe GithubAuth -> [String] -> IO (Either Error b) githubGet' auth paths = githubAPI (BS.pack "GET") + Nothing (buildUrl paths) auth (Nothing :: Maybe Value) @@ -39,6 +45,7 @@ githubGetWithQueryString = githubGetWithQueryString' Nothing githubGetWithQueryString' :: (FromJSON b, Show b) => Maybe GithubAuth -> [String] -> String -> IO (Either Error b) githubGetWithQueryString' auth paths qs = githubAPI (BS.pack "GET") + Nothing (buildUrl paths ++ "?" ++ qs) auth (Nothing :: Maybe Value) @@ -46,6 +53,19 @@ githubGetWithQueryString' auth paths qs = githubPost :: (ToJSON a, Show a, FromJSON b, Show b) => GithubAuth -> [String] -> a -> IO (Either Error b) githubPost auth paths body = githubAPI (BS.pack "POST") + Nothing + (buildUrl paths) + (Just auth) + (Just body) + +githubDelete auth paths = do + r <- doHttps "DELETE" Nothing (buildUrl paths) (Just auth) Nothing + return r + +githubDeleteBody :: (ToJSON a, Show a, FromJSON b, Show b) => GithubAuth -> [String] -> a -> IO (Either Error b) +githubDeleteBody auth paths body = do + githubAPI (BS.pack "DELETE") + Nothing (buildUrl paths) (Just auth) (Just body) @@ -53,17 +73,30 @@ githubPost auth paths body = githubPatch :: (ToJSON a, Show a, FromJSON b, Show b) => GithubAuth -> [String] -> a -> IO (Either Error b) githubPatch auth paths body = githubAPI (BS.pack "PATCH") + Nothing (buildUrl paths) (Just auth) (Just body) +githubPut auth paths = do + r <- doHttps "PUT" Nothing (buildUrl paths) (Just auth) Nothing + return r + +githubPutBody auth paths p = do + r <- doHttps "PUT" Nothing (buildUrl paths) (Just auth) $ fmap (RequestBodyLBS . encode) p + return r + +githubPutBodyMedia auth paths m p = do + r <- doHttps "PUT" m (buildUrl paths) (Just auth) $ fmap (RequestBodyLBS . encode) p + return r + buildUrl :: [String] -> String buildUrl paths = "https://api.github.com/" ++ intercalate "/" paths -githubAPI :: (ToJSON a, Show a, FromJSON b, Show b) => BS.ByteString -> String +githubAPI :: (ToJSON a, Show a, FromJSON b, Show b) => BS.ByteString -> Maybe BS.ByteString -> String -> Maybe GithubAuth -> Maybe a -> IO (Either Error b) -githubAPI apimethod url auth body = do - result <- doHttps apimethod url auth (encodeBody body) +githubAPI apimethod mversion url auth body = do + result <- doHttps apimethod mversion url auth (encodeBody body) case result of Left e -> return (Left (HTTPConnectionError e)) Right resp -> either Left (\x -> jsonResultToE (LBS.pack (show x)) @@ -94,23 +127,25 @@ githubAPI apimethod url auth body = do nextJson <- handleBody nextResp return $ (\(Array x) -> Array (ary <> x)) <$> nextJson) - =<< doHttps apimethod nu auth Nothing + =<< doHttps apimethod mversion nu auth Nothing handleJson _ gotjson = return (Right gotjson) - getNextUrl l = - if "rel=\"next\"" `isInfixOf` l - then let s = l - s' = Data.List.tail $ Data.List.dropWhile (/= '<') s - in Just (Data.List.takeWhile (/= '>') s') - else Nothing +getNextUrl :: String -> Maybe String +getNextUrl = + let + p = + T.takeWhile (/= '>') . T.tail . T.dropWhile (/= '<') + in + fmap (T.unpack . p) . lookup "rel=\"next\"" . fmap (swap . fmap (T.strip . T.drop 1) . T.breakOn ";") . T.splitOn "," . T.pack --- doHttps :: Method -> String -> Maybe GithubAuth +-- doHttps :: Method -> Maybe ByteString -> String -> Maybe GithubAuth -- -> Maybe (RequestBody (ResourceT IO)) -- -> IO (Either E.SomeException (Response LBS.ByteString)) -doHttps reqMethod url auth body = do +doHttps reqMethod mversion url auth body = do let reqBody = fromMaybe (RequestBodyBS $ BS.pack "") body reqHeaders = maybe [] getOAuth auth Just uri = parseUrl url + version = maybe "application/vnd.github.preview" id mversion request = uri { method = reqMethod , secure = True , port = 443 @@ -118,7 +153,7 @@ doHttps reqMethod url auth body = do , responseTimeout = Just 20000000 , requestHeaders = reqHeaders <> [("User-Agent", "github.hs/0.7.4")] - <> [("Accept", "application/vnd.github.preview")] + <> [("Accept", version)] , checkStatus = successOrMissing } authRequest = getAuthRequest auth request @@ -138,17 +173,9 @@ doHttps reqMethod url auth body = do BS.pack ("token " ++ token))] getOAuth _ = [] getResponse request = withManager $ \manager -> httpLbs request manager -#if MIN_VERSION_http_conduit(1, 9, 0) successOrMissing s@(Status sci _) hs cookiejar -#else - successOrMissing s@(Status sci _) hs -#endif | (200 <= sci && sci < 300) || sci == 404 = Nothing -#if MIN_VERSION_http_conduit(1, 9, 0) | otherwise = Just $ E.toException $ StatusCodeException s hs cookiejar -#else - | otherwise = Just $ E.toException $ StatusCodeException s hs -#endif parseJsonRaw :: LBS.ByteString -> Either Error Value parseJsonRaw jsonString = diff --git a/Github/PullRequests.hs b/Github/PullRequests.hs index b3cf400d..567d485b 100644 --- a/Github/PullRequests.hs +++ b/Github/PullRequests.hs @@ -2,6 +2,7 @@ -- . module Github.PullRequests ( pullRequestsFor' +,pullRequestsWith' ,pullRequest' ,pullRequestCommits' ,pullRequestFiles' @@ -23,6 +24,14 @@ pullRequestsFor' :: Maybe GithubAuth -> String -> String -> IO (Either Error [Pu pullRequestsFor' auth userName reqRepoName = githubGet' auth ["repos", userName, reqRepoName, "pulls"] +-- | All pull requests for the repo, by owner and repo name. +-- | With authentification +-- +-- > pullRequestsWith' (Just ("github-username", "github-password")) "rails" "rails" +pullRequestsWith' :: Maybe GithubAuth -> String -> String -> String -> IO (Either Error [PullRequest]) +pullRequestsWith' auth userName reqRepoName state = + githubGetWithQueryString' auth ["repos", userName, reqRepoName, "pulls"] ("state=" ++ state) + -- | All pull requests for the repo, by owner and repo name. -- -- > pullRequestsFor "rails" "rails" diff --git a/Github/Repos.hs b/Github/Repos.hs index 704f6c08..0963d196 100644 --- a/Github/Repos.hs +++ b/Github/Repos.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} -- | The Github Repos API, as documented at -- module Github.Repos ( @@ -25,7 +24,9 @@ module Github.Repos ( ,createRepo ,createOrganizationRepo ,newRepo +,newOrgRepo ,NewRepo(..) +,NewOrgRepo(..) -- ** Edit ,editRepo @@ -102,7 +103,7 @@ organizationRepo = organizationRepo' Nothing -- -- > organizationRepo (Just (GithubUser (user, password))) "thoughtbot" "github" organizationRepo' :: Maybe GithubAuth -> String -> String -> IO (Either Error Repo) -organizationRepo' auth orgName reqRepoName = githubGet' auth ["orgs", orgName, reqRepoName] +organizationRepo' auth orgName reqRepoName = githubGet' auth ["repos", orgName, reqRepoName] -- | Details on a specific repo, given the owner and repo name. -- @@ -187,9 +188,52 @@ instance ToJSON NewRepo where , "auto_init" .= autoInit ] +data NewOrgRepo = NewOrgRepo { + newOrgRepoName :: String +, newOrgRepoDescription :: (Maybe String) +, newOrgRepoHomepage :: (Maybe String) +, newOrgRepoPrivate :: (Maybe Bool) +, newOrgRepoHasIssues :: (Maybe Bool) +, newOrgRepoHasWiki :: (Maybe Bool) +, newOrgRepoHasDownloads :: (Maybe Bool) +, newOrgRepoTeamId :: (Maybe Integer) +, newOrgRepoAutoInit :: (Maybe Bool) +, newOrgRepoGitIgnore :: (Maybe String) +, newOrgRepoLicense :: (Maybe String) +} deriving Show + +instance ToJSON NewOrgRepo where + toJSON (NewOrgRepo { newOrgRepoName = name + , newOrgRepoDescription = description + , newOrgRepoHomepage = homepage + , newOrgRepoPrivate = private + , newOrgRepoHasIssues = hasIssues + , newOrgRepoHasWiki = hasWiki + , newOrgRepoHasDownloads = hasDownloads + , newOrgRepoTeamId = teamId + , newOrgRepoAutoInit = autoInit + , newOrgRepoGitIgnore = gitIgnore + , newOrgRepoLicense = license + }) = object + [ "name" .= name + , "description" .= description + , "homepage" .= homepage + , "private" .= private + , "has_issues" .= hasIssues + , "has_wiki" .= hasWiki + , "has_downloads" .= hasDownloads + , "team_id" .= teamId + , "auto_init" .= autoInit + , "gitignore_template" .= gitIgnore + , "license" .= license + ] + newRepo :: String -> NewRepo newRepo name = NewRepo name Nothing Nothing Nothing Nothing Nothing Nothing +newOrgRepo :: String -> NewOrgRepo +newOrgRepo name = NewOrgRepo name Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + -- | -- Create a new repository. -- @@ -201,7 +245,7 @@ createRepo auth = githubPost auth ["user", "repos"] -- Create a new repository for an organization. -- -- > createOrganizationRepo (GithubUser (user, password)) "thoughtbot" (newRepo "some_repo") {newRepoHasIssues = Just False} -createOrganizationRepo :: GithubAuth -> String -> NewRepo -> IO (Either Error Repo) +createOrganizationRepo :: GithubAuth -> String -> NewOrgRepo -> IO (Either Error Repo) createOrganizationRepo auth org = githubPost auth ["orgs", org, "repos"] data Edit = Edit { @@ -258,7 +302,7 @@ deleteRepo :: GithubAuth -> String -- ^ repository name -> IO (Either Error ()) deleteRepo auth owner repo = do - result <- doHttps "DELETE" url (Just auth) Nothing + result <- doHttps "DELETE" Nothing url (Just auth) Nothing case result of Left e -> return (Left (HTTPConnectionError e)) Right resp -> @@ -271,9 +315,7 @@ deleteRepo auth owner repo = do then return (Left (HTTPConnectionError (E.toException (StatusCodeException status headers -#if MIN_VERSION_http_conduit(1, 9, 0) (responseCookieJar resp) -#endif )))) else return (Right ()) where diff --git a/Github/Repos/Branches.hs b/Github/Repos/Branches.hs new file mode 100644 index 00000000..b4cd01c3 --- /dev/null +++ b/Github/Repos/Branches.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | The repo starring API as described on +-- . +module Github.Repos.Branches ( + protect + ) where + +import Data.Aeson +import qualified Data.ByteString.Char8 as BS + +import Github.Data +import Github.Private + +import qualified Network.HTTP.Conduit as C (responseStatus) +import qualified Network.HTTP.Types as T (statusCode) + + +-- https://developer.github.com/v3/repos/branches/#update-branch-protection +--protect :: GithubAuth -> String -> String -> String -> Protection -> IO (Either SomeException ()) +protect auth userName reqRepoName branch protection = do + githubPutBodyMedia + auth + ["repos", userName, reqRepoName, "branches", branch, "protection"] + (Just "application/vnd.github.loki-preview+json") + protection + + +instance ToJSON Protection where + toJSON (Protection r p) = + object [ + ("required_status_checks", maybeOrNull r $ \(RequiredStatusChecks e s c) -> + object [ + "include_admins" .= case e of { Everyone -> True; NotAdmins -> False } + , "strict" .= s + , "contexts" .= toJSON c + ]) + , ("restrictions", maybeOrNull p $ \(PushRestrictions us ts) -> + object [ + "users" .= toJSON (fmap user us) + , "teams" .= toJSON (fmap team ts) + ]) + ] + +maybeOrNull :: Maybe a -> (a -> Value) -> Value +maybeOrNull m f = + case m of + Nothing -> + Null + Just a -> + f a diff --git a/Github/Repos/Collaborators.hs b/Github/Repos/Collaborators.hs index 6cca521b..4e93143c 100644 --- a/Github/Repos/Collaborators.hs +++ b/Github/Repos/Collaborators.hs @@ -3,6 +3,7 @@ module Github.Repos.Collaborators ( collaboratorsOn ,isCollaboratorOn +,removeCollaborator ,module Github.Data ) where @@ -28,6 +29,19 @@ collaboratorsOn userName reqRepoName = isCollaboratorOn :: String -> String -> String -> IO (Either Error Bool) isCollaboratorOn userName repoOwnerName reqRepoName = do result <- doHttps (pack "GET") + Nothing + (buildUrl ["repos", repoOwnerName, reqRepoName, "collaborators", userName]) + Nothing + Nothing + return $ either (Left . HTTPConnectionError) + (Right . (204 ==) . T.statusCode . C.responseStatus) + result + + +removeCollaborator :: String -> String -> String -> IO (Either Error Bool) +removeCollaborator userName repoOwnerName reqRepoName = do + result <- doHttps (pack "DELETE") + Nothing (buildUrl ["repos", repoOwnerName, reqRepoName, "collaborators", userName]) Nothing Nothing diff --git a/Github/Repos/Hooks.hs b/Github/Repos/Hooks.hs new file mode 100644 index 00000000..92d62abc --- /dev/null +++ b/Github/Repos/Hooks.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | The repo starring API as described on +-- . +module Github.Repos.Hooks ( + hooksFor +,singleHook +,createHook +,testHook +,module Github.Data +) where + +import Github.Data +import Github.Private + +import Data.Aeson (Value(String, Bool, Array), toJSON) +import qualified Data.Map as M +import Data.Text (pack, Text) +import qualified Data.Vector as V + +hooksFor :: GithubAuth -> String -> String -> IO (Either Error [Hook]) +hooksFor auth userName reqRepoName = + githubGet' (Just auth) ["repos", userName, reqRepoName, "hooks"] + +singleHook :: GithubAuth -> String -> String -> Integer -> IO (Either Error Hook) +singleHook auth userName reqRepoName hid = + githubGet' (Just auth) ["repos", userName, reqRepoName, "hooks", show hid] + +createHook :: GithubAuth -> String -> String -> String -> M.Map String String -> Maybe [String] -> Maybe Bool -> IO (Either Error Hook) +createHook auth userName reqRepoName hookName hookConfig hookEvents hookActive = + githubPost auth ["repos", userName, reqRepoName, "hooks"] + $ M.fromList $ ("name", String (pack hookName)) + : ("config", toJSON hookConfig) + : concat + [ jinA "events" hookEvents + , jinB "active" hookActive + ] + +-- Edit a hook: TODO + +testHook :: GithubAuth -> String -> String -> Integer -> IO (Either Error ()) +testHook auth userName reqRepoName hid = + githubPost auth ["repos", userName, reqRepoName, "hooks", show hid] () + +-- deleteHook :: GithubAuth -> String -> String -> Integer -> IO (Either Error ()) +-- deleteHook auth userName reqRepoName hid = +-- githubDelete auth ["repos", userName, reqRepoName, "hooks", show hid] () + +-- json kludge +jinA :: String -> Maybe [String] -> [(Text, Value)] +jinA k (Just x) = [(pack k, toJSON x)] +jinA _ Nothing = [] + +jinS :: String -> Maybe String -> [(Text, Value)] +jinS k (Just x) = [(pack k, String (pack x))] +jinS _ Nothing = [] + +jinB :: String -> Maybe Bool -> [(Text, Value)] +jinB k (Just x) = [(pack k, Bool x)] +jinB _ Nothing = [] diff --git a/Github/Search.hs b/Github/Search.hs index 41fe84a3..79791c70 100644 --- a/Github/Search.hs +++ b/Github/Search.hs @@ -1,7 +1,9 @@ -- | The Github Search API, as described at -- . module Github.Search( - searchRepos' + searchIssues' +,searchIssues +,searchRepos' ,searchRepos ,module Github.Data ) where @@ -23,3 +25,17 @@ searchRepos' auth queryString = githubGetWithQueryString' auth ["search/reposito searchRepos :: String -> IO (Either Error SearchReposResult) searchRepos = searchRepos' Nothing +-- | Perform an issue search. +-- | With authentication. +-- +-- > searchIssues' (Just $ GithubBasicAuth "github-username" "github-password') "q=is%3Aopen" +searchIssues' :: Maybe GithubAuth -> String -> IO (Either Error SearchIssuesResult) +searchIssues' auth queryString = githubGetWithQueryString' auth ["search/issues"] queryString + +-- | Perform an issue search. +-- | Without authentication. +-- +-- > searchIssues "q=is%3Aopen" +searchIssues :: String -> IO (Either Error SearchIssuesResult) +searchIssues = searchIssues' Nothing + diff --git a/bin/build b/bin/build new file mode 100755 index 00000000..96a989e3 --- /dev/null +++ b/bin/build @@ -0,0 +1,12 @@ +#!/bin/sh -euvx + +export GHC_VERSION="7.10.2" +export CABAL_VERSION="1.22.4.0" + + +GHC_PATH=$(ghc-path) +export PATH=$GHC_PATH:$PATH +CABAL_PATH=$(cabal-path) +export PATH=$CABAL_PATH:$PATH + +./mafia build -w diff --git a/boris-git.toml b/boris-git.toml new file mode 100644 index 00000000..48994499 --- /dev/null +++ b/boris-git.toml @@ -0,0 +1,8 @@ +[boris] + version = 1 + +[build.dist] + git = "refs/heads/master" + +[build.branches] + git = "refs/heads/topic/*" diff --git a/boris.toml b/boris.toml new file mode 100644 index 00000000..eff6ba6e --- /dev/null +++ b/boris.toml @@ -0,0 +1,8 @@ +[boris] + version = 1 + +[build.dist] + command = [["bin/build"]] + +[build.branches] + command = [["bin/build"]] diff --git a/github.cabal b/github.cabal index e9cfafd8..5707c889 100644 --- a/github.cabal +++ b/github.cabal @@ -116,6 +116,7 @@ Library Exposed-modules: Github.Auth, Github.Data, Github.Data.Definitions, + Github.Data.Teams, Github.Gists, Github.Gists.Comments, Github.GitData.Commits, @@ -123,17 +124,21 @@ Library Github.GitData.Trees, Github.GitData.Blobs, Github.Issues, + Github.Issues.Assignees, Github.Issues.Comments, Github.Issues.Events, Github.Issues.Labels, Github.Issues.Milestones, Github.Organizations, Github.Organizations.Members, + Github.Organizations.Teams, Github.PullRequests, Github.Repos, + Github.Repos.Branches, Github.Repos.Collaborators, Github.Repos.Commits, Github.Repos.Forks, + Github.Repos.Hooks, Github.Repos.Watching, Github.Repos.Starring, Github.Users, @@ -143,17 +148,17 @@ Library -- Packages needed in order to build this package. Build-depends: base >= 4.0 && < 5.0, time, - aeson >= 0.6.1.0, + aeson >= 0.6.1.0 && < 0.10, attoparsec >= 0.10.3.0, bytestring, case-insensitive >= 0.4.0.4, containers, hashable, text, - old-locale, + time-locale-compat == 0.1.*, HTTP, network, - http-conduit >= 1.8, + http-conduit >= 1.9 && < 2.2, conduit, failure, http-types, diff --git a/github.lock-7.10.2 b/github.lock-7.10.2 new file mode 100644 index 00000000..1d4da111 --- /dev/null +++ b/github.lock-7.10.2 @@ -0,0 +1,68 @@ +# mafia-lock-file-version: 0 +aeson == 0.9.0.1 +asn1-encoding == 0.9.4 +asn1-parse == 0.9.4 +asn1-types == 0.3.2 +async == 2.1.0 +attoparsec == 0.13.0.2 +base64-bytestring == 1.0.0.1 +blaze-builder == 0.4.0.2 +byteable == 0.1.1 +case-insensitive == 1.2.0.7 +cereal == 0.5.3.0 +conduit == 1.2.6.6 +conduit-extra == 1.1.13.2 +connection == 0.2.5 +cookie == 0.4.2.1 +cryptonite == 0.17 +data-default == 0.7.1.1 +data-default-class == 0.1.2.0 +data-default-instances-containers == 0.0.1 +data-default-instances-dlist == 0.0.1 +data-default-instances-old-locale == 0.0.1 +dlist == 0.8 +exceptions == 0.8.3 +fail == 4.9.0.0 +failure == 0.2.0.3 +hashable == 1.2.4.0 +hourglass == 0.2.10 +HTTP == 4000.3.3 +http-client == 0.4.31 +http-client-tls == 0.2.4.1 +http-conduit == 2.1.11 +http-types == 0.8.6 +lifted-base == 0.2.3.8 +memory == 0.13 +mime-types == 0.1.0.7 +mmorph == 1.0.6 +monad-control == 1.0.1.0 +mtl == 2.2.1 +network == 2.6.2.1 +network-uri == 2.6.1.0 +old-locale == 1.0.0.7 +parsec == 3.1.11 +pem == 0.2.2 +primitive == 0.6.1.0 +random == 1.1 +resourcet == 1.1.7.4 +scientific == 0.3.4.9 +semigroups == 0.18.2 +semigroups -bytestring-builder +socks == 0.5.5 +stm == 2.4.4.1 +streaming-commons == 0.1.15.5 +syb == 0.6 +tagged == 0.8.5 +text == 1.2.2.1 +time-locale-compat == 0.1.1.3 +time-locale-compat -old-locale +tls == 1.3.8 +transformers-base == 0.4.4 +transformers-compat == 0.5.1.4 +unordered-containers == 0.2.7.1 +vector == 0.11.0.0 +x509 == 1.6.3 +x509-store == 1.6.1 +x509-system == 1.6.3 +x509-validation == 1.6.3 +zlib == 0.6.1.1 diff --git a/mafia b/mafia new file mode 100755 index 00000000..de5e87fb --- /dev/null +++ b/mafia @@ -0,0 +1,121 @@ +#!/bin/sh -eu + +fetch_latest () { + if [ -z ${MAFIA_TEST_MODE+x} ]; then + TZ=$(date +"%T") + curl --silent "https://raw.githubusercontent.com/ambiata/mafia/master/script/mafia?$TZ" + else + cat ../script/mafia + fi +} + +latest_version () { + git ls-remote https://github.com/ambiata/mafia | grep refs/heads/master | cut -f 1 +} + +local_version () { + awk '/^# Version: / { print $3; exit 0; }' $0 +} + +run_upgrade () { + MAFIA_TEMP=$(mktemp 2>/dev/null || mktemp -t 'upgrade_mafia') + + clean_up () { + rm -f "$MAFIA_TEMP" + } + + trap clean_up EXIT + + MAFIA_CUR="$0" + + if [ -L "$MAFIA_CUR" ]; then + echo 'Refusing to overwrite a symlink; run `upgrade` from the canonical path.' >&2 + exit 1 + fi + + echo "Checking for a new version of mafia ..." + fetch_latest > $MAFIA_TEMP + + LATEST_VERSION=$(latest_version) + echo "# Version: $LATEST_VERSION" >> $MAFIA_TEMP + + if ! cmp $MAFIA_CUR $MAFIA_TEMP >/dev/null 2>&1; then + mv $MAFIA_TEMP $MAFIA_CUR + chmod +x $MAFIA_CUR + echo "New version found and upgraded. You can now commit it to your git repo." + else + echo "You have latest mafia." + fi +} + +exec_mafia () { + MAFIA_VERSION=$(local_version) + + if [ "x$MAFIA_VERSION" = "x" ]; then + # If we can't find the mafia version, then we need to upgrade the script. + run_upgrade + else + MAFIA_BIN=$HOME/.ambiata/mafia/bin + MAFIA_FILE=mafia-$MAFIA_VERSION + MAFIA_PATH=$MAFIA_BIN/$MAFIA_FILE + + [ -f "$MAFIA_PATH" ] || { + # Create a temporary directory which will be deleted when the script + # terminates. Unfortunately `mktemp` doesn't behave the same on + # Linux and OS/X so we need to try two different approaches. + MAFIA_TEMP=$(mktemp -d 2>/dev/null || mktemp -d -t 'exec_mafia') + + # Create a temporary file in MAFIA_BIN so we can do an atomic copy/move dance. + mkdir -p $MAFIA_BIN + + clean_up () { + rm -rf "$MAFIA_TEMP" + } + + trap clean_up EXIT + + echo "Building $MAFIA_FILE in $MAFIA_TEMP" + + ( cd "$MAFIA_TEMP" + + git clone https://github.com/ambiata/mafia + cd mafia + + git reset --hard $MAFIA_VERSION + + bin/bootstrap ) || exit $? + + MAFIA_PATH_TEMP=$(mktemp --tmpdir=$MAFIA_BIN $MAFIA_FILE-XXXXXX 2>/dev/null || TMPDIR=$MAFIA_BIN mktemp -t $MAFIA_FILE) + + clean_up_temp () { + clean_up + rm -f "$MAFIA_PATH_TEMP" + } + trap clean_up_temp EXIT + + cp "$MAFIA_TEMP/mafia/.cabal-sandbox/bin/mafia" "$MAFIA_PATH_TEMP" + chmod 755 "$MAFIA_PATH_TEMP" + mv "$MAFIA_PATH_TEMP" "$MAFIA_PATH" + + clean_up_temp + } + + exec $MAFIA_PATH "$@" + fi +} + +# +# The actual start of the script..... +# + +if [ $# -gt 0 ]; then + MODE="$1" +else + MODE="" +fi + +case "$MODE" in +upgrade) shift; run_upgrade "$@" ;; +*) exec_mafia "$@" +esac +# Version: de245376fd86c1ec9a5a451f096cb79bc8ae68f7