From 434e2bc0924b5f6945bd5d52628091194bc18605 Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Sat, 15 Feb 2014 14:44:01 -0500 Subject: [PATCH 1/5] Update dependencies, make it work, address -Wall Housekeeping: * Use newer http-conduit (Request m becomes Request) * Increase upper bound on aeson * Fix whitespace, remove unfinished function * Add type signatures and some comments * Remove unused imports Fixes: * ByteString needs an orphan JSON instance so AccessToken can have one. I'm not sure if there's a way around this. * redirect takes a Text, not a ByteString * dispatch for "callback" should handle setting the credentials Additions * oauth2Learn for authenticating against learn.thoughtbot.com --- Yesod/Auth/OAuth2.hs | 50 +++++++++++++++++++--------- Yesod/Auth/OAuth2/Internal.hs | 61 ++++++++++++++--------------------- yesod-auth-oauth2.cabal | 4 +-- 3 files changed, 60 insertions(+), 55 deletions(-) diff --git a/Yesod/Auth/OAuth2.hs b/Yesod/Auth/OAuth2.hs index 9ff4677..2a97631 100644 --- a/Yesod/Auth/OAuth2.hs +++ b/Yesod/Auth/OAuth2.hs @@ -1,13 +1,15 @@ {-# LANGUAGE DeriveDataTypeable, OverloadedStrings, QuasiQuotes #-} -module Yesod.Auth.OAuth2 where +module Yesod.Auth.OAuth2 + ( authOAuth2 + , oauth2Google + , oauth2Learn + ) where import Control.Monad.IO.Class import Data.ByteString (ByteString) import Data.Text (Text) import Data.Text.Encoding (decodeUtf8With, encodeUtf8) import Data.Text.Encoding.Error (lenientDecode) -import Data.Maybe -import Network.HTTP.Conduit as C import Yesod.Auth import Yesod.Form import Yesod.Core @@ -16,7 +18,18 @@ import Yesod.Auth.OAuth2.Internal oauth2Url :: Text -> AuthRoute oauth2Url name = PluginR name ["forward"] -authOAuth2 name oauth getCreds = AuthPlugin name dispatch login +authOAuth2 :: YesodAuth m + => Text -- ^ Service name + -> OAuth2 -- ^ Service details + + -- | This function defines how to take an @'AccessToken'@ and + -- retrive additional information about the user, to be set + -- in the session as @'Creds'@. Usually this means a second + -- authorized request to @api/me.json@. + -> (AccessToken -> IO (Creds m)) + -> AuthPlugin m +authOAuth2 name oauth mkCreds = AuthPlugin name dispatch login + where url = PluginR name ["callback"] dispatch "GET" ["forward"] = do @@ -24,32 +37,37 @@ authOAuth2 name oauth getCreds = AuthPlugin name dispatch login lift $ do render <- getUrlRender let oauth' = oauth { oauthCallback = Just $ encodeUtf8 $ render $ tm url } - redirect $ authorizationUrl oauth' + redirect $ bsToText $ authorizationUrl oauth' dispatch "GET" ["callback"] = do + tm <- getRouteToParent + render <- lift $ getUrlRender code <- lift $ runInputGet $ ireq textField "code" - mtoken <- liftIO $ postAccessToken oauth (encodeUtf8 code) (Just "authorization_code") + let oauth' = oauth { oauthCallback = Just $ encodeUtf8 $ render $ tm url } + mtoken <- liftIO $ postAccessToken oauth' (encodeUtf8 code) (Just "authorization_code") case mtoken of Nothing -> permissionDenied "Couldn't get token" - Just token -> getCreds token - disptach _ _ = notFound + Just token -> do + creds <- liftIO $ mkCreds token + lift $ setCreds True creds + dispatch _ _ = notFound login tm = do render <- getUrlRender let oaUrl = render $ tm $ oauth2Url name [whamlet| Login via #{name} |] +oauth2Google :: Text -> Text -> OAuth2 oauth2Google clientId clientSecret = newOAuth2 { oauthClientId = encodeUtf8 clientId , oauthClientSecret = encodeUtf8 clientSecret , oauthOAuthorizeEndpoint = "https://accounts.google.com/o/oauth2/auth" , oauthAccessTokenEndpoint = "https://accounts.google.com/o/oauth2/token" } -cloudsdaleAuth clientId clientSecret = authOAuth2 "cloudsdale" oauth2 $ \token -> do - rsp <- request $ authorizeRequest token $ fromJust $ parseUrl "http://api.cloudsdale.org/v2/me.json" - undefined - where - oauth2 = newOAuth2 { oauthClientId = encodeUtf8 clientId - , oauthClientSecret = encodeUtf8 clientSecret - , oauthOAuthorizeEndpoint = "http://www.cloudsdale.org/oauth/authorize" - , oauthAccessTokenEndpoint = "http://www.cloudsdale.org/oauth/token" } +oauth2Learn :: Text -> Text -> OAuth2 +oauth2Learn clientId clientSecret = newOAuth2 + { oauthClientId = encodeUtf8 clientId + , oauthClientSecret = encodeUtf8 clientSecret + , oauthOAuthorizeEndpoint = "http://learn.thoughtbot.com/oauth/authorize" + , oauthAccessTokenEndpoint = "http://learn.thoughtbot.com/oauth/token" + } bsToText :: ByteString -> Text bsToText = decodeUtf8With lenientDecode diff --git a/Yesod/Auth/OAuth2/Internal.hs b/Yesod/Auth/OAuth2/Internal.hs index d38cd36..a849ef8 100644 --- a/Yesod/Auth/OAuth2/Internal.hs +++ b/Yesod/Auth/OAuth2/Internal.hs @@ -1,13 +1,13 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-} module Yesod.Auth.OAuth2.Internal where {- see https://gist.github.com/qzchenwl/2351071 -} - + import Data.Aeson import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BSL -import Data.ByteString.Lazy (toChunks) import Data.List import Data.Maybe import Data.Typeable (Typeable) @@ -15,9 +15,14 @@ import Network.HTTP.Types (renderSimpleQuery, parseSimpleQuery) import qualified Network.HTTP.Types as HT import Network.HTTP.Conduit as C import Control.Exception -import Control.Applicative ((<$>)) +import Control.Applicative ((<$>), pure) import Control.Monad (mzero) - +import Data.Text.Encoding (encodeUtf8) + +instance FromJSON BS.ByteString where + parseJSON (String t) = pure $ encodeUtf8 t + parseJSON _ = mzero + data OAuth2 = OAuth2 { oauthClientId :: BS.ByteString , oauthClientSecret :: BS.ByteString , oauthOAuthorizeEndpoint :: BS.ByteString @@ -25,12 +30,12 @@ data OAuth2 = OAuth2 { oauthClientId :: BS.ByteString , oauthCallback :: Maybe BS.ByteString , oauthAccessToken :: Maybe BS.ByteString } deriving (Show, Eq) - + data OAuthException = OAuthException String deriving (Show, Eq, Typeable) - + instance Exception OAuthException - + newOAuth2 :: OAuth2 newOAuth2 = OAuth2 { oauthClientId = error "You must specify client id." , oauthClientSecret = error "You must specify client secret." @@ -39,32 +44,17 @@ newOAuth2 = OAuth2 { oauthClientId = error "You must specify client id." , oauthCallback = Nothing , oauthAccessToken = Nothing } - + authorizationUrl :: OAuth2 -> BS.ByteString -authorizationUrl oa = oauthOAuthorizeEndpoint oa `BS.append` queryString - where queryString = renderSimpleQuery True query +authorizationUrl oa = oauthOAuthorizeEndpoint oa `BS.append` queryString' + where queryString' = renderSimpleQuery True query query = foldr step [] [ ("client_id", Just $ oauthClientId oa) , ("response_type", Just "code") , ("redirect_uri", oauthCallback oa)] - + +request :: Request -> IO (Response BSL.ByteString) request req = (withManager . httpLbs) (req { checkStatus = \_ _ _ -> Nothing }) - -getAccessToken' :: OAuth2 -> BS.ByteString -> Maybe BS.ByteString -> IO BSL.ByteString -getAccessToken' oa code grant_type = do - rsp <- request req - if (HT.statusCode . responseStatus) rsp == 200 - then return $ responseBody rsp - else throwIO . OAuthException $ "Gaining access_token failed: " ++ BSL.unpack (responseBody rsp) - where - req = fromJust $ parseUrl url - url = BS.unpack $ oauthAccessTokenEndpoint oa `BS.append` queryString - queryString = renderSimpleQuery True query - query = foldr step [] [ ("client_id", Just $ oauthClientId oa) - , ("client_secret", Just $ oauthClientSecret oa) - , ("code", Just code) - , ("redirect_uri", oauthCallback oa) - , ("grant_type", grant_type) ] - + postAccessToken' :: OAuth2 -> BS.ByteString -> Maybe BS.ByteString -> IO BSL.ByteString postAccessToken' oa code grant_type = do rsp <- request req @@ -80,23 +70,20 @@ postAccessToken' oa code grant_type = do , ("code", Just code) , ("redirect_uri", oauthCallback oa) , ("grant_type", grant_type) ] - + step :: (a, Maybe b) -> [(a, b)] -> [(a, b)] step (a, Just b) xs = (a, b):xs step _ xs = xs - -getAccessToken :: OAuth2 -> BS.ByteString -> Maybe BS.ByteString -> IO (Maybe AccessToken) -getAccessToken oa code grant_type = decode <$> getAccessToken' oa code grant_type - + postAccessToken :: OAuth2 -> BS.ByteString -> Maybe BS.ByteString -> IO (Maybe AccessToken) postAccessToken oa code grant_type = decode <$> postAccessToken' oa code grant_type - + data AccessToken = AccessToken { accessToken :: BS.ByteString } deriving (Show) instance FromJSON AccessToken where parseJSON (Object o) = AccessToken <$> o .: "access_token" parseJSON _ = mzero - -signRequest :: OAuth2 -> Request m -> Request m + +signRequest :: OAuth2 -> Request -> Request signRequest oa req = req { queryString = (renderSimpleQuery False newQuery) } where newQuery = case oauthAccessToken oa of @@ -104,7 +91,7 @@ signRequest oa req = req { queryString = (renderSimpleQuery False newQuery) } _ -> insert ("client_id", oauthClientId oa) . insert ("client_secret", oauthClientSecret oa) $ oldQuery oldQuery = parseSimpleQuery (queryString req) -authorizeRequest :: AccessToken -> Request m -> Request m +authorizeRequest :: AccessToken -> Request -> Request authorizeRequest (AccessToken token) req = req { requestHeaders = auth : requestHeaders req } where auth = ("Authorization", BS.concat ["Bearer ", token]) diff --git a/yesod-auth-oauth2.cabal b/yesod-auth-oauth2.cabal index 765ffa2..eb1ca1c 100644 --- a/yesod-auth-oauth2.cabal +++ b/yesod-auth-oauth2.cabal @@ -21,9 +21,9 @@ library else build-depends: base >= 4 && < 4.3 build-depends: bytestring >= 0.9.1.4 - , http-conduit >= 1.9 && < 2 + , http-conduit >= 2.0 && < 3.0 , http-types >= 0.8 && < 0.9 - , aeson >= 0.6 && < 0.7 + , aeson >= 0.6 && < 0.8 , yesod-core >= 1.2 && < 1.3 , yesod-auth >= 1.2 && < 1.3 , text >= 0.7 && < 0.12 From 4ec390e32a60c2eee2f08f8f0bdccab68232ace4 Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Sat, 15 Feb 2014 15:11:03 -0500 Subject: [PATCH 2/5] Use Network.OAuth.OAuth2 * Provides basically the same interface * Re-export it for making additional requests --- Yesod/Auth/OAuth2.hs | 27 ++++++---- Yesod/Auth/OAuth2/Internal.hs | 97 ----------------------------------- yesod-auth-oauth2.cabal | 5 +- 3 files changed, 20 insertions(+), 109 deletions(-) delete mode 100644 Yesod/Auth/OAuth2/Internal.hs diff --git a/Yesod/Auth/OAuth2.hs b/Yesod/Auth/OAuth2.hs index 2a97631..aca6e0b 100644 --- a/Yesod/Auth/OAuth2.hs +++ b/Yesod/Auth/OAuth2.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings, QuasiQuotes #-} module Yesod.Auth.OAuth2 ( authOAuth2 , oauth2Google , oauth2Learn + , module Network.OAuth.OAuth2 ) where import Control.Monad.IO.Class @@ -13,7 +14,7 @@ import Data.Text.Encoding.Error (lenientDecode) import Yesod.Auth import Yesod.Form import Yesod.Core -import Yesod.Auth.OAuth2.Internal +import Network.OAuth.OAuth2 oauth2Url :: Text -> AuthRoute oauth2Url name = PluginR name ["forward"] @@ -43,10 +44,10 @@ authOAuth2 name oauth mkCreds = AuthPlugin name dispatch login render <- lift $ getUrlRender code <- lift $ runInputGet $ ireq textField "code" let oauth' = oauth { oauthCallback = Just $ encodeUtf8 $ render $ tm url } - mtoken <- liftIO $ postAccessToken oauth' (encodeUtf8 code) (Just "authorization_code") - case mtoken of - Nothing -> permissionDenied "Couldn't get token" - Just token -> do + result <- liftIO $ fetchAccessToken oauth' (encodeUtf8 code) + case result of + Left _ -> permissionDenied "Unable to retreive OAuth2 token" + Right token -> do creds <- liftIO $ mkCreds token lift $ setCreds True creds dispatch _ _ = notFound @@ -56,17 +57,21 @@ authOAuth2 name oauth mkCreds = AuthPlugin name dispatch login [whamlet| Login via #{name} |] oauth2Google :: Text -> Text -> OAuth2 -oauth2Google clientId clientSecret = newOAuth2 { oauthClientId = encodeUtf8 clientId - , oauthClientSecret = encodeUtf8 clientSecret - , oauthOAuthorizeEndpoint = "https://accounts.google.com/o/oauth2/auth" - , oauthAccessTokenEndpoint = "https://accounts.google.com/o/oauth2/token" } +oauth2Google clientId clientSecret = OAuth2 + { oauthClientId = encodeUtf8 clientId + , oauthClientSecret = encodeUtf8 clientSecret + , oauthOAuthorizeEndpoint = "https://accounts.google.com/o/oauth2/auth" + , oauthAccessTokenEndpoint = "https://accounts.google.com/o/oauth2/token" + , oauthCallback = Nothing + } oauth2Learn :: Text -> Text -> OAuth2 -oauth2Learn clientId clientSecret = newOAuth2 +oauth2Learn clientId clientSecret = OAuth2 { oauthClientId = encodeUtf8 clientId , oauthClientSecret = encodeUtf8 clientSecret , oauthOAuthorizeEndpoint = "http://learn.thoughtbot.com/oauth/authorize" , oauthAccessTokenEndpoint = "http://learn.thoughtbot.com/oauth/token" + , oauthCallback = Nothing } bsToText :: ByteString -> Text diff --git a/Yesod/Auth/OAuth2/Internal.hs b/Yesod/Auth/OAuth2/Internal.hs deleted file mode 100644 index a849ef8..0000000 --- a/Yesod/Auth/OAuth2/Internal.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveDataTypeable #-} -module Yesod.Auth.OAuth2.Internal where - -{- see https://gist.github.com/qzchenwl/2351071 -} - -import Data.Aeson -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy.Char8 as BSL -import Data.List -import Data.Maybe -import Data.Typeable (Typeable) -import Network.HTTP.Types (renderSimpleQuery, parseSimpleQuery) -import qualified Network.HTTP.Types as HT -import Network.HTTP.Conduit as C -import Control.Exception -import Control.Applicative ((<$>), pure) -import Control.Monad (mzero) -import Data.Text.Encoding (encodeUtf8) - -instance FromJSON BS.ByteString where - parseJSON (String t) = pure $ encodeUtf8 t - parseJSON _ = mzero - -data OAuth2 = OAuth2 { oauthClientId :: BS.ByteString - , oauthClientSecret :: BS.ByteString - , oauthOAuthorizeEndpoint :: BS.ByteString - , oauthAccessTokenEndpoint :: BS.ByteString - , oauthCallback :: Maybe BS.ByteString - , oauthAccessToken :: Maybe BS.ByteString - } deriving (Show, Eq) - -data OAuthException = OAuthException String - deriving (Show, Eq, Typeable) - -instance Exception OAuthException - -newOAuth2 :: OAuth2 -newOAuth2 = OAuth2 { oauthClientId = error "You must specify client id." - , oauthClientSecret = error "You must specify client secret." - , oauthOAuthorizeEndpoint = error "You must specify authorize endpoint." - , oauthAccessTokenEndpoint = error "You must specify access_token endpoint." - , oauthCallback = Nothing - , oauthAccessToken = Nothing - } - -authorizationUrl :: OAuth2 -> BS.ByteString -authorizationUrl oa = oauthOAuthorizeEndpoint oa `BS.append` queryString' - where queryString' = renderSimpleQuery True query - query = foldr step [] [ ("client_id", Just $ oauthClientId oa) - , ("response_type", Just "code") - , ("redirect_uri", oauthCallback oa)] - -request :: Request -> IO (Response BSL.ByteString) -request req = (withManager . httpLbs) (req { checkStatus = \_ _ _ -> Nothing }) - -postAccessToken' :: OAuth2 -> BS.ByteString -> Maybe BS.ByteString -> IO BSL.ByteString -postAccessToken' oa code grant_type = do - rsp <- request req - if (HT.statusCode . responseStatus) rsp == 200 - then return $ responseBody rsp - else throwIO . OAuthException $ "Gaining access_token failed: " ++ BSL.unpack (responseBody rsp) - where - toPost r = r { method = "POST" } - req = urlEncodedBody query . toPost . fromJust $ parseUrl url - url = BS.unpack $ oauthAccessTokenEndpoint oa - query = foldr step [] [ ("client_id", Just $ oauthClientId oa) - , ("client_secret", Just $ oauthClientSecret oa) - , ("code", Just code) - , ("redirect_uri", oauthCallback oa) - , ("grant_type", grant_type) ] - -step :: (a, Maybe b) -> [(a, b)] -> [(a, b)] -step (a, Just b) xs = (a, b):xs -step _ xs = xs - -postAccessToken :: OAuth2 -> BS.ByteString -> Maybe BS.ByteString -> IO (Maybe AccessToken) -postAccessToken oa code grant_type = decode <$> postAccessToken' oa code grant_type - -data AccessToken = AccessToken { accessToken :: BS.ByteString } deriving (Show) -instance FromJSON AccessToken where - parseJSON (Object o) = AccessToken <$> o .: "access_token" - parseJSON _ = mzero - -signRequest :: OAuth2 -> Request -> Request -signRequest oa req = req { queryString = (renderSimpleQuery False newQuery) } - where - newQuery = case oauthAccessToken oa of - Just at -> insert ("oauth_token", at) oldQuery - _ -> insert ("client_id", oauthClientId oa) . insert ("client_secret", oauthClientSecret oa) $ oldQuery - oldQuery = parseSimpleQuery (queryString req) - -authorizeRequest :: AccessToken -> Request -> Request -authorizeRequest (AccessToken token) req = req { requestHeaders = auth : requestHeaders req } - where - auth = ("Authorization", BS.concat ["Bearer ", token]) diff --git a/yesod-auth-oauth2.cabal b/yesod-auth-oauth2.cabal index eb1ca1c..d093703 100644 --- a/yesod-auth-oauth2.cabal +++ b/yesod-auth-oauth2.cabal @@ -20,6 +20,7 @@ library cpp-options: -DGHC7 else build-depends: base >= 4 && < 4.3 + build-depends: bytestring >= 0.9.1.4 , http-conduit >= 2.0 && < 3.0 , http-types >= 0.8 && < 0.9 @@ -29,8 +30,10 @@ library , text >= 0.7 && < 0.12 , yesod-form >= 1.3 && < 1.4 , transformers >= 0.2.2 && < 0.4 + , hoauth2 >= 0.3.6 && < 0.4 + exposed-modules: Yesod.Auth.OAuth2 - other-modules: Yesod.Auth.OAuth2.Internal + ghc-options: -Wall source-repository head From 1ea281b4b1dc7192563b42bb8aba0f8632a9ccdf Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Sat, 15 Feb 2014 15:23:58 -0500 Subject: [PATCH 3/5] Minor refactor --- Yesod/Auth/OAuth2.hs | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/Yesod/Auth/OAuth2.hs b/Yesod/Auth/OAuth2.hs index aca6e0b..fabb3b8 100644 --- a/Yesod/Auth/OAuth2.hs +++ b/Yesod/Auth/OAuth2.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings, QuasiQuotes #-} module Yesod.Auth.OAuth2 ( authOAuth2 + , oauth2Url , oauth2Google , oauth2Learn , module Network.OAuth.OAuth2 @@ -33,24 +34,28 @@ authOAuth2 name oauth mkCreds = AuthPlugin name dispatch login where url = PluginR name ["callback"] - dispatch "GET" ["forward"] = do - tm <- getRouteToParent - lift $ do - render <- getUrlRender - let oauth' = oauth { oauthCallback = Just $ encodeUtf8 $ render $ tm url } - redirect $ bsToText $ authorizationUrl oauth' - dispatch "GET" ["callback"] = do + + withCallback = do tm <- getRouteToParent render <- lift $ getUrlRender + return $ oauth { oauthCallback = Just $ encodeUtf8 $ render $ tm url } + + dispatch "GET" ["forward"] = do + authUrl <- fmap (bsToText . authorizationUrl) withCallback + lift $ redirect authUrl + + dispatch "GET" ["callback"] = do code <- lift $ runInputGet $ ireq textField "code" - let oauth' = oauth { oauthCallback = Just $ encodeUtf8 $ render $ tm url } + oauth' <- withCallback result <- liftIO $ fetchAccessToken oauth' (encodeUtf8 code) case result of Left _ -> permissionDenied "Unable to retreive OAuth2 token" Right token -> do creds <- liftIO $ mkCreds token lift $ setCreds True creds + dispatch _ _ = notFound + login tm = do render <- getUrlRender let oaUrl = render $ tm $ oauth2Url name From 7536e7f25f33615c5f4a9f8f963fc0d8c2acb93e Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Sat, 15 Feb 2014 15:56:15 -0500 Subject: [PATCH 4/5] Refactor to separate modules, document things * oauth2 functions now handle the getCreds argument themselves * Learn is updated to do the Right Thing * Google is unfinished --- Yesod/Auth/OAuth2.hs | 42 +++++++------------- Yesod/Auth/OAuth2/Google.hs | 30 +++++++++++++++ Yesod/Auth/OAuth2/Learn.hs | 76 +++++++++++++++++++++++++++++++++++++ yesod-auth-oauth2.cabal | 2 + 4 files changed, 122 insertions(+), 28 deletions(-) create mode 100644 Yesod/Auth/OAuth2/Google.hs create mode 100644 Yesod/Auth/OAuth2/Learn.hs diff --git a/Yesod/Auth/OAuth2.hs b/Yesod/Auth/OAuth2.hs index fabb3b8..96c56cb 100644 --- a/Yesod/Auth/OAuth2.hs +++ b/Yesod/Auth/OAuth2.hs @@ -1,21 +1,25 @@ {-# LANGUAGE OverloadedStrings, QuasiQuotes #-} +-- | +-- +-- Generic OAuth2 plugin for Yesod +-- +-- * See Yesod.Auth.OAuth2.Learn for example usage. +-- module Yesod.Auth.OAuth2 ( authOAuth2 , oauth2Url - , oauth2Google - , oauth2Learn , module Network.OAuth.OAuth2 ) where import Control.Monad.IO.Class -import Data.ByteString (ByteString) -import Data.Text (Text) -import Data.Text.Encoding (decodeUtf8With, encodeUtf8) +import Data.ByteString (ByteString) +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8With, encodeUtf8) import Data.Text.Encoding.Error (lenientDecode) -import Yesod.Auth -import Yesod.Form -import Yesod.Core import Network.OAuth.OAuth2 +import Yesod.Auth +import Yesod.Core +import Yesod.Form oauth2Url :: Text -> AuthRoute oauth2Url name = PluginR name ["forward"] @@ -30,7 +34,7 @@ authOAuth2 :: YesodAuth m -- authorized request to @api/me.json@. -> (AccessToken -> IO (Creds m)) -> AuthPlugin m -authOAuth2 name oauth mkCreds = AuthPlugin name dispatch login +authOAuth2 name oauth getCreds = AuthPlugin name dispatch login where url = PluginR name ["callback"] @@ -51,7 +55,7 @@ authOAuth2 name oauth mkCreds = AuthPlugin name dispatch login case result of Left _ -> permissionDenied "Unable to retreive OAuth2 token" Right token -> do - creds <- liftIO $ mkCreds token + creds <- liftIO $ getCreds token lift $ setCreds True creds dispatch _ _ = notFound @@ -61,23 +65,5 @@ authOAuth2 name oauth mkCreds = AuthPlugin name dispatch login let oaUrl = render $ tm $ oauth2Url name [whamlet| Login via #{name} |] -oauth2Google :: Text -> Text -> OAuth2 -oauth2Google clientId clientSecret = OAuth2 - { oauthClientId = encodeUtf8 clientId - , oauthClientSecret = encodeUtf8 clientSecret - , oauthOAuthorizeEndpoint = "https://accounts.google.com/o/oauth2/auth" - , oauthAccessTokenEndpoint = "https://accounts.google.com/o/oauth2/token" - , oauthCallback = Nothing - } - -oauth2Learn :: Text -> Text -> OAuth2 -oauth2Learn clientId clientSecret = OAuth2 - { oauthClientId = encodeUtf8 clientId - , oauthClientSecret = encodeUtf8 clientSecret - , oauthOAuthorizeEndpoint = "http://learn.thoughtbot.com/oauth/authorize" - , oauthAccessTokenEndpoint = "http://learn.thoughtbot.com/oauth/token" - , oauthCallback = Nothing - } - bsToText :: ByteString -> Text bsToText = decodeUtf8With lenientDecode diff --git a/Yesod/Auth/OAuth2/Google.hs b/Yesod/Auth/OAuth2/Google.hs new file mode 100644 index 0000000..662849e --- /dev/null +++ b/Yesod/Auth/OAuth2/Google.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- +-- OAuth2 plugin for http://google.com +-- +-- * Note: this module is unfinished, do not use. +-- +module Yesod.Auth.OAuth2.Google + ( oauth2Google + , module Yesod.Auth.OAuth2 + ) where + +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +import Yesod.Auth +import Yesod.Auth.OAuth2 + +oauth2Google :: YesodAuth m + => Text -- ^ Client ID + -> Text -- ^ Client Secret + -> AuthPlugin m +oauth2Google clientId clientSecret = authOAuth2 "google" + (OAuth2 + { oauthClientId = encodeUtf8 clientId + , oauthClientSecret = encodeUtf8 clientSecret + , oauthOAuthorizeEndpoint = "https://accounts.google.com/o/oauth2/auth" + , oauthAccessTokenEndpoint = "https://accounts.google.com/o/oauth2/token" + , oauthCallback = Nothing + }) + undefined -- TODO diff --git a/Yesod/Auth/OAuth2/Learn.hs b/Yesod/Auth/OAuth2/Learn.hs new file mode 100644 index 0000000..e876006 --- /dev/null +++ b/Yesod/Auth/OAuth2/Learn.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- +-- OAuth2 plugin for http://learn.thoughbot.com +-- +-- * Authenticates against learn +-- * Uses learn user id as credentials identifier +-- * Returns first_name, last_name, and email as extras +-- +module Yesod.Auth.OAuth2.Learn + ( oauth2Learn + , module Yesod.Auth.OAuth2 + ) where + +import Control.Applicative ((<$>), (<*>)) +import Control.Monad (mzero) +import Data.Aeson +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +import Yesod.Auth +import Yesod.Auth.OAuth2 +import qualified Data.Text as T + +data LearnUser = LearnUser + { learnUserId :: Int + , learnUserFirstName :: Text + , learnUserLastName :: Text + , learnUserEmail :: Text + } + +instance FromJSON LearnUser where + parseJSON (Object o) = + LearnUser <$> o .: "id" + <*> o .: "first_name" + <*> o .: "last_name" + <*> o .: "email" + + parseJSON _ = mzero + +data LearnResponse = LearnResponse LearnUser + +instance FromJSON LearnResponse where + parseJSON (Object o) = + LearnResponse <$> o .: "user" + + parseJSON _ = mzero + +oauth2Learn :: YesodAuth m + => Text -- ^ Client ID + -> Text -- ^ Client Secret + -> AuthPlugin m +oauth2Learn clientId clientSecret = authOAuth2 "learn" + (OAuth2 + { oauthClientId = encodeUtf8 clientId + , oauthClientSecret = encodeUtf8 clientSecret + , oauthOAuthorizeEndpoint = "http://learn.thoughtbot.com/oauth/authorize" + , oauthAccessTokenEndpoint = "http://learn.thoughtbot.com/oauth/token" + , oauthCallback = Nothing + }) + fetchLearnProfile + +fetchLearnProfile :: AccessToken -> IO (Creds m) +fetchLearnProfile token = do + result <- authGetJSON token "http://learn.thoughtbot.com/api/v1/me.json" + + case result of + Right (LearnResponse user) -> return $ toCreds user + _ -> error "Invalid response for learn profile data" + +toCreds :: LearnUser -> Creds m +toCreds user = Creds "learn" + (T.pack $ show $ learnUserId user) + [ ("first_name", learnUserFirstName user) + , ("last_name" , learnUserLastName user) + , ("email" , learnUserEmail user) + ] diff --git a/yesod-auth-oauth2.cabal b/yesod-auth-oauth2.cabal index d093703..f11daf4 100644 --- a/yesod-auth-oauth2.cabal +++ b/yesod-auth-oauth2.cabal @@ -33,6 +33,8 @@ library , hoauth2 >= 0.3.6 && < 0.4 exposed-modules: Yesod.Auth.OAuth2 + Yesod.Auth.OAuth2.Google + Yesod.Auth.OAuth2.Learn ghc-options: -Wall From 4b6cb31ba98cfc7a2e6f2586bef0554cae6708c6 Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Sat, 15 Feb 2014 16:05:59 -0500 Subject: [PATCH 5/5] Typos --- Yesod/Auth/OAuth2.hs | 6 +++--- Yesod/Auth/OAuth2/Learn.hs | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/Yesod/Auth/OAuth2.hs b/Yesod/Auth/OAuth2.hs index 96c56cb..99362d4 100644 --- a/Yesod/Auth/OAuth2.hs +++ b/Yesod/Auth/OAuth2.hs @@ -29,9 +29,9 @@ authOAuth2 :: YesodAuth m -> OAuth2 -- ^ Service details -- | This function defines how to take an @'AccessToken'@ and - -- retrive additional information about the user, to be set - -- in the session as @'Creds'@. Usually this means a second - -- authorized request to @api/me.json@. + -- retrieve additional information about the user, to be + -- set in the session as @'Creds'@. Usually this means a + -- second authorized request to @api/me.json@. -> (AccessToken -> IO (Creds m)) -> AuthPlugin m authOAuth2 name oauth getCreds = AuthPlugin name dispatch login diff --git a/Yesod/Auth/OAuth2/Learn.hs b/Yesod/Auth/OAuth2/Learn.hs index e876006..46879ad 100644 --- a/Yesod/Auth/OAuth2/Learn.hs +++ b/Yesod/Auth/OAuth2/Learn.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} -- | -- --- OAuth2 plugin for http://learn.thoughbot.com +-- OAuth2 plugin for http://learn.thoughtbot.com -- -- * Authenticates against learn -- * Uses learn user id as credentials identifier