haskell/yesod-auth-oauth2
1
0
Fork 0
mirror of https://github.com/freckle/yesod-auth-oauth2.git synced 2026-01-12 04:08:30 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

Merge pull request #1 from pbrisbin/master

Browse Source 
Updates, fixes - request to maintain
This commit is contained in:
scan 2014-02-18 12:49:11 +01:00
commit 5c5f2eb613
5 changed files with 161 additions and 146 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
Yesod/Auth/OAuth2.hs
View File

@ -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| <a href=#{oaUrl}>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

30
Yesod/Auth/OAuth2/Google.hs Normal file
View File

@ -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

110
Yesod/Auth/OAuth2/Internal.hs
View File

@ -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])

76
Yesod/Auth/OAuth2/Learn.hs Normal file
View File

@ -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)
]

11
yesod-auth-oauth2.cabal
View File

@ -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