Tighten up CSRF

TODO #17

src/Foundation.hs

@@ -25,6 +25,8 @@ import Yesod.Auth.Message
 import Yesod.Auth.Dummy
 import Yesod.Auth.LDAP
 
+import qualified Network.Wai as W (requestMethod)
+
 import LDAP.Data (LDAPScope(..))
 import LDAP.Search (LDAPEntry(..))
 
@@ -456,8 +458,10 @@ instance Yesod UniWorX where
     --   b) Validates that incoming write requests include that token in either a header or POST parameter.
     -- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware
     -- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package.
-    yesodMiddleware handler = do
+    yesodMiddleware = updateFavouritesMiddleware . defaultYesodMiddleware . defaultCsrfMiddleware
-      void . runMaybeT $ do
+      where
+        updateFavouritesMiddleware :: Handler a -> Handler a
+        updateFavouritesMiddleware handler = (*> handler) . runMaybeT $ do
           route <- MaybeT getCurrentRoute
           guardM . lift $ (== Authorized) <$> isAuthorized route False
           case route of -- update Course Favourites here
@@ -480,9 +484,14 @@ instance Yesod UniWorX where
                   , OffsetBy $ userMaxFavourites user
                   ]
                 lift $ mapM_ delete oldFavs
-
             _other -> return ()
-      defaultYesodMiddleware handler -- handler is executed afterwards, so Favourites are updated immediately
+
+    -- The following exception permits drive-by login via LDAP plugin. FIXME: Blocked by #17
+    isWriteRequest (AuthR (PluginR "LDAP" _)) = return False
+    isWriteRequest _ = do
+      wai <- waiRequest
+      return $ W.requestMethod wai `notElem`
+        ["GET", "HEAD", "OPTIONS", "TRACE"]
 
     defaultLayout widget = do
         master <- getYesod