Merge 9462ca974a into a306f80da8

Yesod/Auth/OAuth2.hs

@@ -22,6 +22,8 @@ import Data.Text.Encoding (decodeUtf8With, encodeUtf8)
 import Data.Text.Encoding.Error (lenientDecode)
 import Data.Typeable
 import Network.OAuth.OAuth2
+import Network.HTTP.Client (newManager)
+import Network.HTTP.Client.TLS (tlsManagerSettings)
 import Yesod.Auth
 import Yesod.Core
 import Yesod.Form
@@ -62,14 +64,15 @@ authOAuth2 name oauth getCreds = AuthPlugin name dispatch login
             lift $ redirect authUrl
 
         dispatch "GET" ["callback"] = do
+            manager <- liftIO $ newManager tlsManagerSettings
             code <- lift $ runInputGet $ ireq textField "code"
             oauth' <- withCallback
-            result <- liftIO $ fetchAccessToken oauth' (encodeUtf8 code)
+            result <- liftIO $ fetchAccessToken manager oauth' (encodeUtf8 code)
             case result of
                 Left _ -> permissionDenied "Unable to retreive OAuth2 token"
                 Right token -> do
                     creds <- liftIO $ getCreds token
-                    lift $ setCreds True creds
+                    lift $ setCredsRedirect creds
 
         dispatch _ _ = notFound
 

Yesod/Auth/OAuth2/Github.hs

@@ -0,0 +1,102 @@
+{-# 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.Text.Encoding (encodeUtf8, decodeUtf8)
+import Yesod.Auth
+import Yesod.Auth.OAuth2
+import Yesod.Core
+import Yesod.Form
+import Network.HTTP.Client (newManager)
+import Network.HTTP.Client.TLS (tlsManagerSettings)
+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
+    , githubUserEmail :: Text
+    , githubUserLogin :: Text
+    , githubUserAvatarUrl :: Text
+    }
+
+instance FromJSON GithubUser where
+    parseJSON (Object o) =
+        GithubUser <$> o .: "id"
+                   <*> o .: "name"
+                   <*> o .: "email"
+                   <*> o .: "login"
+                   <*> o .: "avatar_url"
+
+    parseJSON _ = mzero
+
+oauth2Github :: YesodAuth m
+             => Text -- ^ Client ID
+             -> Text -- ^ Client Secret
+             -> [Text] -- ^ List of scopes to request
+             -> AuthPlugin m
+oauth2Github clientId clientSecret scopes = basicPlugin {apDispatch = dispatch}
+    where
+        oauth = OAuth2
+                { oauthClientId            = encodeUtf8 clientId
+                , oauthClientSecret        = encodeUtf8 clientSecret
+                , oauthOAuthorizeEndpoint  = encodeUtf8 $ "https://github.com/login/oauth/authorize?scopes=" `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"
+            case savedState of
+                Just saved | saved == state -> (apDispatch basicPlugin) "GET" ["callback"]
+                _ -> invalidArgs ["state"]
+
+        dispatch method ps = (apDispatch basicPlugin) method ps
+
+fetchGithubProfile :: AccessToken -> IO (Creds m)
+fetchGithubProfile token = do
+    manager <- newManager tlsManagerSettings
+    result <- authGetJSON manager token "https://api.github.com/user"
+
+    case result of
+        Right user -> return $ toCreds user token
+        Left err -> throwIO $ InvalidProfileResponse "github" err
+
+toCreds :: GithubUser -> AccessToken -> Creds m
+toCreds user token = Creds "github"
+    (T.pack $ show $ githubUserId user)
+    [ ("name", githubUserName user)
+    , ("email", githubUserEmail user)
+    , ("login", githubUserLogin user)
+    , ("avatar_url", githubUserAvatarUrl user)
+    , ("access_token", decodeUtf8 $ accessToken token)
+    ]

Yesod/Auth/OAuth2/Learn.hs

@@ -20,6 +20,8 @@ import Data.Text (Text)
 import Data.Text.Encoding (encodeUtf8)
 import Yesod.Auth
 import Yesod.Auth.OAuth2
+import Network.HTTP.Client (newManager)
+import Network.HTTP.Client.TLS (tlsManagerSettings)
 import qualified Data.Text as T
 
 data LearnUser = LearnUser
@@ -62,7 +64,8 @@ oauth2Learn clientId clientSecret = authOAuth2 "learn"
 
 fetchLearnProfile :: AccessToken -> IO (Creds m)
 fetchLearnProfile token = do
-    result <- authGetJSON token "http://learn.thoughtbot.com/api/v1/me.json"
+    manager <- newManager tlsManagerSettings
+    result <- authGetJSON manager token "http://learn.thoughtbot.com/api/v1/me.json"
 
     case result of
         Right (LearnResponse user) -> return $ toCreds user

yesod-auth-oauth2.cabal

@@ -24,18 +24,21 @@ library
     build-depends:   bytestring              >= 0.9.1.4
                    , http-conduit            >= 2.0       && < 3.0
                    , http-types              >= 0.8       && < 0.9
-                   , aeson                   >= 0.6       && < 0.8
+                   , aeson                   >= 0.6       && < 0.9
                    , yesod-core              >= 1.2       && < 1.3
-                   , yesod-auth              >= 1.2       && < 1.3
+                   , 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.3.6     && < 0.4
+                   , transformers            >= 0.3       && < 0.5
+                   , hoauth2                 >= 0.4       && < 0.5
                    , lifted-base             >= 0.2       && < 0.4
-
+                   , http-client             >= 0.3       && < 0.4
+                   , http-client-tls         >= 0.2       && < 0.3
+                   , 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