diff --git a/Github/Gists.hs b/Github/Gists.hs --- a/Github/Gists.hs +++ b/Github/Gists.hs @@ -13,7 +13,7 @@ -- | The list of all gists created by the user -- -- > gists' (Just ("github-username", "github-password")) "mike-burns" -gists' :: Maybe BasicAuth -> String -> IO (Either Error [Gist]) +gists' :: Maybe GithubAuth -> String -> IO (Either Error [Gist]) gists' auth userName = githubGet' auth ["users", userName, "gists"] -- | The list of all public gists created by the user. @@ -25,7 +25,7 @@ -- | A specific gist, given its id, with authentication credentials -- -- > gist' (Just ("github-username", "github-password")) "225074" -gist' :: Maybe BasicAuth -> String -> IO (Either Error Gist) +gist' :: Maybe GithubAuth -> String -> IO (Either Error Gist) gist' auth gistId = githubGet' auth ["gists", gistId] -- | A specific gist, given its id. diff --git a/Github/Issues.hs b/Github/Issues.hs --- a/Github/Issues.hs +++ b/Github/Issues.hs @@ -37,7 +37,7 @@ -- number.' -- -- > issue' (Just ("github-username", "github-password")) "thoughtbot" "paperclip" "462" -issue' :: Maybe BasicAuth -> String -> String -> Int -> IO (Either Error Issue) +issue' :: Maybe GithubAuth -> String -> String -> Int -> IO (Either Error Issue) issue' auth user repoName issueNumber = githubGet' auth ["repos", user, repoName, "issues", show issueNumber] @@ -52,7 +52,7 @@ -- restrictions as described in the @IssueLimitation@ data type. -- -- > issuesForRepo' (Just ("github-username", "github-password")) "thoughtbot" "paperclip" [NoMilestone, OnlyClosed, Mentions "jyurek", Ascending] -issuesForRepo' :: Maybe BasicAuth -> String -> String -> [IssueLimitation] -> IO (Either Error [Issue]) +issuesForRepo' :: Maybe GithubAuth -> String -> String -> [IssueLimitation] -> IO (Either Error [Issue]) issuesForRepo' auth user repoName issueLimitations = githubGetWithQueryString' auth diff --git a/Github/Organizations.hs b/Github/Organizations.hs --- a/Github/Organizations.hs +++ b/Github/Organizations.hs @@ -13,7 +13,7 @@ -- | The public organizations for a user, given the user's login, with authorization -- -- > publicOrganizationsFor' (Just ("github-username", "github-password")) "mike-burns" -publicOrganizationsFor' :: Maybe BasicAuth -> String -> IO (Either Error [SimpleOrganization]) +publicOrganizationsFor' :: Maybe GithubAuth -> String -> IO (Either Error [SimpleOrganization]) publicOrganizationsFor' auth userName = githubGet' auth ["users", userName, "orgs"] -- | The public organizations for a user, given the user's login. @@ -25,7 +25,7 @@ -- | Details on a public organization. Takes the organization's login. -- -- > publicOrganization' (Just ("github-username", "github-password")) "thoughtbot" -publicOrganization' :: Maybe BasicAuth -> String -> IO (Either Error Organization) +publicOrganization' :: Maybe GithubAuth -> String -> IO (Either Error Organization) publicOrganization' auth organizationName = githubGet' auth ["orgs", organizationName] -- | Details on a public organization. Takes the organization's login. diff --git a/Github/Private.hs b/Github/Private.hs --- a/Github/Private.hs +++ b/Github/Private.hs @@ -1,11 +1,13 @@ -{-# LANGUAGE OverloadedStrings, StandaloneDeriving #-} +{-# LANGUAGE OverloadedStrings, StandaloneDeriving, DeriveDataTypeable #-} module Github.Private where import Github.Data import Data.Aeson import Data.Attoparsec.ByteString.Lazy +import Data.Data import Control.Applicative import Data.List +import Data.CaseInsensitive (mk) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS import Network.HTTP.Types (Method, Status(..)) @@ -14,10 +16,15 @@ import qualified Control.Exception as E import Data.Maybe (fromMaybe) +-- | user/password for HTTP basic access authentication +data GithubAuth = GithubBasicAuth BS.ByteString BS.ByteString + | GithubOAuth String + deriving (Show, Data, Typeable, Eq, Ord) + githubGet :: (FromJSON b, Show b) => [String] -> IO (Either Error b) githubGet = githubGet' Nothing -githubGet' :: (FromJSON b, Show b) => Maybe BasicAuth -> [String] -> IO (Either Error b) +githubGet' :: (FromJSON b, Show b) => Maybe GithubAuth -> [String] -> IO (Either Error b) githubGet' auth paths = githubAPI (BS.pack "GET") (buildUrl paths) @@ -27,21 +34,21 @@ githubGetWithQueryString :: (FromJSON b, Show b) => [String] -> String -> IO (Either Error b) githubGetWithQueryString = githubGetWithQueryString' Nothing -githubGetWithQueryString' :: (FromJSON b, Show b) => Maybe BasicAuth -> [String] -> String -> IO (Either Error b) +githubGetWithQueryString' :: (FromJSON b, Show b) => Maybe GithubAuth -> [String] -> String -> IO (Either Error b) githubGetWithQueryString' auth paths queryString = githubAPI (BS.pack "GET") (buildUrl paths ++ "?" ++ queryString) auth (Nothing :: Maybe Value) -githubPost :: (ToJSON a, Show a, FromJSON b, Show b) => BasicAuth -> [String] -> a -> IO (Either Error b) +githubPost :: (ToJSON a, Show a, FromJSON b, Show b) => GithubAuth -> [String] -> a -> IO (Either Error b) githubPost auth paths body = githubAPI (BS.pack "POST") (buildUrl paths) (Just auth) (Just body) -githubPatch :: (ToJSON a, Show a, FromJSON b, Show b) => BasicAuth -> [String] -> a -> IO (Either Error b) +githubPatch :: (ToJSON a, Show a, FromJSON b, Show b) => GithubAuth -> [String] -> a -> IO (Either Error b) githubPatch auth paths body = githubAPI (BS.pack "PATCH") (buildUrl paths) @@ -51,7 +58,7 @@ buildUrl :: [String] -> String buildUrl paths = "https://api.github.com/" ++ intercalate "/" paths -githubAPI :: (ToJSON a, Show a, FromJSON b, Show b) => BS.ByteString -> String -> Maybe BasicAuth -> Maybe a -> IO (Either Error b) +githubAPI :: (ToJSON a, Show a, FromJSON b, Show b) => BS.ByteString -> String -> Maybe GithubAuth -> Maybe a -> IO (Either Error b) githubAPI method url auth body = do result <- doHttps method url auth (Just encodedBody) return $ either (Left . HTTPConnectionError) @@ -59,20 +66,19 @@ result where encodedBody = RequestBodyLBS $ encode $ toJSON body --- | user/password for HTTP basic access authentication -type BasicAuth = (BS.ByteString, BS.ByteString) - -doHttps :: Method -> String -> Maybe BasicAuth -> Maybe (RequestBody (ResourceT IO)) -> IO (Either E.SomeException (Response LBS.ByteString)) +doHttps :: Method -> String -> Maybe GithubAuth -> Maybe (RequestBody (ResourceT IO)) -> IO (Either E.SomeException (Response LBS.ByteString)) doHttps method url auth body = do let requestBody = fromMaybe (RequestBodyBS $ BS.pack "") body + requestHeaders = maybe [] getOAuth auth (Just uri) = parseUrl url request = uri { method = method , secure = True , port = 443 , requestBody = requestBody + , requestHeaders = requestHeaders , checkStatus = successOrMissing } - authRequest = maybe id (uncurry applyBasicAuth) auth request + authRequest = getAuthRequest auth request (getResponse authRequest >>= return . Right) `E.catches` [ -- Re-throw AsyncException, otherwise execution will not terminate on @@ -80,10 +86,16 @@ -- UserInterrupt) because all of them indicate severe conditions and -- should not occur during normal operation. E.Handler (\e -> E.throw (e :: E.AsyncException)), - E.Handler (\e -> (return . Left) (e :: E.SomeException)) ] where + getAuthRequest (Just (GithubBasicAuth user pass)) = applyBasicAuth user pass + getAuthRequest _ = id + getBasicAuth (GithubBasicAuth user pass) = applyBasicAuth user pass + getBasicAuth _ = id + getOAuth (GithubOAuth token) = [(mk (BS.pack "Authorization"), + BS.pack ("token " ++ token))] + getOAuth _ = [] getResponse request = withManager $ \manager -> httpLbs request manager successOrMissing s@(Status sci _) hs | (200 <= sci && sci < 300) || sci == 404 = Nothing diff --git a/Github/PullRequests.hs b/Github/PullRequests.hs --- a/Github/PullRequests.hs +++ b/Github/PullRequests.hs @@ -19,7 +19,7 @@ -- | With authentification -- -- > pullRequestsFor' (Just ("github-username", "github-password")) "rails" "rails" -pullRequestsFor' :: Maybe BasicAuth -> String -> String -> IO (Either Error [PullRequest]) +pullRequestsFor' :: Maybe GithubAuth -> String -> String -> IO (Either Error [PullRequest]) pullRequestsFor' auth userName repoName = githubGet' auth ["repos", userName, repoName, "pulls"] @@ -34,7 +34,7 @@ -- | With authentification -- -- > pullRequest' (Just ("github-username", "github-password")) "thoughtbot" "paperclip" 562 -pullRequest' :: Maybe BasicAuth -> String -> String -> Int -> IO (Either Error DetailedPullRequest) +pullRequest' :: Maybe GithubAuth -> String -> String -> Int -> IO (Either Error DetailedPullRequest) pullRequest' auth userName repoName number = githubGet' auth ["repos", userName, repoName, "pulls", show number] @@ -50,7 +50,7 @@ -- | With authentification -- -- > pullRequestCommits' (Just ("github-username", "github-password")) "thoughtbot" "paperclip" 688 -pullRequestCommits' :: Maybe BasicAuth -> String -> String -> Int -> IO (Either Error [Commit]) +pullRequestCommits' :: Maybe GithubAuth -> String -> String -> Int -> IO (Either Error [Commit]) pullRequestCommits' auth userName repoName number = githubGet' auth ["repos", userName, repoName, "pulls", show number, "commits"] @@ -66,7 +66,7 @@ -- | With authentification -- -- > pullRequestFiles' (Just ("github-username", "github-password")) "thoughtbot" "paperclip" 688 -pullRequestFiles' :: Maybe BasicAuth -> String -> String -> Int -> IO (Either Error [File]) +pullRequestFiles' :: Maybe GithubAuth -> String -> String -> Int -> IO (Either Error [File]) pullRequestFiles' auth userName repoName number = githubGet' auth ["repos", userName, repoName, "pulls", show number, "files"] -- | The individual files that a pull request patches. Takes the repo owner and diff --git a/Github/Repos.hs b/Github/Repos.hs --- a/Github/Repos.hs +++ b/Github/Repos.hs @@ -5,8 +5,9 @@ -- * Querying repositories userRepos -,organizationRepos ,userRepo +,organizationRepos +,organizationRepo ,contributors ,contributorsWithAnonymous ,languagesFor @@ -17,9 +18,8 @@ -- * Modifying repositories -- | --- Only authenticated users may modify repositories. Currently only --- /HTTP basic access authentication/ is implemented. -,BasicAuth +-- Only authenticated users may modify repositories. +,GithubAuth(..) -- ** Create ,createRepo @@ -43,6 +43,7 @@ import Network.HTTP.Conduit import qualified Data.ByteString.Char8 as BS import Control.Applicative +import qualified Control.Exception as E import Network.HTTP.Types -- | Filter the list of the user's repos using any of these constructors. @@ -77,6 +78,12 @@ organizationRepos :: String -> IO (Either Error [Repo]) organizationRepos orgName = githubGet ["orgs", orgName, "repos"] +-- | A specific organization repo, by the organization name. +-- +-- > organizationRepo "thoughtbot" "github" +organizationRepo :: String -> String -> IO (Either Error Repo) +organizationRepo orgName repoName = githubGet ["orgs", orgName, repoName] + -- | Details on a specific repo, given the owner and repo name. -- -- > userRepo "mike-burns" "github" @@ -133,6 +140,7 @@ , newRepoHasIssues :: (Maybe Bool) , newRepoHasWiki :: (Maybe Bool) , newRepoHasDownloads :: (Maybe Bool) +, newRepoAutoInit :: (Maybe Bool) } deriving Show instance ToJSON NewRepo where @@ -143,6 +151,7 @@ , newRepoHasIssues = hasIssues , newRepoHasWiki = hasWiki , newRepoHasDownloads = hasDownloads + , newRepoAutoInit = autoInit }) = object [ "name" .= name , "description" .= description @@ -150,24 +159,24 @@ , "private" .= private , "has_issues" .= hasIssues , "has_wiki" .= hasWiki - , "has_downloads" .= hasDownloads + , "auto_init" .= autoInit ] newRepo :: String -> NewRepo -newRepo name = NewRepo name Nothing Nothing Nothing Nothing Nothing Nothing +newRepo name = NewRepo name Nothing Nothing Nothing Nothing Nothing Nothing Nothing -- | -- Create a new repository. -- --- > createRepo (user, password) (newRepo "some_repo") {newRepoHasIssues = Just False} -createRepo :: BasicAuth -> NewRepo -> IO (Either Error Repo) +-- > createRepo (GithubUser (user, password)) (newRepo "some_repo") {newRepoHasIssues = Just False} +createRepo :: GithubAuth -> NewRepo -> IO (Either Error Repo) createRepo auth = githubPost auth ["user", "repos"] -- | -- Create a new repository for an organization. -- --- > createOrganizationRepo (user, password) "thoughtbot" (newRepo "some_repo") {newRepoHasIssues = Just False} -createOrganizationRepo :: BasicAuth -> String -> NewRepo -> IO (Either Error Repo) +-- > createOrganizationRepo (GithubUser (user, password)) "thoughtbot" (newRepo "some_repo") {newRepoHasIssues = Just False} +createOrganizationRepo :: GithubAuth -> String -> NewRepo -> IO (Either Error Repo) createOrganizationRepo auth org = githubPost auth ["orgs", org, "repos"] data Edit = Edit { @@ -204,8 +213,8 @@ -- | -- Edit an existing repository. -- --- > editRepo (user, password) "some_user" "some_repo" def {editDescription = Just "some description"} -editRepo :: BasicAuth +-- > editRepo (GithubUser (user, password)) "some_user" "some_repo" def {editDescription = Just "some description"} +editRepo :: GithubAuth -> String -- ^ owner -> String -- ^ repository name -> Edit @@ -218,30 +227,25 @@ -- | -- Delete an existing repository. -- --- > deleteRepo (user, password) "thoughtbot" "some_repo" -deleteRepo :: BasicAuth +-- > deleteRepo (GithubUser (user, password)) "thoughtbot" "some_repo" +deleteRepo :: GithubAuth -> String -- ^ owner -> String -- ^ repository name -> IO (Either Error ()) deleteRepo auth owner repo = do - requestToken >>= either (return . Left) (sendToken) + result <- doHttps "DELETE" url (Just auth) Nothing + case result of + Left e -> return (Left (HTTPConnectionError e)) + Right resp -> + let status = responseStatus resp + headers = responseHeaders resp + in if status == notFound404 + -- doHttps silently absorbs 404 errors, but for this operation + -- we want the user to know if they've tried to delete a + -- non-existent repository + then return (Left (HTTPConnectionError + (E.toException + (StatusCodeException status headers)))) + else return (Right ()) where - -- APIv3 does not support deletion, so we use APIv2 for that - url = "https://github.com/api/v2/json/repos/delete/" ++ owner ++ "/" ++ repo - - requestToken :: IO (Either Error DeleteToken) - requestToken = githubAPI "POST" url (Just auth) (Nothing :: Maybe Value) - - sendToken (DeleteToken t) = do - let body = RequestBodyBS $ renderSimpleQuery False [("delete_token", t)] - result <- doHttps "POST" url (Just auth) (Just body) - return $ either (Left . HTTPConnectionError) - (const $ Right ()) - result - -newtype DeleteToken = DeleteToken BS.ByteString - deriving Show - -instance FromJSON DeleteToken where - parseJSON (Object o) = DeleteToken <$> o .: "delete_token" - parseJSON _ = fail "Could not build a DeleteToken" + url = "https://api.github.com/repos/" ++ owner ++ "/" ++ repo diff --git a/Github/Users.hs b/Github/Users.hs --- a/Github/Users.hs +++ b/Github/Users.hs @@ -13,7 +13,7 @@ -- | With authentification -- -- > userInfoFor' (Just ("github-username", "github-password")) "mike-burns" -userInfoFor' :: Maybe BasicAuth -> String -> IO (Either Error DetailedOwner) +userInfoFor' :: Maybe GithubAuth -> String -> IO (Either Error DetailedOwner) userInfoFor' auth userName = githubGet' auth ["users", userName] -- | The information for a single user, by login name. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -27,7 +27,7 @@ Documentation ============= -For details see the reference documentation on Hackage. Later. +For details see the reference documentation on Hackage. Each module lines up with the hierarchy of [documentation from the Github API](http://developer.github.com/v3/). diff --git a/github.cabal b/github.cabal --- a/github.cabal +++ b/github.cabal @@ -7,7 +7,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented. -Version: 0.4.1 +Version: 0.5.0 -- A short (one-line) description of the package. Synopsis: Access to the Github API, v3. @@ -36,7 +36,7 @@ Homepage: https://github.com/mike-burns/github -- A copyright notice. -Copyright: Copyright 2012 Mike Burns +Copyright: Copyright 2012-2013 Mike Burns Category: Network APIs @@ -141,8 +141,9 @@ Build-depends: base >= 4.0 && < 5.0, time, aeson == 0.6.1.0, - attoparsec == 0.10.3.0, + attoparsec >= 0.10.3.0, bytestring, + case-insensitive >= 0.4.0.4, containers, text, old-locale,