Add support for OAuth token-based authentication

Author: John Wiegley

Github/Gists.hs

@@ -13,7 +13,7 @@ import Github.Private
 -- | 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 @@ gists = gists' Nothing
 -- | 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.

Github/Issues.hs

@@ -37,7 +37,7 @@ data IssueLimitation =
 -- 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 @@ issue = issue' Nothing
 -- 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

Github/Organizations.hs

@@ -13,7 +13,7 @@ import Github.Private
 -- | 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 @@ publicOrganizationsFor = publicOrganizationsFor' Nothing
 -- | 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.

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 Data.Conduit (ResourceT)
 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 @@ githubGet' auth paths =
 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,39 +58,44 @@ githubPatch auth paths body =
 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)
  (parseJson . responseBody)
  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
  -- SIGINT (ctrl-c). All AsyncExceptions are re-thrown (not just
  -- 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

Github/PullRequests.hs

@@ -19,7 +19,7 @@ import Github.Private
 -- | 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 @@ pullRequestsFor = pullRequestsFor' Nothing
 -- | 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 @@ pullRequest = pullRequest' Nothing
 -- | 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 @@ pullRequestCommits = pullRequestCommits' Nothing
 -- | 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

Github/Repos.hs

@@ -19,7 +19,7 @@ module Github.Repos (
 -- |
 -- Only authenticated users may modify repositories. Currently only
 -- /HTTP basic access authentication/ is implemented.
-,BasicAuth
+,GithubAuth(..)
 
 -- ** Create
 ,createRepo
@@ -160,14 +160,14 @@ newRepo name = NewRepo name 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 :: 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 :: GithubAuth -> String -> NewRepo -> IO (Either Error Repo)
 createOrganizationRepo auth org = githubPost auth ["orgs", org, "repos"]
 
 data Edit = Edit {
@@ -205,7 +205,7 @@ instance ToJSON Edit where
 -- Edit an existing repository.
 --
 -- > editRepo (user, password) "some_user" "some_repo" def {editDescription = Just "some description"}
-editRepo :: BasicAuth
+editRepo :: GithubAuth
  -> String -- ^ owner
  -> String -- ^ repository name
  -> Edit
@@ -219,7 +219,7 @@ editRepo auth user repo body = githubPatch auth ["repos", user, repo] b
 -- Delete an existing repository.
 --
 -- > deleteRepo (user, password) "thoughtbot" "some_repo"
-deleteRepo :: BasicAuth
+deleteRepo :: GithubAuth
  -> String -- ^ owner
  -> String -- ^ repository name
  -> IO (Either Error ())

Github/Users.hs

@@ -13,7 +13,7 @@ import Github.Private
 -- | 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.

github.cabal

@@ -143,6 +143,7 @@ Library
  aeson == 0.6.1.0,
  attoparsec >= 0.10.3.0,
  bytestring,
+ case-insensitive >= 0.4.0.4,
  containers,
  text,
  old-locale,