From 434e2bc0924b5f6945bd5d52628091194bc18605 Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Sat, 15 Feb 2014 14:44:01 -0500 Subject: [PATCH] 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