haskell/yesod-auth-oauth2
1
0
Fork 0
mirror of https://github.com/freckle/yesod-auth-oauth2.git synced 2026-03-01 10:54:36 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

Minor refactor

Browse Source
This commit is contained in:
patrick brisbin 2014-02-15 15:23:58 -05:00
parent 4ec390e32a
commit 1ea281b4b1
1 changed files with 13 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
Yesod/Auth/OAuth2.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE OverloadedStrings, QuasiQuotes #-} {-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
module Yesod.Auth.OAuth2 module Yesod.Auth.OAuth2
( authOAuth2 ( authOAuth2
, oauth2Url
, oauth2Google , oauth2Google
, oauth2Learn , oauth2Learn
, module Network.OAuth.OAuth2 , module Network.OAuth.OAuth2
@ -33,24 +34,28 @@ authOAuth2 name oauth mkCreds = AuthPlugin name dispatch login
where where
url = PluginR name ["callback"] url = PluginR name ["callback"]
dispatch "GET" ["forward"] = do
tm <- getRouteToParent withCallback = do
lift $ do
render <- getUrlRender
let oauth' = oauth { oauthCallback = Just $ encodeUtf8 $ render $ tm url }
redirect $ bsToText $ authorizationUrl oauth'
dispatch "GET" ["callback"] = do
tm <- getRouteToParent tm <- getRouteToParent
render <- lift $ getUrlRender 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" code <- lift $ runInputGet $ ireq textField "code"
let oauth' = oauth { oauthCallback = Just $ encodeUtf8 $ render $ tm url } oauth' <- withCallback
result <- liftIO $ fetchAccessToken oauth' (encodeUtf8 code) result <- liftIO $ fetchAccessToken oauth' (encodeUtf8 code)
case result of case result of
Left _ -> permissionDenied "Unable to retreive OAuth2 token" Left _ -> permissionDenied "Unable to retreive OAuth2 token"
Right token -> do Right token -> do
creds <- liftIO $ mkCreds token creds <- liftIO $ mkCreds token
lift $ setCreds True creds lift $ setCreds True creds
dispatch _ _ = notFound dispatch _ _ = notFound
login tm = do login tm = do
render <- getUrlRender render <- getUrlRender
let oaUrl = render $ tm $ oauth2Url name let oaUrl = render $ tm $ oauth2Url name