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,33 +458,40 @@ 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
-        route <- MaybeT getCurrentRoute
+        updateFavouritesMiddleware :: Handler a -> Handler a
-        guardM . lift $ (== Authorized) <$> isAuthorized route False
+        updateFavouritesMiddleware handler = (*> handler) . runMaybeT $ do
-        case route of -- update Course Favourites here
+          route <- MaybeT getCurrentRoute
-          CourseR tid csh _  -> do
+          guardM . lift $ (== Authorized) <$> isAuthorized route False
-            uid <- MaybeT maybeAuthId
+          case route of -- update Course Favourites here
-            $(logDebug) "Favourites save"
+            CourseR tid csh _  -> do
-            now <- liftIO $ getCurrentTime
+              uid <- MaybeT maybeAuthId
-            void . lift . runDB . runMaybeT $ do
+              $(logDebug) "Favourites save"
-              cid  <- MaybeT . getKeyBy $ CourseTermShort tid csh
+              now <- liftIO $ getCurrentTime
-              user <- MaybeT $ get uid
+              void . lift . runDB . runMaybeT $ do
-              -- update Favourites
+                cid  <- MaybeT . getKeyBy $ CourseTermShort tid csh
-              void . lift $ upsertBy
+                user <- MaybeT $ get uid
-                      (UniqueCourseFavourite uid cid)
+                -- update Favourites
-                      (CourseFavourite uid now cid)
+                void . lift $ upsertBy
-                      [CourseFavouriteTime =. now]
+                  (UniqueCourseFavourite uid cid)
-              -- prune Favourites to user-defined size
+                  (CourseFavourite uid now cid)
-              oldFavs <- lift $ selectKeysList
+                  [CourseFavouriteTime =. now]
-                                  [ CourseFavouriteUser ==. uid]
+                -- prune Favourites to user-defined size
-                                  [ Desc CourseFavouriteTime
+                oldFavs <- lift $ selectKeysList
-                                  , OffsetBy $ userMaxFavourites user
+                  [ CourseFavouriteUser ==. uid]
-                                  ]
+                  [ Desc CourseFavouriteTime
-              lift $ mapM_ delete oldFavs
+                  , OffsetBy $ userMaxFavourites user
+                  ]
+                lift $ mapM_ delete oldFavs
+            _other -> return ()
 
-          _other -> return ()
+    -- The following exception permits drive-by login via LDAP plugin. FIXME: Blocked by #17
-      defaultYesodMiddleware handler -- handler is executed afterwards, so Favourites are updated immediately
+    isWriteRequest (AuthR (PluginR "LDAP" _)) = return False
+    isWriteRequest _ = do
+      wai <- waiRequest
+      return $ W.requestMethod wai `notElem`
+        ["GET", "HEAD", "OPTIONS", "TRACE"]
 
     defaultLayout widget = do
         master <- getYesod