haskell/yesod-auth-oauth2
1
0
Fork 0
mirror of https://github.com/freckle/yesod-auth-oauth2.git synced 2026-09-10 19:34:56 +02:00
Code Issues Actions 1 Packages Projects Releases Wiki Activity

Cleanup as suggested by @pbrisbin

Browse Source
This commit is contained in:
silky 2015-10-14 10:26:36 +11:00
parent 60c91306f1
commit 3efa4175a0
1 changed files with 16 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
Yesod/Auth/OAuth2.hs
View File

@ -24,6 +24,7 @@ import Control.Applicative ((<$>))
import Control.Exception.Lifted import Control.Exception.Lifted
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad (unless)
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.Monoid ((<>)) import Data.Monoid ((<>))
import Data.Text (Text, pack) import Data.Text (Text, pack)
@ -35,7 +36,6 @@ import Network.OAuth.OAuth2
import System.Random import System.Random
import Yesod.Auth import Yesod.Auth
import Yesod.Core import Yesod.Core
import Yesod.Form
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
@ -97,22 +97,23 @@ authOAuth2Widget widget name oauth getCreds = AuthPlugin name dispatch login
lift $ redirect authUrl lift $ redirect authUrl
dispatch "GET" ["callback"] = do dispatch "GET" ["callback"] = do
newToken <- lookupGetParam "state" csrfToken <- requireGetParam "state"
oldToken <- lookupSession tokenSessionKey oldToken <- lookupSession tokenSessionKey
deleteSession tokenSessionKey deleteSession tokenSessionKey
case newToken of unless (oldToken == (Just csrfToken)) $ permissionDenied "Invalid OAuth2 state token"
Just csrfToken | newToken == oldToken -> do code <- requireGetParam "code"
code <- lift $ runInputGet $ ireq textField "code" oauth' <- withCallback csrfToken
oauth' <- withCallback csrfToken master <- lift getYesod
master <- lift getYesod result <- liftIO $ fetchAccessToken (authHttpManager master) oauth' (encodeUtf8 code)
result <- liftIO $ fetchAccessToken (authHttpManager master) 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 $ getCreds (authHttpManager master) token
creds <- liftIO $ getCreds (authHttpManager master) token lift $ setCredsRedirect creds
lift $ setCredsRedirect creds where
_ -> requireGetParam key = do
permissionDenied "Invalid OAuth2 state token" m <- lookupGetParam key
maybe (permissionDenied $ "'" <> key <> "' parameter not provided") return m
dispatch _ _ = notFound dispatch _ _ = notFound