diff --git a/src/Foundation.hs b/src/Foundation.hs index ac7cd37d2..8134af45a 100644 --- a/src/Foundation.hs +++ b/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 - void . runMaybeT $ do - route <- MaybeT getCurrentRoute - guardM . lift $ (== Authorized) <$> isAuthorized route False - case route of -- update Course Favourites here - CourseR tid csh _ -> do - uid <- MaybeT maybeAuthId - $(logDebug) "Favourites save" - now <- liftIO $ getCurrentTime - void . lift . runDB . runMaybeT $ do - cid <- MaybeT . getKeyBy $ CourseTermShort tid csh - user <- MaybeT $ get uid - -- update Favourites - void . lift $ upsertBy - (UniqueCourseFavourite uid cid) - (CourseFavourite uid now cid) - [CourseFavouriteTime =. now] - -- prune Favourites to user-defined size - oldFavs <- lift $ selectKeysList - [ CourseFavouriteUser ==. uid] - [ Desc CourseFavouriteTime - , OffsetBy $ userMaxFavourites user - ] - lift $ mapM_ delete oldFavs + yesodMiddleware = updateFavouritesMiddleware . defaultYesodMiddleware . defaultCsrfMiddleware + 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 + CourseR tid csh _ -> do + uid <- MaybeT maybeAuthId + $(logDebug) "Favourites save" + now <- liftIO $ getCurrentTime + void . lift . runDB . runMaybeT $ do + cid <- MaybeT . getKeyBy $ CourseTermShort tid csh + user <- MaybeT $ get uid + -- update Favourites + void . lift $ upsertBy + (UniqueCourseFavourite uid cid) + (CourseFavourite uid now cid) + [CourseFavouriteTime =. now] + -- prune Favourites to user-defined size + oldFavs <- lift $ selectKeysList + [ CourseFavouriteUser ==. uid] + [ Desc CourseFavouriteTime + , OffsetBy $ userMaxFavourites user + ] + lift $ mapM_ delete oldFavs + _other -> return () - _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