added csrf state token

Yesod/Auth/OAuth2.hs

@@ -17,12 +17,14 @@ module Yesod.Auth.OAuth2
 import Control.Exception.Lifted
 import Control.Monad.IO.Class
 import Data.ByteString (ByteString)
-import Data.Text (Text)
+import qualified Data.ByteString as BS
+import Data.Text (Text, append, pack)
 import Data.Text.Encoding (decodeUtf8With, encodeUtf8)
 import Data.Text.Encoding.Error (lenientDecode)
 import Data.Typeable
 import Network.OAuth.OAuth2
 import Network.HTTP.Conduit(Manager)
+import System.Random
 import Yesod.Auth
 import Yesod.Core
 import Yesod.Form
@@ -52,28 +54,46 @@ authOAuth2 name oauth getCreds = AuthPlugin name dispatch login
     where
         url = PluginR name ["callback"]
 
-        withCallback = do
+        withCallback csrfToken = do
             tm <- getRouteToParent
             render <- lift $ getUrlRender
-            return $ oauth { oauthCallback = Just $ encodeUtf8 $ render $ tm url }
+            let newEndpoint = oauthOAuthorizeEndpoint oauth `BS.append` "&state=" `BS.append` encodeUtf8 csrfToken
+            return $ oauth { 
+                    oauthCallback = Just $ encodeUtf8 $ render $ tm url, 
+                    oauthOAuthorizeEndpoint = newEndpoint
+                }
 
         dispatch "GET" ["forward"] = do
-            authUrl <- fmap (bsToText . authorizationUrl) withCallback
+            csrfToken <- liftIO $ generateToken
+            setSession tokenSessionKey csrfToken
+            authUrl <- fmap (bsToText . authorizationUrl) $ withCallback csrfToken
             lift $ redirect authUrl
 
         dispatch "GET" ["callback"] = do
-            code <- lift $ runInputGet $ ireq textField "code"
-            oauth' <- withCallback
-            master <- lift getYesod
-            result <- liftIO $ fetchAccessToken (authHttpManager master) oauth' (encodeUtf8 code)
-            case result of
-                Left _ -> permissionDenied "Unable to retreive OAuth2 token"
-                Right token -> do
-                    creds <- liftIO $ getCreds (authHttpManager master) token
-                    lift $ setCredsRedirect creds
+            newToken <- lookupGetParam "state"
+            oldToken <- lookupSession tokenSessionKey
+            deleteSession tokenSessionKey
+            case newToken of
+                Just csrfToken | newToken == oldToken -> do
+                    code <- lift $ runInputGet $ ireq textField "code"
+                    oauth' <- withCallback csrfToken
+                    master <- lift getYesod
+                    result <- liftIO $ fetchAccessToken (authHttpManager master) oauth' (encodeUtf8 code)
+                    case result of
+                        Left _ -> permissionDenied "Unable to retreive OAuth2 token"
+                        Right token -> do
+                            creds <- liftIO $ getCreds (authHttpManager master) token
+                            lift $ setCredsRedirect creds
+                _ ->
+                    permissionDenied "Invalid OAuth2 state token"
 
         dispatch _ _ = notFound
 
+        generateToken = fmap (pack . take 30 . randomRs ('a','z')) newStdGen
+
+        tokenSessionKey :: Text
+        tokenSessionKey = "_yesod_oauth2_" `append` name
+
         login tm = do
             render <- getUrlRender
             let oaUrl = render $ tm $ oauth2Url name

yesod-auth-oauth2.cabal

@@ -36,6 +36,7 @@ library
                    , aeson                   >= 0.6       && < 0.9
                    , yesod-core              >= 1.2       && < 1.5
                    , authenticate            >= 1.3.2.7   && < 1.4
+                   , random
                    , yesod-auth              >= 1.3       && < 1.5
                    , text                    >= 0.7       && < 2.0
                    , yesod-form              >= 1.3       && < 1.5