Merge pull request #10 from freiric/github-provider

Github provider

Yesod/Auth/OAuth2/Github.hs

@@ -0,0 +1,120 @@
+{-# LANGUAGE OverloadedStrings #-}
+-- |
+--
+-- OAuth2 plugin for http://github.com
+--
+-- * Authenticates against github
+-- * Uses github user id as credentials identifier
+-- * Returns first_name, last_name, and email as extras
+--
+module Yesod.Auth.OAuth2.Github
+    ( oauth2Github
+    , module Yesod.Auth.OAuth2
+    ) where
+
+import Control.Applicative ((<$>), (<*>))
+import Control.Exception.Lifted
+import Control.Monad (mzero)
+import Data.Aeson
+import Data.Text (Text)
+import Data.Monoid (mappend)
+import Data.Text.Encoding (encodeUtf8, decodeUtf8)
+import Yesod.Auth
+import Yesod.Auth.OAuth2
+import Yesod.Core
+import Yesod.Form
+import Network.HTTP.Conduit(Manager)
+import Data.UUID (toString)
+import Data.UUID.V4 (nextRandom)
+import qualified Data.ByteString as BS
+import qualified Data.Text as T
+
+data GithubUser = GithubUser
+    { githubUserId    :: Int
+    , githubUserName  :: Text
+    , githubUserLogin :: Text
+    , githubUserAvatarUrl :: Text
+    }
+
+instance FromJSON GithubUser where
+    parseJSON (Object o) =
+        GithubUser <$> o .: "id"
+                   <*> o .: "name"
+                   <*> o .: "login"
+                   <*> o .: "avatar_url"
+
+    parseJSON _ = mzero
+
+data GithubUserEmail = GithubUserEmail
+    { githubUserEmail :: Text
+    }
+
+instance FromJSON GithubUserEmail where
+    parseJSON (Object o) =
+        GithubUserEmail <$> o .: "email"
+
+    parseJSON _ = mzero
+
+oauth2Github :: YesodAuth m
+             => Text -- ^ Client ID
+             -> Text -- ^ Client Secret
+             -> AuthPlugin m
+oauth2Github clientId clientSecret = oauth2GithubScoped clientId clientSecret ["user:email"]
+
+oauth2GithubScoped :: YesodAuth m
+             => Text -- ^ Client ID
+             -> Text -- ^ Client Secret
+             -> [Text] -- ^ List of scopes to request
+             -> AuthPlugin m
+oauth2GithubScoped clientId clientSecret scopes = basicPlugin {apDispatch = dispatch}
+    where
+        oauth = OAuth2
+                { oauthClientId            = encodeUtf8 clientId
+                , oauthClientSecret        = encodeUtf8 clientSecret
+                , oauthOAuthorizeEndpoint  = encodeUtf8 $ "https://github.com/login/oauth/authorize?scope=" `T.append` T.intercalate "," scopes
+                , oauthAccessTokenEndpoint = "https://github.com/login/oauth/access_token"
+                , oauthCallback            = Nothing
+                }
+
+        withState state = authOAuth2 "github"
+            (oauth {oauthOAuthorizeEndpoint = oauthOAuthorizeEndpoint oauth `BS.append` "&state=" `BS.append` encodeUtf8 state})
+            fetchGithubProfile
+
+        basicPlugin = authOAuth2 "github" oauth fetchGithubProfile
+
+        dispatch "GET" ["forward"] = do
+            state <- liftIO $ fmap (T.pack . toString) nextRandom
+            setSession "githubState" state
+            apDispatch (withState state) "GET" ["forward"]
+
+        dispatch "GET" ["callback"] = do
+            state <- lift $ runInputGet $ ireq textField "state"
+            savedState <- lookupSession "githubState"
+            apDispatch basicPlugin "GET" ["callback"]
+            case savedState of
+                Just saved | saved == state -> apDispatch basicPlugin "GET" ["callback"]
+                Just saved -> invalidArgs ["state: " `mappend` state `mappend` ", and not: " `mappend` saved]
+                _ -> invalidArgs ["state: " `mappend` state]
+
+        dispatch method ps = apDispatch basicPlugin method ps
+
+fetchGithubProfile :: Manager -> AccessToken -> IO (Creds m)
+fetchGithubProfile manager token = do
+    userResult <- authGetJSON manager token "https://api.github.com/user"
+    mailResult <- authGetJSON manager token "https://api.github.com/user/emails"
+
+    case (userResult, mailResult) of
+        (Right user, Right []) -> throwIO $ InvalidProfileResponse "github" "no mail address for user"
+        (Right user, Right mails) -> return $ toCreds user mails token
+        (Left err, _) -> throwIO $ InvalidProfileResponse "github" err
+        (_, Left err) -> throwIO $ InvalidProfileResponse "github" err
+
+toCreds :: GithubUser -> [GithubUserEmail] -> AccessToken -> Creds m
+toCreds user userMail token = Creds "github"
+    (T.pack $ show $ githubUserId user)
+    [ ("name", githubUserName user)
+    , ("email", githubUserEmail $ head userMail)
+    , ("login", githubUserLogin user)
+    , ("avatar_url", githubUserAvatarUrl user)
+    , ("access_token", decodeUtf8 $ accessToken token)
+    ]

yesod-auth-oauth2.cabal

@@ -1,5 +1,5 @@
 name:            yesod-auth-oauth2
-version:         0.0.5.1
+version:         0.0.5.2
 license:         BSD3
 license-file:    LICENSE
 author:          Tom Streller
@@ -14,7 +14,16 @@ homepage:        http://github.com/scan/yesod-auth-oauth2
 
 flag ghc7
 
+flag network-uri
+   description: Get Network.URI from the network-uri package
+   default: True
+
 library
+    if flag(network-uri)
+        build-depends: network-uri >= 2.6
+    else
+        build-depends: network < 2.6
+
     if flag(ghc7)
         build-depends:   base                >= 4.3      && < 5
         cpp-options:     -DGHC7
@@ -26,16 +35,19 @@ library
                    , http-types              >= 0.8       && < 0.9
                    , aeson                   >= 0.6       && < 0.8
                    , yesod-core              >= 1.2       && < 1.4
+                   , authenticate            >= 1.3.2.7   && < 1.4
                    , yesod-auth              >= 1.3       && < 1.4
                    , text                    >= 0.7       && < 2.0
                    , yesod-form              >= 1.3       && < 1.4
                    , transformers            >= 0.2.2     && < 0.4
                    , hoauth2                 >= 0.4.1     && < 0.5
                    , lifted-base             >= 0.2       && < 0.4
+                   , uuid                    >= 1.3       && < 1.4
 
     exposed-modules: Yesod.Auth.OAuth2
                      Yesod.Auth.OAuth2.Google
                      Yesod.Auth.OAuth2.Learn
+                     Yesod.Auth.OAuth2.Github
 
     ghc-options:     -Wall