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