haskell/yesod-auth-oauth2
1
0
Fork 0
mirror of https://github.com/freckle/yesod-auth-oauth2.git synced 2026-04-26 20:57:48 +02:00
Code Issues Actions Packages Projects Releases Wiki Activity

Nicer error message when 'code' field missing

Browse Source 
Fixes #42
This commit is contained in:
silky 2015-10-14 10:26:36 +11:00 committed by patrick brisbin
parent 6c16a7458d
commit 7354c36e13
No known key found for this signature in database
GPG Key ID: ADB6812F871D4478
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
import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Char8 as C8
@ -98,22 +98,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