mirror of
https://github.com/freckle/yesod-auth-oauth2.git
synced 2026-01-11 19:58:28 +01:00
Use Network.OAuth.OAuth2
* Provides basically the same interface * Re-export it for making additional requests
This commit is contained in:
patrick brisbin
parent
434e2bc092
commit
4ec390e32a
@ -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| <a href=#{oaUrl}>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
|
||||
|
||||
@ -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])
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user