diff --git a/Yesod/Auth/OAuth2.hs b/Yesod/Auth/OAuth2.hs index 9ff4677..99362d4 100644 --- a/Yesod/Auth/OAuth2.hs +++ b/Yesod/Auth/OAuth2.hs @@ -1,55 +1,69 @@ -{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, QuasiQuotes #-} -module Yesod.Auth.OAuth2 where +{-# LANGUAGE OverloadedStrings, QuasiQuotes #-} +-- | +-- +-- Generic OAuth2 plugin for Yesod +-- +-- * See Yesod.Auth.OAuth2.Learn for example usage. +-- +module Yesod.Auth.OAuth2 + ( authOAuth2 + , oauth2Url + , 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 Data.Maybe -import Network.HTTP.Conduit as C +import Network.OAuth.OAuth2 import Yesod.Auth -import Yesod.Form import Yesod.Core -import Yesod.Auth.OAuth2.Internal +import Yesod.Form oauth2Url :: Text -> AuthRoute oauth2Url name = PluginR name ["forward"] +authOAuth2 :: YesodAuth m + => Text -- ^ Service name + -> OAuth2 -- ^ Service details + + -- | This function defines how to take an @'AccessToken'@ and + -- 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 + where url = PluginR name ["callback"] - dispatch "GET" ["forward"] = do + + withCallback = do tm <- getRouteToParent - lift $ do - render <- getUrlRender - let oauth' = oauth { oauthCallback = Just $ encodeUtf8 $ render $ tm url } - redirect $ authorizationUrl oauth' + 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" - mtoken <- liftIO $ postAccessToken oauth (encodeUtf8 code) (Just "authorization_code") - case mtoken of - Nothing -> permissionDenied "Couldn't get token" - Just token -> getCreds token - disptach _ _ = notFound + oauth' <- withCallback + result <- liftIO $ fetchAccessToken oauth' (encodeUtf8 code) + case result of + Left _ -> permissionDenied "Unable to retreive OAuth2 token" + Right token -> do + creds <- liftIO $ getCreds token + lift $ setCreds True creds + + dispatch _ _ = notFound + login tm = do render <- getUrlRender let oaUrl = render $ tm $ oauth2Url name [whamlet| Login via #{name} |] -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" } - 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/Internal.hs b/Yesod/Auth/OAuth2/Internal.hs deleted file mode 100644 index d38cd36..0000000 --- a/Yesod/Auth/OAuth2/Internal.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-# 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) -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.Monad (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 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 - 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 - -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 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 m -> Request m -authorizeRequest (AccessToken token) req = req { requestHeaders = auth : requestHeaders req } - where - auth = ("Authorization", BS.concat ["Bearer ", token]) diff --git a/Yesod/Auth/OAuth2/Learn.hs b/Yesod/Auth/OAuth2/Learn.hs new file mode 100644 index 0000000..46879ad --- /dev/null +++ b/Yesod/Auth/OAuth2/Learn.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- +-- OAuth2 plugin for http://learn.thoughtbot.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 765ffa2..f11daf4 100644 --- a/yesod-auth-oauth2.cabal +++ b/yesod-auth-oauth2.cabal @@ -20,17 +20,22 @@ library cpp-options: -DGHC7 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 , 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 + Yesod.Auth.OAuth2.Google + Yesod.Auth.OAuth2.Learn + ghc-options: -Wall source-repository head