_{MsgErrorResponseEncrypted} -
- #{ciphertext}
- |]
- | otherwise -> plaintext
-
- errPage = case err of
- NotFound -> [whamlet|_{MsgErrorResponseNotFound}|]
- InternalError err' -> encrypted err' [whamlet|
#{err'}|]
- InvalidArgs errs -> [whamlet|
-
_{MsgErrorResponseNotAuthenticated}|] - PermissionDenied err' -> [whamlet|
#{err'}|] - BadMethod method -> [whamlet|
_{MsgErrorResponseBadMethod (decodeUtf8 method)}|] - siteLayout (toWgt . mr $ ErrorResponseTitle err) $ do - toWidget - [cassius| - .errMsg - white-space: pre-wrap - font-family: monospace - |] - errPage - provideRep . fmap PrettyValue $ case err of - PermissionDenied err' -> return $ object [ "message" JSON..= err' ] - InternalError err' - | shouldEncrypt -> do - ciphertext <- encodedSecretBox SecretBoxShort err' - return $ object [ "message" JSON..= ciphertext - , "encrypted" JSON..= True - ] - | otherwise -> return $ object [ "message" JSON..= err' ] - InvalidArgs errs -> return $ object [ "messages" JSON..= errs ] - _other -> return $ object [] - provideRep $ case err of - PermissionDenied err' -> return err' - InternalError err' - | shouldEncrypt -> do - addHeader "Encrypted-Error-Message" "True" - encodedSecretBox SecretBoxPretty err' - | otherwise -> return err' - InvalidArgs errs -> return . Text.unlines . map (Text.replace "\n" "\n\t") $ errs - _other -> return Text.empty - - defaultLayout = siteLayout' Nothing - - -- The page to be redirected to when authentication is required. - authRoute _ = Just $ AuthR LoginR - - isAuthorized = evalAccess - - addStaticContent ext _mime content = do - UniWorX{appWidgetMemcached, appSettings'} <- getYesod - for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings') $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConf = MemcachedConf { memcachedExpiry }, widgetMemcachedBaseUrl }) -> do - let expiry = maybe 0 ceiling memcachedExpiry - touch = liftIO $ Memcached.touch expiry (encodeUtf8 $ pack fileName) mConn - add = liftIO $ Memcached.add zeroBits expiry (encodeUtf8 $ pack fileName) content mConn - absoluteLink = unpack widgetMemcachedBaseUrl fileName - C.catchIf Memcached.isKeyNotFound touch $ \_ -> - C.handleIf Memcached.isKeyExists (\_ -> return ()) add - return . Left $ pack absoluteLink - where - -- Generate a unique filename based on the content itself, this is used - -- for deduplication so a collision resistant hash function is required - -- - -- SHA-3 (SHAKE256) seemed to be a future-proof choice - -- - -- Length of hash is 144 bits instead of MD5's 128, so as to avoid - -- padding after base64-conversion - fileName = (<.> unpack ext) - . unpack - . decodeUtf8 - . Base64.encode - . (convert :: Digest (SHAKE256 144) -> ByteString) - . runConduitPure - $ sourceList (Lazy.ByteString.toChunks content) .| sinkHash - - fileUpload _site _length = FileUploadMemory lbsBackEnd - - -- What messages should be logged. The following includes all messages when - -- in development, and warnings and errors in production. - shouldLogIO app _source level = do - LogSettings{..} <- readTVarIO $ appLogSettings app - return $ logAll || level >= logMinimumLevel - - makeLogger = readTVarIO . snd . appLogger - - --- langForm :: Form (Lang, Route UniWorX) --- langForm csrf = do --- lang <- selectLanguage appLanguages --- route <- getCurrentRoute --- (urlRes, urlView) <- mreq hiddenField ("" & addName ("referer" :: Text)) route --- (langBoxRes, langBoxView) <- mreq --- (selectField appLanguagesOpts) --- ("" & addAttr "multiple" "multiple" & addAttr "size" (tshow . min 10 $ length appLanguages) & addAutosubmit & addName ("lang" :: Text)) --- (Just lang) --- return ((,) <$> langBoxRes <*> urlRes, toWidget csrf <> fvInput urlView <> fvInput langBoxView) - -data MemcachedKeyFavourites - = MemcachedKeyFavouriteQuickActions CourseId AuthContext (NonEmpty Lang) - deriving (Eq, Read, Show, Generic, Typeable) - deriving anyclass (Hashable, Binary) - -data MemcachedLimitKeyFavourites - = MemcachedLimitKeyFavourites - deriving (Eq, Ord, Read, Show, Generic, Typeable) - deriving anyclass (Hashable, Binary) - - -updateFavourites :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) - => Maybe (TermId, SchoolId, CourseShorthand) -- ^ Insert course into favourites, as appropriate - -> ReaderT SqlBackend m () -updateFavourites cData = void . runMaybeT $ do - $logDebugS "updateFavourites" "Updating favourites" - - now <- liftIO $ getCurrentTime - uid <- MaybeT $ liftHandler maybeAuthId - mcid <- for cData $ \(tid, ssh, csh) -> MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - User{userMaxFavourites} <- MaybeT $ get uid - - -- update Favourites - for_ mcid $ \cid -> - void . lift $ upsertBy - (UniqueCourseFavourite uid cid) - (CourseFavourite uid cid FavouriteVisited now) - [CourseFavouriteLastVisit =. now] - -- prune Favourites to user-defined size - oldFavs <- lift $ selectList [CourseFavouriteUser ==. uid] [] - let deleteFavs = oldFavs - & sortOn ((courseFavouriteReason &&& Down . courseFavouriteLastVisit) . entityVal) - & drop userMaxFavourites - & filter ((<= FavouriteVisited) . courseFavouriteReason . entityVal) - & map entityKey - unless (null deleteFavs) $ - lift $ deleteWhere [CourseFavouriteId <-. deleteFavs] - - -siteLayoutMsg :: (RenderMessage site msg, site ~ UniWorX) => msg -> Widget -> Handler Html -siteLayoutMsg msg widget = do - mr <- getMessageRender - siteLayout (toWgt $ mr msg) widget - -siteLayoutMsg' :: (RenderMessage site msg, site ~ UniWorX) => msg -> Widget -> Handler Html -siteLayoutMsg' = siteLayout . i18nHeading - -siteLayout :: Widget -- ^ `pageHeading` - -> Widget -> Handler Html -siteLayout = siteLayout' . Just - -siteLayout' :: Maybe Widget -- ^ Optionally override `pageHeading` - -> Widget -> Handler Html -siteLayout' headingOverride widget = do - AppSettings { appUserDefaults = UserDefaultConf{..}, .. } <- getsYesod $ view appSettings - - isModal <- hasCustomHeader HeaderIsModal - - primaryLanguage <- unsafeHead . Text.splitOn "-" <$> selectLanguage appLanguages - - mcurrentRoute <- getCurrentRoute - let currentHandler = classifyHandler <$> mcurrentRoute - - currentApproot' <- siteApproot <$> getYesod <*> (reqWaiRequest <$> getRequest) - - -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance. - let - breadcrumbs' mcRoute = do - mr <- getMessageRender - case mcRoute of - Nothing -> return (mr MsgErrorResponseTitleNotFound, []) - Just cRoute -> do - (title, next) <- breadcrumb cRoute - crumbs <- go [] next - return (title, crumbs) - where - go crumbs Nothing = return crumbs - go crumbs (Just cRoute) = do - hasAccess <- hasReadAccessTo cRoute - (title, next) <- breadcrumb cRoute - go ((cRoute, title, hasAccess) : crumbs) next - (title, parents) <- breadcrumbs' mcurrentRoute - - -- let isParent :: Route UniWorX -> Bool - -- isParent r = r == (fst parents) - - isAuth <- isJust <$> maybeAuthId - - now <- liftIO getCurrentTime - - -- Lookup Favourites & Theme if possible - (favourites', maxFavouriteTerms, currentTheme) <- do - muid <- maybeAuthPair - - favCourses'' <- runDB . E.select . E.from $ \(course `E.LeftOuterJoin` courseFavourite) -> do - E.on $ E.just (course E.^. CourseId) E.==. courseFavourite E.?. CourseFavouriteCourse - E.&&. courseFavourite E.?. CourseFavouriteUser E.==. E.val (view _1 <$> muid) - - let isFavourite = E.not_ . E.isNothing $ courseFavourite E.?. CourseFavouriteId - isCurrent - | Just (CourseR tid ssh csh _) <- mcurrentRoute - = course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - | otherwise - = E.false - notBlacklist = E.not_ . E.exists . E.from $ \courseNoFavourite -> - E.where_ $ E.just (courseNoFavourite E.^. CourseNoFavouriteUser) E.==. E.val (view _1 <$> muid) - E.&&. courseNoFavourite E.^. CourseNoFavouriteCourse E.==. course E.^. CourseId - isParticipant = E.exists . E.from $ \participant -> - E.where_ $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId - E.&&. E.just (participant E.^. CourseParticipantUser) E.==. E.val (view _1 <$> muid) - E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive - isLecturer = E.exists . E.from $ \lecturer -> - E.where_ $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId - E.&&. E.just (lecturer E.^. LecturerUser) E.==. E.val (view _1 <$> muid) - isCorrector = E.exists . E.from $ \(corrector `E.InnerJoin` sheet) -> do - E.on $ corrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId - E.&&. sheet E.^. SheetCourse E.==. course E.^. CourseId - E.where_ $ E.just (corrector E.^. SheetCorrectorUser) E.==. E.val (view _1 <$> muid) - isTutor = E.exists . E.from $ \(tutor `E.InnerJoin` tutorial) -> do - E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId - E.&&. tutorial E.^. TutorialCourse E.==. course E.^. CourseId - E.where_ $ E.just (tutor E.^. TutorUser) E.==. E.val (view _1 <$> muid) - isAssociated = isParticipant E.||. isLecturer E.||. isCorrector E.||. isTutor - courseVisible = courseIsVisible now course Nothing - - reason = E.case_ - [ E.when_ isCurrent E.then_ . E.just $ E.val FavouriteCurrent - , E.when_ isAssociated E.then_ . E.just $ E.val FavouriteParticipant - ] (E.else_ $ courseFavourite E.?. CourseFavouriteReason) - - E.where_ $ ((isFavourite E.||. isAssociated) E.&&. notBlacklist) E.||. isCurrent - - return (course, reason, courseVisible) - - favCourses' <- forM favCourses'' $ \(course@(Entity _ Course{..}), reason, E.Value courseVisible) -> do - mayView <- hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CShowR - mayEdit <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR - return (course, reason, courseVisible, mayView, mayEdit) - - let favCourses = favCourses' & filter (\(_, _, _, mayView, _) -> mayView) - - return ( favCourses - , maybe userDefaultMaxFavouriteTerms userMaxFavouriteTerms $ view _2 <$> muid - , maybe userDefaultTheme userTheme $ view _2 <$> muid - ) - - let favouriteTerms :: [TermIdentifier] - favouriteTerms = take maxFavouriteTerms . Set.toDescList $ foldMap (\(Entity _ Course{..}, _, _, _, _) -> Set.singleton $ unTermKey courseTerm) favourites' - - favourites <- fmap catMaybes . forM favourites' $ \(Entity cId c@Course{..}, E.Value mFavourite, courseVisible, mayView, mayEdit) - -> let courseRoute = CourseR courseTerm courseSchool courseShorthand CShowR - favouriteReason = fromMaybe FavouriteCurrent mFavourite - in runMaybeT . guardOnM (unTermKey courseTerm `elem` favouriteTerms) . lift $ do - ctx <- getAuthContext - MsgRenderer mr <- getMsgRenderer - langs <- selectLanguages appLanguages <$> languages - let cK = MemcachedKeyFavouriteQuickActions cId ctx langs - $logDebugS "FavouriteQuickActions" $ tshow cK <> " Checking..." - items <- memcachedLimitedKeyTimeoutBy - MemcachedLimitKeyFavourites appFavouritesQuickActionsBurstsize appFavouritesQuickActionsAvgInverseRate 1 - (Right <$> appFavouritesQuickActionsCacheTTL) - appFavouritesQuickActionsTimeout - cK - cK - . observeFavouritesQuickActionsDuration $ do - $logDebugS "FavouriteQuickActions" $ tshow cK <> " Starting..." - items' <- pageQuickActions NavQuickViewFavourite courseRoute - items <- forM items' $ \n@NavLink{navLabel} -> (mr navLabel,) <$> toTextUrl n - $logDebugS "FavouriteQuickActions" $ tshow cK <> " Done." - return items - $logDebugS "FavouriteQuickActions" $ tshow cK <> " returning " <> tshow (is _Just items) - return (c, courseRoute, items, favouriteReason, courseVisible, mayView, mayEdit) - - nav'' <- mconcat <$> sequence - [ defaultLinks - , maybe (return []) pageActions mcurrentRoute - ] - nav' <- catMaybes <$> mapM (runMaybeT . navAccess) nav'' - nav <- forM nav' $ \n -> (n,,,) <$> newIdent <*> traverse toTextUrl (n ^? _navLink) <*> traverse (\nc -> (nc,, ) <$> newIdent <*> toTextUrl nc) (n ^. _navChildren) - - mmsgs <- if - | isModal -> return mempty - | otherwise -> do - applySystemMessages - authTagPivots <- fromMaybe Set.empty <$> takeSessionJson SessionInactiveAuthTags - forM_ authTagPivots $ - \authTag -> addMessageWidget Info $ msgModal [whamlet|_{MsgUnauthorizedDisabledTag authTag}|] (Left $ SomeRoute (AuthPredsR, catMaybes [(toPathPiece GetReferer, ) . toPathPiece <$> mcurrentRoute])) - getMessages - - -- (langFormView, langFormEnctype) <- generateFormPost $ identifyForm FIDLanguage langForm - -- let langFormView' = wrapForm langFormView def - -- { formAction = Just $ SomeRoute LangR - -- , formSubmit = FormAutoSubmit - -- , formEncoding = langFormEnctype - -- } - - let highlight :: HasRoute UniWorX url => url -> Bool - -- ^ highlight last route in breadcrumbs, favorites taking priority - highlight = (highR ==) . Just . urlRoute - where crumbs = mcons mcurrentRoute $ view _1 <$> reverse parents - navItems = map (view _2) favourites ++ toListOf (folded . typesUsing @NavChildren @NavLink . to urlRoute) nav - highR = find (`elem` navItems) . uncurry (++) $ partition (`elem` map (view _2) favourites) crumbs - highlightNav = (||) <$> navForceActive <*> highlight - favouriteTermReason :: TermIdentifier -> FavouriteReason -> [(Course, Route UniWorX, Maybe [(Text, Text)], FavouriteReason, Bool, Bool, Bool)] - favouriteTermReason tid favReason' = favourites - & filter (\(Course{..}, _, _, favReason, _, _, _) -> unTermKey courseTerm == tid && favReason == favReason') - & sortOn (\(Course{..}, _, _, _, _, _, _) -> courseName) - - -- We break up the default layout into two components: - -- default-layout is the contents of the body tag, and - -- default-layout-wrapper is the entire page. Since the final - -- value passed to hamletToRepHtml cannot be a widget, this allows - -- you to use normal widget features in default-layout. - - navWidget :: (Nav, Text, Maybe Text, [(NavLink, Text, Text)]) -> Widget - navWidget (n, navIdent, navRoute', navChildren') = case n of - NavHeader{ navLink = navLink@NavLink{..}, .. } - | NavTypeLink{..} <- navType - , navModal - -> customModal Modal - { modalTriggerId = Just navIdent - , modalId = Nothing - , modalTrigger = \(Just route) ident -> $(widgetFile "widgets/navbar/item") - , modalContent = Left $ SomeRoute navLink - } - | NavTypeLink{} <- navType - -> let route = navRoute' - ident = navIdent - in $(widgetFile "widgets/navbar/item") - NavPageActionPrimary{ navLink = navLink@NavLink{..}, .. } - -> let pWidget - | NavTypeLink{..} <- navType - , navModal - = customModal Modal - { modalTriggerId = Just navIdent - , modalId = Nothing - , modalTrigger = \(Just route) ident -> $(widgetFile "widgets/pageaction/primary") - , modalContent = Left $ SomeRoute navLink - } - | NavTypeLink{} <- navType - = let route = navRoute' - ident = navIdent - in $(widgetFile "widgets/pageaction/primary") - | otherwise - = error "not implemented" - sWidgets = navChildren' - & map (\(l, i, r) -> navWidget (NavPageActionSecondary l, i, Just r, [])) - in $(widgetFile "widgets/pageaction/primary-wrapper") - NavPageActionSecondary{ navLink = navLink@NavLink{..}, .. } - | NavTypeLink{..} <- navType - , navModal - -> customModal Modal - { modalTriggerId = Just navIdent - , modalId = Nothing - , modalTrigger = \(Just route) ident -> $(widgetFile "widgets/pageaction/secondary") - , modalContent = Left $ SomeRoute navLink - } - | NavTypeLink{} <- navType - -> let route = navRoute' - ident = navIdent - in $(widgetFile "widgets/pageaction/secondary") - NavHeaderContainer{..} -> $(widgetFile "widgets/navbar/container") - NavFooter{ navLink = navLink@NavLink{..} } - | NavTypeLink{..} <- navType - , not navModal - -> let route = navRoute' - ident = navIdent - in $(widgetFile "widgets/footer/link") - _other -> error "not implemented" - - navContainerItemWidget :: (Nav, Text, Maybe Text, [(NavLink, Text, Text)]) - -> (NavLink, Text, Text) - -> Widget - navContainerItemWidget (n, _navIdent, _navRoute', _navChildren') (iN@NavLink{..}, iNavIdent, iNavRoute) = case n of - NavHeaderContainer{} - | NavTypeLink{..} <- navType - , navModal - -> customModal Modal - { modalTriggerId = Just iNavIdent - , modalId = Nothing - , modalTrigger = \(Just route) ident -> $(widgetFile "widgets/navbar/navbar-container-item--link") - , modalContent = Left $ SomeRoute iN - } - | NavTypeLink{} <- navType - -> let route = iNavRoute - ident = iNavIdent - in $(widgetFile "widgets/navbar/navbar-container-item--link") - | NavTypeButton{..} <- navType -> do - csrfToken <- reqToken <$> getRequest - wrapForm $(widgetFile "widgets/navbar/navbar-container-item--button") def - { formMethod = navMethod - , formSubmit = FormNoSubmit - , formAction = Just $ SomeRoute iN - } - _other -> error "not implemented" - - navbar :: Widget - navbar = do - $(widgetFile "widgets/navbar/navbar") - forM_ (filter isNavHeaderContainer nav) $ \(_, containerIdent, _, _) -> - toWidget $(cassiusFile "templates/widgets/navbar/container-radio.cassius") - where isNavHeaderPrimary = has $ _1 . _navHeaderRole . only NavHeaderPrimary - isNavHeaderSecondary = has $ _1 . _navHeaderRole . only NavHeaderSecondary - asidenav :: Widget - asidenav = $(widgetFile "widgets/asidenav/asidenav") - where - logo = preEscapedToMarkup $ decodeUtf8 $(embedFile "assets/lmu/logo.svg") - footer :: Widget - footer = $(widgetFile "widgets/footer/footer") - where isNavFooter = has $ _1 . _NavFooter - alerts :: Widget - alerts = $(widgetFile "widgets/alerts/alerts") - contentHeadline :: Maybe Widget - contentHeadline = headingOverride <|> (pageHeading =<< mcurrentRoute) - breadcrumbsWgt :: Widget - breadcrumbsWgt = $(widgetFile "widgets/breadcrumbs/breadcrumbs") - pageaction :: Widget - pageaction = $(widgetFile "widgets/pageaction/pageaction") - -- functions to determine if there are page-actions (primary or secondary) - hasPageActions, hasSecondaryPageActions, hasPrimaryPageActions :: Bool - hasPageActions = hasPrimaryPageActions || hasSecondaryPageActions - hasSecondaryPageActions = has (folded . _1 . _NavPageActionSecondary) nav - hasPrimaryPageActions = has (folded . _1 . _NavPageActionPrimary ) nav - hasPrimarySubActions = has (folded . _1 . filtered (is _NavPageActionPrimary) . _navChildren . folded) nav - contentRibbon :: Maybe Widget - contentRibbon = fmap toWidget appRibbon - - isNavHeaderContainer = has $ _1 . _NavHeaderContainer - isPageActionPrimary = has $ _1 . _NavPageActionPrimary - isPageActionSecondary = has $ _1 . _NavPageActionSecondary - - MsgRenderer mr <- getMsgRenderer - let - -- See Utils.Frontend.I18n and files in messages/frontend for message definitions - frontendI18n = toJSON (mr :: FrontendMessage -> Text) - frontendDatetimeLocale <- toJSON <$> selectLanguage frontendDatetimeLocales - - pc <- widgetToPageContent $ do - webpackLinks_main StaticR - toWidget $(juliusFile "templates/i18n.julius") - whenIsJust currentApproot' $ \currentApproot -> - toWidget $(juliusFile "templates/approot.julius") - whenIsJust mcurrentRoute $ \currentRoute' -> do - currentRoute <- toTextUrl currentRoute' - toWidget $(juliusFile "templates/current-route.julius") - wellKnownHtmlLinks - - $(widgetFile "default-layout") - withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") - - -getSystemMessageState :: (MonadHandler m, HandlerSite m ~ UniWorX) => SystemMessageId -> m UserSystemMessageState -getSystemMessageState smId = liftHandler $ do - muid <- maybeAuthId - reqSt <- $cachedHere getSystemMessageStateRequest - dbSt <- $cachedHere $ maybe (return mempty) getDBSystemMessageState muid - let MergeHashMap smSt = reqSt <> dbSt - smSt' = MergeHashMap $ HashMap.filter (/= mempty) smSt - when (smSt' /= reqSt) $ - setRegisteredCookieJson CookieSystemMessageState - =<< ifoldMapM (\smId' v -> MergeHashMap <$> (HashMap.singleton <$> encrypt smId' <*> pure v :: Handler (HashMap CryptoUUIDSystemMessage _))) smSt' - - return . fromMaybe mempty $ HashMap.lookup smId smSt - where - getSystemMessageStateRequest = - (lookupRegisteredCookiesJson id CookieSystemMessageState :: Handler (MergeHashMap CryptoUUIDSystemMessage UserSystemMessageState)) - >>= ifoldMapM (\(cID :: CryptoUUIDSystemMessage) v -> MergeHashMap <$> (maybeT (return mempty) . catchMPlus (Proxy @CryptoIDError) $ HashMap.singleton <$> decrypt cID <*> pure v)) - getDBSystemMessageState uid = runDB . runConduit $ selectSource [ SystemMessageHiddenUser ==. uid ] [] .| C.foldMap foldSt - where foldSt (Entity _ SystemMessageHidden{..}) - = MergeHashMap . HashMap.singleton systemMessageHiddenMessage $ mempty { userSystemMessageHidden = Just systemMessageHiddenTime } - -applySystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX) => m () -applySystemMessages = liftHandler . maybeT_ . catchMPlus (Proxy @CryptoIDError) $ do - lift $ maybeAuthId >>= traverse_ syncSystemMessageHidden - - cRoute <- lift getCurrentRoute - guard $ cRoute /= Just NewsR - - lift . runDB . runConduit $ selectSource [] [Asc SystemMessageManualPriority] .| C.mapM_ applyMessage - where - syncSystemMessageHidden uid = runDB $ do - smSt <- lookupRegisteredCookiesJson id CookieSystemMessageState :: DB (MergeHashMap CryptoUUIDSystemMessage UserSystemMessageState) - iforM_ smSt $ \cID UserSystemMessageState{..} -> do - smId <- decrypt cID - whenIsJust userSystemMessageHidden $ \systemMessageHiddenTime -> void $ - upsert SystemMessageHidden - { systemMessageHiddenMessage = smId - , systemMessageHiddenUser = uid - , systemMessageHiddenTime - } - [ SystemMessageHiddenTime =. systemMessageHiddenTime ] - - when (maybe False (maybe (const True) (<=) userSystemMessageHidden) userSystemMessageUnhidden) $ do - deleteBy $ UniqueSystemMessageHidden uid smId - - modifyRegisteredCookieJson CookieSystemMessageState $ \(fold -> MergeHashMap hm) - -> fmap MergeHashMap . assertM' (/= mempty) $ - HashMap.update (\smSt' -> assertM' (/= mempty) $ smSt' { userSystemMessageHidden = Nothing, userSystemMessageUnhidden = Nothing }) cID hm - - applyMessage (Entity smId SystemMessage{..}) = maybeT_ $ do - guard $ not systemMessageNewsOnly - - cID <- encrypt smId - void . assertM (== Authorized) . lift $ evalAccessDB (MessageR cID) False - - now <- liftIO getCurrentTime - guard $ NTop systemMessageFrom <= NTop (Just now) - guard $ NTop (Just now) < NTop systemMessageTo - - UserSystemMessageState{..} <- lift $ getSystemMessageState smId - guard $ userSystemMessageShown <= Just systemMessageLastChanged - guard $ userSystemMessageHidden <= Just systemMessageLastUnhide - - (_, smTrans) <- MaybeT $ getSystemMessage appLanguages smId - let - (summary, content) = case smTrans of - Nothing -> (systemMessageSummary, systemMessageContent) - Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent) - case summary of - Just s -> - addMessageWidget systemMessageSeverity $ msgModal (toWidget s) (Left . SomeRoute $ MessageR cID) - Nothing -> addMessage systemMessageSeverity content - - tellRegisteredCookieJson CookieSystemMessageState . MergeHashMap $ - HashMap.singleton cID mempty{ userSystemMessageShown = Just now } - --- Define breadcrumbs. -i18nCrumb :: ( RenderMessage (HandlerSite m) msg, MonadHandler m ) - => msg - -> Maybe (Route (HandlerSite m)) - -> m (Text, Maybe (Route (HandlerSite m))) -i18nCrumb msg mbR = do - mr <- getMessageRender - return (mr msg, mbR) - --- `breadcrumb` _really_ needs to be total for _all_ routes --- --- Even if routes are POST only or don't usually use `siteLayout` they will if --- an error occurs. --- --- Keep in mind that Breadcrumbs are also shown by the 403-Handler, --- i.e. information might be leaked by not performing permission checks if the --- breadcrumb value depends on sensitive content (like an user's name). -instance YesodBreadcrumbs UniWorX where - breadcrumb (AuthR _) = i18nCrumb MsgMenuLogin $ Just NewsR - breadcrumb (StaticR _) = i18nCrumb MsgBreadcrumbStatic Nothing - breadcrumb (WellKnownR _) = i18nCrumb MsgBreadcrumbWellKnown Nothing - breadcrumb MetricsR = i18nCrumb MsgBreadcrumbMetrics Nothing - - breadcrumb NewsR = i18nCrumb MsgMenuNews Nothing - breadcrumb UsersR = i18nCrumb MsgMenuUsers $ Just AdminR - breadcrumb AdminUserAddR = i18nCrumb MsgMenuUserAdd $ Just UsersR - breadcrumb (AdminUserR cID) = maybeT (i18nCrumb MsgBreadcrumbUser $ Just UsersR) $ do - guardM . hasReadAccessTo $ AdminUserR cID - uid <- decrypt cID - User{..} <- MaybeT . runDB $ get uid - return (userDisplayName, Just UsersR) - breadcrumb (AdminUserDeleteR cID) = i18nCrumb MsgBreadcrumbUserDelete . Just $ AdminUserR cID - breadcrumb (AdminHijackUserR cID) = i18nCrumb MsgBreadcrumbUserHijack . Just $ AdminUserR cID - breadcrumb (UserNotificationR cID) = do - mayList <- hasReadAccessTo UsersR - if - | mayList - -> i18nCrumb MsgMenuUserNotifications . Just $ AdminUserR cID - | otherwise - -> i18nCrumb MsgMenuUserNotifications $ Just ProfileR - breadcrumb (UserPasswordR cID) = do - mayList <- hasReadAccessTo UsersR - if - | mayList - -> i18nCrumb MsgMenuUserPassword . Just $ AdminUserR cID - | otherwise - -> i18nCrumb MsgMenuUserPassword $ Just ProfileR - breadcrumb AdminNewFunctionaryInviteR = i18nCrumb MsgMenuLecturerInvite $ Just UsersR - breadcrumb AdminFunctionaryInviteR = i18nCrumb MsgBreadcrumbFunctionaryInvite Nothing - - breadcrumb AdminR = i18nCrumb MsgAdminHeading Nothing - breadcrumb AdminFeaturesR = i18nCrumb MsgAdminFeaturesHeading $ Just AdminR - breadcrumb AdminTestR = i18nCrumb MsgMenuAdminTest $ Just AdminR - breadcrumb AdminErrMsgR = i18nCrumb MsgMenuAdminErrMsg $ Just AdminR - breadcrumb AdminTokensR = i18nCrumb MsgMenuAdminTokens $ Just AdminR - breadcrumb AdminCrontabR = i18nCrumb MsgBreadcrumbAdminCrontab $ Just AdminR - - breadcrumb SchoolListR = i18nCrumb MsgMenuSchoolList $ Just AdminR - breadcrumb (SchoolR ssh SchoolEditR) = maybeT (i18nCrumb MsgBreadcrumbSchool $ Just SchoolListR) $ do - School{..} <- MaybeT . runDB $ get ssh - return (CI.original schoolName, Just SchoolListR) - breadcrumb SchoolNewR = i18nCrumb MsgMenuSchoolNew $ Just SchoolListR - - breadcrumb (ExamOfficeR EOExamsR) = i18nCrumb MsgMenuExamOfficeExams Nothing - breadcrumb (ExamOfficeR EOFieldsR) = i18nCrumb MsgMenuExamOfficeFields . Just $ ExamOfficeR EOExamsR - breadcrumb (ExamOfficeR EOUsersR) = i18nCrumb MsgMenuExamOfficeUsers . Just $ ExamOfficeR EOExamsR - breadcrumb (ExamOfficeR EOUsersInviteR) = i18nCrumb MsgBreadcrumbExamOfficeUserInvite Nothing - - breadcrumb InfoR = i18nCrumb MsgMenuInformation Nothing - breadcrumb InfoLecturerR = i18nCrumb MsgInfoLecturerTitle $ Just InfoR - breadcrumb LegalR = i18nCrumb MsgMenuLegal $ Just InfoR - breadcrumb InfoAllocationR = i18nCrumb MsgBreadcrumbAllocationInfo $ Just InfoR - breadcrumb VersionR = i18nCrumb MsgMenuVersion $ Just InfoR - breadcrumb FaqR = i18nCrumb MsgBreadcrumbFaq $ Just InfoR - - - breadcrumb HelpR = i18nCrumb MsgMenuHelp Nothing - - - breadcrumb HealthR = i18nCrumb MsgMenuHealth Nothing - breadcrumb InstanceR = i18nCrumb MsgMenuInstance Nothing - - breadcrumb ProfileR = i18nCrumb MsgBreadcrumbProfile Nothing - breadcrumb SetDisplayEmailR = i18nCrumb MsgUserDisplayEmail $ Just ProfileR - breadcrumb ProfileDataR = i18nCrumb MsgMenuProfileData $ Just ProfileR - breadcrumb AuthPredsR = i18nCrumb MsgMenuAuthPreds $ Just ProfileR - breadcrumb CsvOptionsR = i18nCrumb MsgCsvOptions $ Just ProfileR - breadcrumb LangR = i18nCrumb MsgMenuLanguage $ Just ProfileR - - breadcrumb StorageKeyR = i18nCrumb MsgBreadcrumbStorageKey Nothing - - breadcrumb TermShowR = i18nCrumb MsgMenuTermShow $ Just NewsR - breadcrumb TermCurrentR = i18nCrumb MsgMenuTermCurrent $ Just TermShowR - breadcrumb TermEditR = i18nCrumb MsgMenuTermCreate $ Just TermShowR - breadcrumb (TermEditExistR tid) = i18nCrumb MsgMenuTermEdit . Just $ TermCourseListR tid - breadcrumb (TermCourseListR tid) = maybeT (i18nCrumb MsgBreadcrumbTerm $ Just CourseListR) $ do -- redirect only, used in other breadcrumbs - guardM . lift . runDB $ isJust <$> get tid - i18nCrumb (ShortTermIdentifier $ unTermKey tid) $ Just CourseListR - - breadcrumb (TermSchoolCourseListR tid ssh) = maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ TermCourseListR tid) $ do -- redirect only, used in other breadcrumbs - guardM . lift . runDB $ - (&&) <$> fmap isJust (get ssh) - <*> fmap isJust (get tid) - return (CI.original $ unSchoolKey ssh, Just $ TermCourseListR tid) - - breadcrumb AllocationListR = i18nCrumb MsgAllocationListTitle $ Just NewsR - breadcrumb (AllocationR tid ssh ash sRoute) = case sRoute of - AShowR -> maybeT (i18nCrumb MsgBreadcrumbAllocation $ Just AllocationListR) $ do - mr <- getMessageRender - Entity _ Allocation{allocationName} <- MaybeT . runDB . getBy $ TermSchoolAllocationShort tid ssh ash - return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{CI.original (unSchoolKey ssh)})|], Just $ AllocationListR) - ARegisterR -> i18nCrumb MsgBreadcrumbAllocationRegister . Just $ AllocationR tid ssh ash AShowR - AApplyR cID -> maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ AllocationR tid ssh ash AShowR) $ do - cid <- decrypt cID - Course{..} <- hoist runDB $ do - aid <- MaybeT . getKeyBy $ TermSchoolAllocationShort tid ssh ash - guardM . lift $ exists [ AllocationCourseAllocation ==. aid, AllocationCourseCourse ==. cid ] - MaybeT $ get cid - return (CI.original courseName, Just $ AllocationR tid ssh ash AShowR) - AUsersR -> i18nCrumb MsgBreadcrumbAllocationUsers . Just $ AllocationR tid ssh ash AShowR - APriosR -> i18nCrumb MsgBreadcrumbAllocationPriorities . Just $ AllocationR tid ssh ash AUsersR - AComputeR -> i18nCrumb MsgBreadcrumbAllocationCompute . Just $ AllocationR tid ssh ash AUsersR - AAcceptR -> i18nCrumb MsgBreadcrumbAllocationAccept . Just $ AllocationR tid ssh ash AUsersR - - breadcrumb ParticipantsListR = i18nCrumb MsgBreadcrumbParticipantsList $ Just CourseListR - breadcrumb (ParticipantsR _ _) = i18nCrumb MsgBreadcrumbParticipants $ Just ParticipantsListR - breadcrumb ParticipantsIntersectR = i18nCrumb MsgMenuParticipantsIntersect $ Just ParticipantsListR - - breadcrumb CourseListR = i18nCrumb MsgMenuCourseList Nothing - breadcrumb CourseNewR = i18nCrumb MsgMenuCourseNew $ Just CourseListR - breadcrumb (CourseR tid ssh csh CShowR) = maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ TermSchoolCourseListR tid ssh) $ do - guardM . lift . runDB . existsBy $ TermSchoolCourseShort tid ssh csh - return (CI.original csh, Just $ TermSchoolCourseListR tid ssh) - breadcrumb (CourseR tid ssh csh CEditR) = i18nCrumb MsgMenuCourseEdit . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CUsersR) = i18nCrumb MsgMenuCourseMembers . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CAddUserR) = i18nCrumb MsgMenuCourseAddMembers . Just $ CourseR tid ssh csh CUsersR - breadcrumb (CourseR tid ssh csh CInviteR) = i18nCrumb MsgBreadcrumbCourseParticipantInvitation . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CExamOfficeR) = i18nCrumb MsgMenuCourseExamOffice . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh (CUserR cID)) = maybeT (i18nCrumb MsgBreadcrumbUser . Just $ CourseR tid ssh csh CUsersR) $ do - guardM . hasReadAccessTo . CourseR tid ssh csh $ CUserR cID - uid <- decrypt cID - User{userDisplayName} <- MaybeT . runDB $ get uid - return (userDisplayName, Just $ CourseR tid ssh csh CUsersR) - breadcrumb (CourseR tid ssh csh CCorrectionsR) = i18nCrumb MsgMenuSubmissions . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CAssignR) = i18nCrumb MsgMenuCorrectionsAssign . Just $ CourseR tid ssh csh CCorrectionsR - breadcrumb (CourseR tid ssh csh SheetListR) = i18nCrumb MsgMenuSheetList . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh SheetNewR ) = i18nCrumb MsgMenuSheetNew . Just $ CourseR tid ssh csh SheetListR - breadcrumb (CourseR tid ssh csh SheetCurrentR) = i18nCrumb MsgMenuSheetCurrent . Just $ CourseR tid ssh csh SheetListR - breadcrumb (CourseR tid ssh csh SheetOldUnassignedR) = i18nCrumb MsgMenuSheetOldUnassigned . Just $ CourseR tid ssh csh SheetListR - breadcrumb (CourseR tid ssh csh CCommR ) = i18nCrumb MsgMenuCourseCommunication . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CTutorialListR) = i18nCrumb MsgMenuTutorialList . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CTutorialNewR) = i18nCrumb MsgMenuTutorialNew . Just $ CourseR tid ssh csh CTutorialListR - breadcrumb (CourseR tid ssh csh CFavouriteR) = i18nCrumb MsgBreadcrumbCourseFavourite . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CRegisterR) = i18nCrumb MsgBreadcrumbCourseRegister . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CRegisterTemplateR) = i18nCrumb MsgBreadcrumbCourseRegisterTemplate . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CLecInviteR) = i18nCrumb MsgBreadcrumbLecturerInvite . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CDeleteR) = i18nCrumb MsgMenuCourseDelete . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CHiWisR) = i18nCrumb MsgBreadcrumbHiWis . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CNotesR) = i18nCrumb MsgBreadcrumbCourseNotes . Just $ CourseR tid ssh csh CShowR - - breadcrumb (CourseR tid ssh csh CNewsNewR) = i18nCrumb MsgMenuCourseNewsNew . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh (CourseNewsR cID sRoute)) = case sRoute of - CNShowR -> i18nCrumb MsgBreadcrumbCourseNews . Just $ CourseR tid ssh csh CShowR - CNEditR -> i18nCrumb MsgMenuCourseNewsEdit . Just $ CNewsR tid ssh csh cID CNShowR - CNDeleteR -> i18nCrumb MsgBreadcrumbCourseNewsDelete . Just $ CNewsR tid ssh csh cID CNShowR - CNArchiveR -> i18nCrumb MsgBreadcrumbCourseNewsArchive . Just $ CNewsR tid ssh csh cID CNShowR - CNFileR _ -> i18nCrumb MsgBreadcrumbCourseNewsFile . Just $ CNewsR tid ssh csh cID CNShowR - - breadcrumb (CourseR tid ssh csh CEventsNewR) = i18nCrumb MsgMenuCourseEventNew . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh (CourseEventR _cID sRoute)) = case sRoute of - CEvEditR -> i18nCrumb MsgMenuCourseEventEdit . Just $ CourseR tid ssh csh CShowR - CEvDeleteR -> i18nCrumb MsgBreadcrumbCourseEventDelete . Just $ CourseR tid ssh csh CShowR - - breadcrumb (CourseR tid ssh csh CExamListR) = i18nCrumb MsgMenuExamList . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CExamNewR) = i18nCrumb MsgMenuExamNew . Just $ CourseR tid ssh csh CExamListR - - breadcrumb (CourseR tid ssh csh CApplicationsR) = i18nCrumb MsgMenuCourseApplications . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh CAppsFilesR) = i18nCrumb MsgBreadcrumbCourseAppsFiles . Just $ CourseR tid ssh csh CApplicationsR - - breadcrumb (CourseR tid ssh csh (CourseApplicationR cID sRoute)) = case sRoute of - CAEditR -> maybeT (i18nCrumb MsgBreadcrumbApplicant . Just $ CourseR tid ssh csh CApplicationsR) $ do - guardM . hasReadAccessTo $ CApplicationR tid ssh csh cID CAEditR - appId <- decrypt cID - User{..} <- hoist runDB $ MaybeT (get appId) >>= MaybeT . get . courseApplicationUser - return (userDisplayName, Just $ CourseR tid ssh csh CApplicationsR) - CAFilesR -> i18nCrumb MsgBreadcrumbApplicationFiles . Just $ CApplicationR tid ssh csh cID CAEditR - - breadcrumb (CourseR tid ssh csh (ExamR examn sRoute)) = case sRoute of - EShowR -> maybeT (i18nCrumb MsgBreadcrumbExam . Just $ CourseR tid ssh csh CExamListR) $ do - guardM . hasReadAccessTo $ CExamR tid ssh csh examn EShowR - return (CI.original examn, Just $ CourseR tid ssh csh CExamListR) - EEditR -> i18nCrumb MsgMenuExamEdit . Just $ CExamR tid ssh csh examn EShowR - EUsersR -> i18nCrumb MsgMenuExamUsers . Just $ CExamR tid ssh csh examn EShowR - EAddUserR -> i18nCrumb MsgMenuExamAddMembers . Just $ CExamR tid ssh csh examn EUsersR - EGradesR -> i18nCrumb MsgMenuExamGrades . Just $ CExamR tid ssh csh examn EShowR - ECInviteR -> i18nCrumb MsgBreadcrumbExamCorrectorInvite . Just $ CExamR tid ssh csh examn EShowR - EInviteR -> i18nCrumb MsgBreadcrumbExamParticipantInvite . Just $ CExamR tid ssh csh examn EShowR - ERegisterR -> i18nCrumb MsgBreadcrumbExamRegister . Just $ CExamR tid ssh csh examn EShowR - ERegisterOccR _occn -> i18nCrumb MsgBreadcrumbExamRegister . Just $ CExamR tid ssh csh examn EShowR - EAutoOccurrenceR -> i18nCrumb MsgBreadcrumbExamAutoOccurrence . Just $ CExamR tid ssh csh examn EUsersR - ECorrectR -> i18nCrumb MsgMenuExamCorrect . Just $ CExamR tid ssh csh examn EShowR - - breadcrumb (CourseR tid ssh csh (TutorialR tutn sRoute)) = case sRoute of - TUsersR -> maybeT (i18nCrumb MsgBreadcrumbTutorial . Just $ CourseR tid ssh csh CTutorialListR) $ do - guardM . hasReadAccessTo $ CTutorialR tid ssh csh tutn TUsersR - return (CI.original tutn, Just $ CourseR tid ssh csh CTutorialListR) - TEditR -> i18nCrumb MsgMenuTutorialEdit . Just $ CTutorialR tid ssh csh tutn TUsersR - TDeleteR -> i18nCrumb MsgMenuTutorialDelete . Just $ CTutorialR tid ssh csh tutn TUsersR - TCommR -> i18nCrumb MsgMenuTutorialComm . Just $ CTutorialR tid ssh csh tutn TUsersR - TRegisterR -> i18nCrumb MsgBreadcrumbTutorialRegister . Just $ CourseR tid ssh csh CShowR - TInviteR -> i18nCrumb MsgBreadcrumbTutorInvite . Just $ CTutorialR tid ssh csh tutn TUsersR - - breadcrumb (CourseR tid ssh csh (SheetR shn sRoute)) = case sRoute of - SShowR -> maybeT (i18nCrumb MsgBreadcrumbSheet . Just $ CourseR tid ssh csh SheetListR) $ do - guardM . hasReadAccessTo $ CSheetR tid ssh csh shn SShowR - return (CI.original shn, Just $ CourseR tid ssh csh SheetListR) - SEditR -> i18nCrumb MsgMenuSheetEdit . Just $ CSheetR tid ssh csh shn SShowR - SDelR -> i18nCrumb MsgMenuSheetDelete . Just $ CSheetR tid ssh csh shn SShowR - SSubsR -> i18nCrumb MsgMenuSubmissions . Just $ CSheetR tid ssh csh shn SShowR - SAssignR -> i18nCrumb MsgMenuCorrectionsAssign . Just $ CSheetR tid ssh csh shn SSubsR - SubmissionNewR -> i18nCrumb MsgMenuSubmissionNew . Just $ CSheetR tid ssh csh shn SShowR - SubmissionOwnR -> i18nCrumb MsgMenuSubmissionOwn . Just $ CSheetR tid ssh csh shn SShowR - SubmissionR cid sRoute' -> case sRoute' of - SubShowR -> do - mayList <- hasReadAccessTo $ CSheetR tid ssh csh shn SSubsR - if - | mayList - -> i18nCrumb MsgBreadcrumbSubmission . Just $ CSheetR tid ssh csh shn SSubsR - | otherwise - -> i18nCrumb MsgBreadcrumbSubmission . Just $ CSheetR tid ssh csh shn SShowR - CorrectionR -> i18nCrumb MsgMenuCorrection . Just $ CSubmissionR tid ssh csh shn cid SubShowR - SubDelR -> i18nCrumb MsgMenuSubmissionDelete . Just $ CSubmissionR tid ssh csh shn cid SubShowR - SubAssignR -> i18nCrumb MsgCorrectorAssignTitle . Just $ CSubmissionR tid ssh csh shn cid SubShowR - SInviteR -> i18nCrumb MsgBreadcrumbSubmissionUserInvite . Just $ CSubmissionR tid ssh csh shn cid SubShowR - SubArchiveR sft -> i18nCrumb sft . Just $ CSubmissionR tid ssh csh shn cid SubShowR - SubDownloadR _ _ -> i18nCrumb MsgBreadcrumbSubmissionFile . Just $ CSubmissionR tid ssh csh shn cid SubShowR - SArchiveR -> i18nCrumb MsgBreadcrumbSheetArchive . Just $ CSheetR tid ssh csh shn SShowR - SIsCorrR -> i18nCrumb MsgBreadcrumbSheetIsCorrector . Just $ CSheetR tid ssh csh shn SShowR - SPseudonymR -> i18nCrumb MsgBreadcrumbSheetPseudonym . Just $ CSheetR tid ssh csh shn SShowR - SCorrInviteR -> i18nCrumb MsgBreadcrumbSheetCorrectorInvite . Just $ CSheetR tid ssh csh shn SShowR - SZipR sft -> i18nCrumb sft . Just $ CSheetR tid ssh csh shn SShowR - SFileR _ _ -> i18nCrumb MsgBreadcrumbSheetFile . Just $ CSheetR tid ssh csh shn SShowR - SPersonalFilesR -> i18nCrumb MsgBreadcrumbSheetPersonalisedFiles . Just $ CSheetR tid ssh csh shn SShowR - - breadcrumb (CourseR tid ssh csh MaterialListR) = i18nCrumb MsgMenuMaterialList . Just $ CourseR tid ssh csh CShowR - breadcrumb (CourseR tid ssh csh MaterialNewR ) = i18nCrumb MsgMenuMaterialNew . Just $ CourseR tid ssh csh MaterialListR - breadcrumb (CourseR tid ssh csh (MaterialR mnm sRoute)) = case sRoute of - MShowR -> maybeT (i18nCrumb MsgBreadcrumbMaterial . Just $ CourseR tid ssh csh MaterialListR) $ do - guardM . hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR - return (CI.original mnm, Just $ CourseR tid ssh csh MaterialListR) - MEditR -> i18nCrumb MsgMenuMaterialEdit . Just $ CMaterialR tid ssh csh mnm MShowR - MDelR -> i18nCrumb MsgMenuMaterialDelete . Just $ CMaterialR tid ssh csh mnm MShowR - MArchiveR -> i18nCrumb MsgBreadcrumbMaterialArchive . Just $ CMaterialR tid ssh csh mnm MShowR - MFileR _ -> i18nCrumb MsgBreadcrumbMaterialFile . Just $ CMaterialR tid ssh csh mnm MShowR - - breadcrumb (CourseR tid ssh csh CPersonalFilesR) = i18nCrumb MsgBreadcrumbCourseSheetPersonalisedFiles . Just $ CourseR tid ssh csh CShowR - - breadcrumb CorrectionsR = i18nCrumb MsgMenuCorrections Nothing - breadcrumb CorrectionsUploadR = i18nCrumb MsgMenuCorrectionsUpload $ Just CorrectionsR - breadcrumb CorrectionsCreateR = i18nCrumb MsgMenuCorrectionsCreate $ Just CorrectionsR - breadcrumb CorrectionsGradeR = i18nCrumb MsgMenuCorrectionsGrade $ Just CorrectionsR - breadcrumb CorrectionsDownloadR = i18nCrumb MsgMenuCorrectionsDownload $ Just CorrectionsR - - breadcrumb (CryptoUUIDDispatchR _) = i18nCrumb MsgBreadcrumbCryptoIDDispatch Nothing - - breadcrumb (MessageR _) = do - mayList <- (== Authorized) <$> evalAccess MessageListR False - if - | mayList -> i18nCrumb MsgBreadcrumbSystemMessage $ Just MessageListR - | otherwise -> i18nCrumb MsgBreadcrumbSystemMessage $ Just NewsR - breadcrumb MessageListR = i18nCrumb MsgMenuMessageList $ Just AdminR - breadcrumb (MessageHideR cID) = i18nCrumb MsgBreadcrumbMessageHide . Just $ MessageR cID - - breadcrumb GlossaryR = i18nCrumb MsgMenuGlossary $ Just InfoR - - breadcrumb EExamListR = i18nCrumb MsgMenuExternalExamList Nothing - breadcrumb EExamNewR = do - isEO <- hasReadAccessTo $ ExamOfficeR EOExamsR - i18nCrumb MsgBreadcrumbExternalExamNew . Just $ if - | isEO -> ExamOfficeR EOExamsR - | otherwise -> EExamListR - breadcrumb (EExamR tid ssh coursen examn sRoute) = case sRoute of - EEShowR -> do - isEO <- hasReadAccessTo $ ExamOfficeR EOExamsR - maybeT (i18nCrumb MsgBreadcrumbExternalExam . Just $ bool EExamListR (ExamOfficeR EOExamsR) isEO) $ do - guardM . hasReadAccessTo $ EExamR tid ssh coursen examn EEShowR - i18nCrumb (MsgBreadcrumbExternalExamShow coursen examn) . Just $ if - | isEO -> ExamOfficeR EOExamsR - | otherwise -> EExamListR - EEEditR -> i18nCrumb MsgBreadcrumbExternalExamEdit . Just $ EExamR tid ssh coursen examn EEShowR - EEUsersR -> i18nCrumb MsgBreadcrumbExternalExamUsers . Just $ EExamR tid ssh coursen examn EEShowR - EEGradesR -> i18nCrumb MsgBreadcrumbExternalExamGrades . Just $ EExamR tid ssh coursen examn EEShowR - EEStaffInviteR -> i18nCrumb MsgBreadcrumbExternalExamStaffInvite . Just $ EExamR tid ssh coursen examn EEShowR - EECorrectR -> i18nCrumb MsgBreadcrumbExternalExamCorrect . Just $ EExamR tid ssh coursen examn EEShowR - - -- breadcrumb _ = return ("Uni2work", Nothing) -- Default is no breadcrumb at all - -submissionList :: TermId -> CourseShorthand -> SheetName -> UserId -> DB [E.Value SubmissionId] -submissionList tid csh shn uid = E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do - E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId - E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId - E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId - - E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid - E.&&. sheet E.^. SheetName E.==. E.val shn - E.&&. course E.^. CourseShorthand E.==. E.val csh - E.&&. course E.^. CourseTerm E.==. E.val tid - - return $ submission E.^. SubmissionId - - - -defaultLinks :: (MonadHandler m, HandlerSite m ~ UniWorX) => m [Nav] -defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the header. - [ return NavHeader - { navHeaderRole = NavHeaderSecondary - , navIcon = IconMenuLogout - , navLink = NavLink - { navLabel = MsgMenuLogout - , navRoute = AuthR LogoutR - , navAccess' = is _Just <$> maybeAuthId - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - } - , return NavHeader - { navHeaderRole = NavHeaderSecondary - , navIcon = IconMenuLogin - , navLink = NavLink - { navLabel = MsgMenuLogin - , navRoute = AuthR LoginR - , navAccess' = is _Nothing <$> maybeAuthId - , navType = NavTypeLink { navModal = True } - , navQuick' = mempty - , navForceActive = False - } - } - , return NavHeader - { navHeaderRole = NavHeaderSecondary - , navIcon = IconMenuProfile - , navLink = NavLink - { navLabel = MsgMenuProfile - , navRoute = ProfileR - , navAccess' = is _Just <$> maybeAuthId - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - } - , do - mCurrentRoute <- getCurrentRoute - - activeLang <- selectLanguage appLanguages - - let navChildren = flip map (toList appLanguages) $ \lang -> NavLink - { navLabel = MsgLanguage lang - , navRoute = (LangR, [(toPathPiece GetReferer, toPathPiece currentRoute) | currentRoute <- hoistMaybe mCurrentRoute ]) - , navAccess' = return True - , navType = NavTypeButton - { navMethod = POST - , navData = [(toPathPiece PostLanguage, lang)] - } - , navQuick' = mempty - , navForceActive = lang == activeLang - } - - guard $ length navChildren > 1 - - return NavHeaderContainer - { navHeaderRole = NavHeaderSecondary - , navLabel = SomeMessage MsgMenuLanguage - , navIcon = IconLanguage - , navChildren - } - , do - mCurrentRoute <- getCurrentRoute - - return NavHeader - { navHeaderRole = NavHeaderSecondary - , navIcon = IconMenuHelp - , navLink = NavLink - { navLabel = MsgMenuHelp - , navRoute = (HelpR, [(toPathPiece GetReferer, toPathPiece currentRoute) | currentRoute <- hoistMaybe mCurrentRoute ]) - , navAccess' = return True - , navType = NavTypeLink { navModal = True } - , navQuick' = mempty - , navForceActive = False - } - } - , return $ NavFooter NavLink - { navLabel = MsgMenuDataProt - , navRoute = LegalR :#: ("data-protection" :: Text) - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , return $ NavFooter NavLink - { navLabel = MsgMenuTermsUse - , navRoute = LegalR :#: ("terms-of-use" :: Text) - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , return $ NavFooter NavLink - { navLabel = MsgMenuCopyright - , navRoute = LegalR :#: ("copyright" :: Text) - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , return $ NavFooter NavLink - { navLabel = MsgMenuImprint - , navRoute = LegalR :#: ("imprint" :: Text) - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , return $ NavFooter NavLink - { navLabel = MsgMenuInformation - , navRoute = InfoR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , return $ NavFooter NavLink - { navLabel = MsgMenuFaq - , navRoute = FaqR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , return $ NavFooter NavLink - { navLabel = MsgMenuGlossary - , navRoute = GlossaryR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , return NavHeader - { navHeaderRole = NavHeaderPrimary - , navIcon = IconMenuNews - , navLink = NavLink - { navLabel = MsgMenuNews - , navRoute = NewsR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - } - , return NavHeader - { navHeaderRole = NavHeaderPrimary - , navIcon = IconMenuCourseList - , navLink = NavLink - { navLabel = MsgMenuCourseList - , navRoute = CourseListR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - } - , return NavHeader - { navHeaderRole = NavHeaderPrimary - , navIcon = IconMenuCorrections - , navLink = NavLink - { navLabel = MsgMenuCorrections - , navRoute = CorrectionsR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - } - , return NavHeader - { navHeaderRole = NavHeaderPrimary - , navIcon = IconMenuExams - , navLink = NavLink - { navLabel = MsgMenuExamOfficeExams - , navRoute = ExamOfficeR EOExamsR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - } - , return NavHeaderContainer - { navHeaderRole = NavHeaderPrimary - , navLabel = SomeMessage MsgAdminHeading - , navIcon = IconMenuAdmin - , navChildren = - [ NavLink - { navLabel = MsgMenuUsers - , navRoute = UsersR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , NavLink - { navLabel = MsgMenuSchoolList - , navRoute = SchoolListR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , NavLink - { navLabel = MsgAdminFeaturesHeading - , navRoute = AdminFeaturesR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , NavLink - { navLabel = MsgMenuMessageList - , navRoute = MessageListR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , NavLink - { navLabel = MsgMenuAdminErrMsg - , navRoute = AdminErrMsgR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , NavLink - { navLabel = MsgMenuAdminTokens - , navRoute = AdminTokensR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , NavLink - { navLabel = MsgMenuAdminCrontab - , navRoute = AdminCrontabR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , NavLink - { navLabel = MsgMenuAdminTest - , navRoute = AdminTestR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - ] - } - , return NavHeaderContainer - { navHeaderRole = NavHeaderPrimary - , navLabel = SomeMessage (mempty :: Text) - , navIcon = IconMenuExtra - , navChildren = - [ NavLink - { navLabel = MsgMenuCourseNew - , navRoute = CourseNewR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , NavLink - { navLabel = MsgMenuExternalExamList - , navRoute = EExamListR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , NavLink - { navLabel = MsgMenuTermShow - , navRoute = TermShowR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , NavLink - { navLabel = MsgMenuAllocationList - , navRoute = AllocationListR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , NavLink - { navLabel = MsgInfoLecturerTitle - , navRoute = InfoLecturerR - , navAccess' = hasWriteAccessTo CourseNewR - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - ] - } - ] - - -pageActions :: ( MonadHandler m - , HandlerSite m ~ UniWorX - , MonadCatch m - ) - => Route UniWorX -> m [Nav] -pageActions NewsR = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuOpenCourses - , navRoute = (CourseListR, [("courses-openregistration", toPathPiece True)]) - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuOpenAllocations - , navRoute = (AllocationListR, [("allocations-active", toPathPiece True)]) - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - ] -pageActions (CourseR tid ssh csh CShowR) = do - materialListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh MaterialListR - tutorialListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh CTutorialListR - sheetListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh SheetListR - examListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh CExamListR - membersSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh CUsersR - - let examListBound :: Num a => a - examListBound = 4 -- guaranteed random; chosen by fair dice roll - examListExams <- liftHandler . runDB $ do - examNames <- E.select . E.from $ \(course `E.InnerJoin` exam) -> do - E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId - E.where_ $ course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - E.limit $ succ examListBound - return $ exam E.^. ExamName - return $ do - E.Value examn <- examNames - return NavLink - { navLabel = examn - , navRoute = CExamR tid ssh csh examn EShowR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = navQuick NavQuickViewFavourite - , navForceActive = False - } - let showExamList = length examListExams <= examListBound - - let - navMembers = NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuCourseMembers - , navRoute = CourseR tid ssh csh CUsersR - , navAccess' = - let courseWhere course = course <$ do - E.where_ $ course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - hasParticipants = E.selectExists . E.from $ \(course `E.InnerJoin` courseParticipant) -> do - E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse - E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive - void $ courseWhere course - mayRegister = hasWriteAccessTo $ CourseR tid ssh csh CAddUserR - in runDB $ mayRegister `or2M` hasParticipants - , navType = NavTypeLink { navModal = False } - , navQuick' = navQuick NavQuickViewFavourite - , navForceActive = False - } - , navChildren = membersSecondary - } - showMembers <- maybeT (return False) $ True <$ navAccess navMembers - - return $ - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuMaterialList - , navRoute = CourseR tid ssh csh MaterialListR - , navAccess' = - let lecturerAccess = hasWriteAccessTo $ CourseR tid ssh csh MaterialNewR -- Always show for lecturers to create new material - materialAccess mnm = hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR -- otherwise show only if the user can see at least one of the contents - existsVisible = do - matNames <- E.select . E.from $ \(course `E.InnerJoin` material) -> do - E.on $ course E.^. CourseId E.==. material E.^. MaterialCourse - E.where_ $ course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - return $ material E.^. MaterialName - anyM matNames (materialAccess . E.unValue) - in runDB $ lecturerAccess `or2M` existsVisible - , navType = NavTypeLink { navModal = False } - , navQuick' = navQuick NavQuickViewFavourite - , navForceActive = False - } - , navChildren = materialListSecondary - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuSheetList - , navRoute = CourseR tid ssh csh SheetListR - , navAccess' = - let lecturerAccess = hasWriteAccessTo $ CourseR tid ssh csh SheetNewR -- Always show for lecturers to create new sheets - sheetAccess shn = hasReadAccessTo $ CSheetR tid ssh csh shn SShowR -- othwerwise show only if the user can see at least one of the contents - existsVisible = do - sheetNames <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do - E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse - E.where_ $ course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - return $ sheet E.^. SheetName - anyM sheetNames $ sheetAccess . E.unValue - in runDB $ lecturerAccess `or2M` existsVisible - , navType = NavTypeLink { navModal = False } - , navQuick' = navQuick NavQuickViewFavourite - , navForceActive = False - } - , navChildren = sheetListSecondary - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuTutorialList - , navRoute = CourseR tid ssh csh CTutorialListR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = navQuick NavQuickViewFavourite - , navForceActive = False - } - , navChildren = tutorialListSecondary - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuExamList - , navRoute = CourseR tid ssh csh CExamListR - , navAccess' = - let lecturerAccess = hasWriteAccessTo $ CourseR tid ssh csh CExamNewR - examAccess examn = hasReadAccessTo $ CExamR tid ssh csh examn EShowR - existsVisible = do - examNames <- E.select . E.from $ \(course `E.InnerJoin` exam) -> do - E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse - E.where_ $ course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - return $ exam E.^. ExamName - anyM examNames $ examAccess . E.unValue - in runDB $ lecturerAccess `or2M` existsVisible - , navType = NavTypeLink { navModal = False } - , navQuick' = bool (navQuick NavQuickViewFavourite) mempty showExamList - , navForceActive = False - } - , navChildren = examListSecondary ++ guardOnM showExamList examListExams - } - , navMembers - ] ++ guardOnM (not showMembers) [ NavPageActionPrimary{ navLink, navChildren = [] } | navLink <- membersSecondary ] ++ - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuCourseCommunication - , navRoute = CourseR tid ssh csh CCommR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = navQuick NavQuickViewFavourite - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionSecondary - { navLink = NavLink - { navLabel = MsgMenuCourseExamOffice - , navRoute = CourseR tid ssh csh CExamOfficeR - , navAccess' = do - uid <- requireAuthId - runDB $ do - cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh - E.selectExists $ do - (_school, isForced) <- courseExamOfficeSchools (E.val uid) (E.val cid) - E.where_ $ E.not_ isForced - , navType = NavTypeLink { navModal = True } - , navQuick' = mempty - , navForceActive = False - } - } - , NavPageActionSecondary - { navLink = NavLink - { navLabel = MsgMenuCourseEdit - , navRoute = CourseR tid ssh csh CEditR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - } - , NavPageActionSecondary - { navLink = NavLink - { navLabel = MsgMenuCourseClone - , navRoute = ( CourseNewR - , [("tid", toPathPiece tid), ("ssh", toPathPiece ssh), ("csh", toPathPiece csh)] - ) - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - } - , NavPageActionSecondary - { navLink = NavLink - { navLabel = MsgMenuCourseDelete - , navRoute = CourseR tid ssh csh CDeleteR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - } - ] -pageActions (ExamOfficeR EOExamsR) = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuExamOfficeFields - , navRoute = ExamOfficeR EOFieldsR - , navAccess' = return True - , navType = NavTypeLink { navModal = True } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuExamOfficeUsers - , navRoute = ExamOfficeR EOUsersR - , navAccess' = return True - , navType = NavTypeLink { navModal = True } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - ] -pageActions SchoolListR = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuSchoolNew - , navRoute = SchoolNewR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - ] -pageActions UsersR = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuLecturerInvite - , navRoute = AdminNewFunctionaryInviteR - , navAccess' = return True - , navType = NavTypeLink { navModal = True } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuUserAdd - , navRoute = AdminUserAddR - , navAccess' = return True - , navType = NavTypeLink { navModal = True } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - ] -pageActions (AdminUserR cID) = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuUserNotifications - , navRoute = UserNotificationR cID - , navAccess' = return True - , navType = NavTypeLink { navModal = True } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuUserPassword - , navRoute = UserPasswordR cID - , navAccess' = do - uid <- decrypt cID - User{userAuthentication} <- runDB $ get404 uid - return $ is _AuthPWHash userAuthentication - , navType = NavTypeLink { navModal = True } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - ] -pageActions InfoR = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgInfoLecturerTitle - , navRoute = InfoLecturerR - , navAccess' = hasWriteAccessTo CourseNewR - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuLegal - , navRoute = LegalR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuFaq - , navRoute = FaqR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuGlossary - , navRoute = GlossaryR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - ] -pageActions VersionR = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgInfoLecturerTitle - , navRoute = InfoLecturerR - , navAccess' = hasWriteAccessTo CourseNewR - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuLegal - , navRoute = LegalR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuFaq - , navRoute = FaqR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuGlossary - , navRoute = GlossaryR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - ] -pageActions HealthR = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuInstance - , navRoute = InstanceR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - ] -pageActions InstanceR = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuHealth - , navRoute = HealthR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - ] -pageActions HelpR = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuFaq - , navRoute = FaqR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgInfoLecturerTitle - , navRoute = InfoLecturerR - , navAccess' = hasWriteAccessTo CourseNewR - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = do - (section, navLabel) <- - [ ("courses", MsgInfoLecturerCourses) - , ("exercises", MsgInfoLecturerExercises) - , ("tutorials", MsgInfoLecturerTutorials) - , ("exams", MsgInfoLecturerExams) - , ("allocations", MsgInfoLecturerAllocations) - ] :: [(Text, UniWorXMessage)] - return NavLink - { navLabel - , navRoute = InfoLecturerR :#: section - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuGlossary - , navRoute = GlossaryR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - ] -pageActions ProfileR = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuProfileData - , navRoute = ProfileDataR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuAuthPreds - , navRoute = AuthPredsR - , navAccess' = return True - , navType = NavTypeLink { navModal = True } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgCsvOptions - , navRoute = CsvOptionsR - , navAccess' = return True - , navType = NavTypeLink { navModal = True } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - ] -pageActions TermShowR = do - participantsSecondary <- pageQuickActions NavQuickViewPageActionSecondary ParticipantsListR - return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuTermCreate - , navRoute = TermEditR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuParticipantsList - , navRoute = ParticipantsListR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = participantsSecondary - } - ] -pageActions (AllocationR tid ssh ash AShowR) = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuAllocationInfo - , navRoute = InfoAllocationR - , navAccess' = return True - , navType = NavTypeLink { navModal = True } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuAllocationUsers - , navRoute = AllocationR tid ssh ash AUsersR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuAllocationCompute - , navRoute = AllocationR tid ssh ash AComputeR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - ] -pageActions (AllocationR tid ssh ash AUsersR) = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuAllocationPriorities - , navRoute = AllocationR tid ssh ash APriosR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuAllocationCompute - , navRoute = AllocationR tid ssh ash AComputeR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - ] -pageActions CourseListR = do - participantsSecondary <- pageQuickActions NavQuickViewPageActionSecondary ParticipantsListR - return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuCourseNew - , navRoute = CourseNewR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuAllocationList - , navRoute = AllocationListR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuParticipantsList - , navRoute = ParticipantsListR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = participantsSecondary - } - ] -pageActions CourseNewR = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgInfoLecturerTitle - , navRoute = InfoLecturerR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - ] -pageActions (CourseR tid ssh csh CCorrectionsR) = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuCorrectionsAssign - , navRoute = CourseR tid ssh csh CAssignR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuCorrectionsOwn - , navRoute = ( CorrectionsR - , [ ("corrections-term", toPathPiece tid) - , ("corrections-school", toPathPiece ssh) - , ("corrections-course", toPathPiece csh) - ] - ) - , navAccess' = do - muid <- maybeAuthId - case muid of - Nothing -> return False - (Just uid) -> do - ok <- runDB . E.selectExists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission) -> do - E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId - E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId - E.where_ $ submission E.^. SubmissionRatingBy E.==. E.just (E.val uid) - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - return ok - , navType = NavTypeLink { navModal = False } - , navQuick' = navQuick NavQuickViewPageActionSecondary - , navForceActive = False - } - , navChildren = [] - } - ] -pageActions (CourseR tid ssh csh SheetListR) = do - correctionsSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh CCorrectionsR - - let - navCorrections = NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuSubmissions - , navRoute = CourseR tid ssh csh CCorrectionsR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite - , navForceActive = False - } - , navChildren = correctionsSecondary - } - showCorrections <- maybeT (return False) $ True <$ navAccess navCorrections - - return $ - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuSheetCurrent - , navRoute = CourseR tid ssh csh SheetCurrentR - , navAccess' = - runDB . maybeT (return False) $ do - void . MaybeT $ sheetCurrent tid ssh csh - return True - , navType = NavTypeLink { navModal = False } - , navQuick' = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuSheetOldUnassigned - , navRoute = CourseR tid ssh csh SheetOldUnassignedR - , navAccess' = - runDB . maybeT (return False) $ do - void . MaybeT $ sheetOldUnassigned tid ssh csh - return True - , navType = NavTypeLink { navModal = False } - , navQuick' = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite - , navForceActive = False - } - , navChildren = [] - } - , navCorrections - ] ++ guardOnM (not showCorrections) [ NavPageActionPrimary{ navLink, navChildren = [] } | navLink <- correctionsSecondary ] ++ - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuSheetNew - , navRoute = CourseR tid ssh csh SheetNewR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite - , navForceActive = False - } - , navChildren = [] - } - ] -pageActions (CourseR tid ssh csh CUsersR) = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuCourseAddMembers - , navRoute = CourseR tid ssh csh CAddUserR - , navAccess' = return True - , navType = NavTypeLink { navModal = True } - , navQuick' = navQuick NavQuickViewPageActionSecondary - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuCourseApplications - , navRoute = CourseR tid ssh csh CApplicationsR - , navAccess' = - let courseWhere course = course <$ do - E.where_ $ course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - existsApplications = E.selectExists . E.from $ \(course `E.InnerJoin` courseApplication) -> do - E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse - void $ courseWhere course - courseApplications = fmap (any E.unValue) . E.select . E.from $ \course -> do - void $ courseWhere course - return $ course E.^. CourseApplicationsRequired - courseAllocation = E.selectExists . E.from $ \(course `E.InnerJoin` allocationCourse) -> do - E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse - void $ courseWhere course - in runDB $ courseAllocation `or2M` courseApplications `or2M` existsApplications - , navType = NavTypeLink { navModal = False } - , navQuick' = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite - , navForceActive = False - } - , navChildren = [] - } - ] -pageActions (CourseR tid ssh csh MaterialListR) = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuMaterialNew - , navRoute = CourseR tid ssh csh MaterialNewR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = navQuick NavQuickViewPageActionSecondary - , navForceActive = False - } - , navChildren = [] - } - ] -pageActions (CMaterialR tid ssh csh mnm MShowR) = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuMaterialEdit - , navRoute = CMaterialR tid ssh csh mnm MEditR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionSecondary - { navLink = NavLink - { navLabel = MsgMenuMaterialDelete - , navRoute = CMaterialR tid ssh csh mnm MDelR - , navAccess' = return True - , navType = NavTypeLink { navModal = True } - , navQuick' = mempty - , navForceActive = False - } - } - ] -pageActions (CourseR tid ssh csh CTutorialListR) = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuTutorialNew - , navRoute = CourseR tid ssh csh CTutorialNewR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = navQuick NavQuickViewPageActionSecondary - , navForceActive = False - } - , navChildren = [] - } - ] -pageActions (CTutorialR tid ssh csh tutn TEditR) = return - [ NavPageActionSecondary - { navLink = NavLink - { navLabel = MsgMenuTutorialDelete - , navRoute = CTutorialR tid ssh csh tutn TDeleteR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - } - ] -pageActions (CTutorialR tid ssh csh tutn TUsersR) = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuTutorialComm - , navRoute = CTutorialR tid ssh csh tutn TCommR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuTutorialEdit - , navRoute = CTutorialR tid ssh csh tutn TEditR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionSecondary - { navLink = NavLink - { navLabel = MsgMenuTutorialDelete - , navRoute = CTutorialR tid ssh csh tutn TDeleteR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - } - ] -pageActions (CourseR tid ssh csh CExamListR) = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuExamNew - , navRoute = CourseR tid ssh csh CExamNewR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = navQuick NavQuickViewPageActionSecondary - , navForceActive = False - } - , navChildren = [] - } - ] -pageActions (CExamR tid ssh csh examn EShowR) = do - usersSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CExamR tid ssh csh examn EUsersR - - return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuExamEdit - , navRoute = CExamR tid ssh csh examn EEditR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuExamUsers - , navRoute = CExamR tid ssh csh examn EUsersR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = usersSecondary - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuExamGrades - , navRoute = CExamR tid ssh csh examn EGradesR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuExamCorrect - , navRoute = CExamR tid ssh csh examn ECorrectR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - ] -pageActions (CExamR tid ssh csh examn ECorrectR) = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuExamUsers - , navRoute = CExamR tid ssh csh examn EUsersR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuExamGrades - , navRoute = CExamR tid ssh csh examn EGradesR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionSecondary - { navLink = NavLink - { navLabel = MsgMenuExamEdit - , navRoute = CExamR tid ssh csh examn EEditR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - } - ] -pageActions (CExamR tid ssh csh examn EUsersR) = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuExamAddMembers - , navRoute = CExamR tid ssh csh examn EAddUserR - , navAccess' = return True - , navType = NavTypeLink { navModal = True } - , navQuick' = navQuick NavQuickViewPageActionSecondary - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuExamGrades - , navRoute = CExamR tid ssh csh examn EGradesR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuExamCorrect - , navRoute = CExamR tid ssh csh examn ECorrectR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - ] -pageActions (CExamR tid ssh csh examn EGradesR) = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuExamUsers - , navRoute = CExamR tid ssh csh examn EUsersR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = navQuick NavQuickViewPageActionSecondary - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuExamCorrect - , navRoute = CExamR tid ssh csh examn ECorrectR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - ] -pageActions (CSheetR tid ssh csh shn SShowR) = do - subsSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CSheetR tid ssh csh shn SSubsR - let - navSubmissions = NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuSubmissions - , navRoute = CSheetR tid ssh csh shn SSubsR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = subsSecondary - } - showSubmissions <- maybeT (return False) $ True <$ navAccess navSubmissions - - return $ - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuSubmissionOwn - , navRoute = CSheetR tid ssh csh shn SubmissionOwnR - , navAccess' = - runDB . maybeT (return False) $ do - uid <- MaybeT $ liftHandler maybeAuthId - submissions <- lift $ submissionList tid csh shn uid - guard . not $ null submissions - return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , navSubmissions - ] ++ guardOnM (not showSubmissions) [ NavPageActionPrimary{ navLink, navChildren = [] } | navLink <- subsSecondary ] ++ - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuSheetPersonalisedFiles - , navRoute = CSheetR tid ssh csh shn SPersonalFilesR - , navAccess' = - let onlyPersonalised = fmap (maybe False $ not . E.unValue) . E.selectMaybe . E.from $ \(sheet `E.InnerJoin` course) -> do - E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId - E.where_$ sheet E.^. SheetName E.==. E.val shn - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - return $ sheet E.^. SheetAllowNonPersonalisedSubmission - hasPersonalised = E.selectExists . E.from $ \(sheet `E.InnerJoin` course `E.InnerJoin` personalisedSheetFile) -> do - E.on $ personalisedSheetFile E.^. PersonalisedSheetFileSheet E.==. sheet E.^. SheetId - E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId - E.where_$ sheet E.^. SheetName E.==. E.val shn - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - in runDB $ or2M onlyPersonalised hasPersonalised - , navType = NavTypeLink { navModal = True } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuSheetEdit - , navRoute = CSheetR tid ssh csh shn SEditR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionSecondary - { navLink = NavLink - { navLabel = MsgMenuSheetClone - , navRoute = (CourseR tid ssh csh SheetNewR, [("shn", toPathPiece shn)]) - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - } - , NavPageActionSecondary - { navLink = NavLink - { navLabel = MsgMenuSheetDelete - , navRoute = CSheetR tid ssh csh shn SDelR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - } - ] -pageActions (CSheetR tid ssh csh shn SSubsR) = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuSubmissionNew - , navRoute = CSheetR tid ssh csh shn SubmissionNewR - , navAccess' = - let submissionAccess = hasWriteAccessTo $ CSheetR tid ssh csh shn SSubsR - hasNoSubmission = maybeT (return False) $ do - uid <- MaybeT $ liftHandler maybeAuthId - submissions <- lift $ submissionList tid csh shn uid - guard $ null submissions - return True - in runDB $ hasNoSubmission `or2M` submissionAccess - , navType = NavTypeLink { navModal = True } - , navQuick' = navQuick NavQuickViewPageActionSecondary - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuCorrectionsOwn - , navRoute = ( CorrectionsR - , [ ("corrections-term", toPathPiece tid) - , ("corrections-school", toPathPiece ssh) - , ("corrections-course", toPathPiece csh) - , ("corrections-sheet", toPathPiece shn) - ] - ) - , navAccess' = (== Authorized) <$> evalAccessCorrector tid ssh csh - , navType = NavTypeLink { navModal = False } - , navQuick' = navQuick NavQuickViewPageActionSecondary - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuCorrectionsAssign - , navRoute = CSheetR tid ssh csh shn SAssignR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = navQuick NavQuickViewPageActionSecondary - , navForceActive = False - } - , navChildren = [] - } - ] -pageActions (CSubmissionR tid ssh csh shn cid SubShowR) = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuCorrection - , navRoute = CSubmissionR tid ssh csh shn cid CorrectionR - , navAccess' = hasWriteAccessTo $ CSubmissionR tid ssh csh shn cid CorrectionR - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgCorrectorAssignTitle - , navRoute = CSubmissionR tid ssh csh shn cid SubAssignR - , navAccess' = return True - , navType = NavTypeLink { navModal = True } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionSecondary - { navLink = NavLink - { navLabel = MsgMenuSubmissionDelete - , navRoute = CSubmissionR tid ssh csh shn cid SubDelR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - } - ] -pageActions (CSubmissionR tid ssh csh shn cid CorrectionR) = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgCorrectorAssignTitle - , navRoute = CSubmissionR tid ssh csh shn cid SubAssignR - , navAccess' = return True - , navType = NavTypeLink { navModal = True } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionSecondary - { navLink = NavLink - { navLabel = MsgMenuSubmissionDelete - , navRoute = CSubmissionR tid ssh csh shn cid SubDelR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - } - ] -pageActions (CourseR tid ssh csh CApplicationsR) = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuCourseApplicationsFiles - , navRoute = CourseR tid ssh csh CAppsFilesR - , navAccess' = - let appAccess (E.Value appId) = do - cID <- encrypt appId - hasReadAccessTo $ CApplicationR tid ssh csh cID CAFilesR - appSource = E.selectSource . E.from $ \(course `E.InnerJoin` courseApplication) -> do - E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse - E.where_ $ course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - E.where_ . E.exists . E.from $ \courseApplicationFile -> - E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. courseApplication E.^. CourseApplicationId - return $ courseApplication E.^. CourseApplicationId - in runDB . runConduit $ appSource .| anyMC appAccess - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuCourseMembers - , navRoute = CourseR tid ssh csh CUsersR - , navAccess' = - runDB $ do - cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh - exists [ CourseParticipantCourse ==. cid ] - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - ] -pageActions CorrectionsR = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuCorrectionsDownload - , navRoute = CorrectionsDownloadR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = navQuick NavQuickViewPageActionSecondary - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuCorrectionsUpload - , navRoute = CorrectionsUploadR - , navAccess' = return True - , navType = NavTypeLink { navModal = True } - , navQuick' = navQuick NavQuickViewPageActionSecondary - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuCorrectionsCreate - , navRoute = CorrectionsCreateR - , navAccess' = runDB . maybeT (return False) $ do - uid <- MaybeT $ liftHandler maybeAuthId - sheets <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do - E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse - let - isCorrector' = E.exists . E.from $ \sheetCorrector -> E.where_ - $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid - E.&&. sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId - isLecturer = E.exists . E.from $ \lecturer -> E.where_ - $ lecturer E.^. LecturerUser E.==. E.val uid - E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId - E.where_ $ isCorrector' E.||. isLecturer - return $ sheet E.^. SheetSubmissionMode - return $ orOf (traverse . _Value . _submissionModeCorrector) sheets - , navType = NavTypeLink { navModal = False } - , navQuick' = navQuick NavQuickViewPageActionSecondary - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuCorrectionsGrade - , navRoute = CorrectionsGradeR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - ] -pageActions CorrectionsGradeR = do - correctionsSecondary <- pageQuickActions NavQuickViewPageActionSecondary CorrectionsR - return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuCorrections - , navRoute = CorrectionsR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = correctionsSecondary - } - ] -pageActions EExamListR = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuExternalExamNew - , navRoute = EExamNewR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - ] -pageActions (EExamR tid ssh coursen examn EEShowR) = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuExternalExamEdit - , navRoute = EExamR tid ssh coursen examn EEEditR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuExternalExamUsers - , navRoute = EExamR tid ssh coursen examn EEUsersR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuExternalExamGrades - , navRoute = EExamR tid ssh coursen examn EEGradesR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuExternalExamCorrect - , navRoute = EExamR tid ssh coursen examn EECorrectR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - ] -pageActions (EExamR tid ssh coursen examn EEGradesR) = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuExternalExamCorrect - , navRoute = EExamR tid ssh coursen examn EECorrectR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuExternalExamUsers - , navRoute = EExamR tid ssh coursen examn EEUsersR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuExternalExamEdit - , navRoute = EExamR tid ssh coursen examn EEEditR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - ] -pageActions (EExamR tid ssh coursen examn EEUsersR) = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuExternalExamGrades - , navRoute = EExamR tid ssh coursen examn EEGradesR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuExternalExamCorrect - , navRoute = EExamR tid ssh coursen examn EECorrectR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuExternalExamEdit - , navRoute = EExamR tid ssh coursen examn EEEditR - , navAccess' = return True - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - ] -pageActions ParticipantsListR = return - [ NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgCsvOptions - , navRoute = CsvOptionsR - , navAccess' = return True - , navType = NavTypeLink { navModal = True } - , navQuick' = mempty - , navForceActive = False - } - , navChildren = [] - } - - , NavPageActionPrimary - { navLink = NavLink - { navLabel = MsgMenuParticipantsIntersect - , navRoute = ParticipantsIntersectR - , navAccess' = return True - , navType = NavTypeLink { navModal = False} - , navQuick' = navQuick NavQuickViewPageActionSecondary - , navForceActive = False - } - , navChildren = [] - } - ] -pageActions _ = return [] - -pageQuickActions :: ( MonadCatch m - , MonadHandler m - , HandlerSite m ~ UniWorX - ) - => NavQuickView -> Route UniWorX -> m [NavLink] -pageQuickActions qView route = do - items'' <- pageActions route - items' <- catMaybes <$> mapM (runMaybeT . navAccess) items'' - filterM navLinkAccess $ items' ^.. typesUsing @NavChildren @NavLink . filtered (getAny . ($ qView) . navQuick') - - -i18nHeading :: (MonadWidget m, RenderMessage site msg, HandlerSite m ~ site) => msg -> m () -i18nHeading msg = liftWidget $ toWidget =<< getMessageRender <*> pure msg - --- | only used in defaultLayout; better use siteLayout instead! -pageHeading :: Route UniWorX -> Maybe Widget -pageHeading (AuthR _) - = Just $ i18nHeading MsgLoginHeading -pageHeading NewsR - = Just $ i18nHeading MsgNewsHeading -pageHeading UsersR - = Just $ i18nHeading MsgUsers -pageHeading (AdminUserR _) - = Just $ i18nHeading MsgAdminUserHeading -pageHeading (AdminTestR) - = Just $ [whamlet|Internal Code Demonstration Page|] -pageHeading (AdminErrMsgR) - = Just $ i18nHeading MsgErrMsgHeading - -pageHeading (InfoR) - = Just $ i18nHeading MsgInfoHeading -pageHeading (LegalR) - = Just $ i18nHeading MsgLegalHeading -pageHeading (VersionR) - = Just $ i18nHeading MsgVersionHeading - -pageHeading (HelpR) - = Just $ i18nHeading MsgHelpRequest - -pageHeading ProfileR - = Just $ i18nHeading MsgProfileHeading -pageHeading ProfileDataR - = Just $ i18nHeading MsgProfileDataHeading - -pageHeading TermShowR - = Just $ i18nHeading MsgTermsHeading -pageHeading TermCurrentR - = Just $ i18nHeading MsgTermCurrent -pageHeading TermEditR - = Just $ i18nHeading MsgTermEditHeading -pageHeading (TermEditExistR tid) - = Just $ i18nHeading $ MsgTermEditTid tid -pageHeading (TermCourseListR tid) - = Just . i18nHeading . MsgTermCourseListHeading $ tid -pageHeading (TermSchoolCourseListR tid ssh) - = Just $ do - School{schoolName=school} <- handlerToWidget $ runDB $ get404 ssh - i18nHeading $ MsgTermSchoolCourseListHeading tid school - -pageHeading (CourseListR) - = Just $ i18nHeading $ MsgCourseListTitle -pageHeading CourseNewR - = Just $ i18nHeading MsgCourseNewHeading -pageHeading (CourseR tid ssh csh CShowR) - = Just $ do - Entity _ Course{..} <- handlerToWidget . runDB . getBy404 $ TermSchoolCourseShort tid ssh csh - toWidget courseName --- (CourseR tid csh CRegisterR) -- just for POST -pageHeading (CourseR tid ssh csh CEditR) - = Just $ i18nHeading $ MsgCourseEditHeading tid ssh csh -pageHeading (CourseR tid ssh csh CCorrectionsR) - = Just $ i18nHeading $ MsgSubmissionsCourse tid ssh csh -pageHeading (CourseR tid ssh csh SheetListR) - = Just $ i18nHeading $ MsgSheetList tid ssh csh -pageHeading (CourseR tid ssh csh SheetNewR) - = Just $ i18nHeading $ MsgSheetNewHeading tid ssh csh -pageHeading (CSheetR tid ssh csh shn SShowR) - = Just $ i18nHeading $ MsgSheetTitle tid ssh csh shn - -- = Just $ i18nHeading $ prependCourseTitle tid ssh csh $ SomeMessage shn -- TODO: for consistency use prependCourseTitle throughout ERROR: circularity -pageHeading (CSheetR tid ssh csh shn SEditR) - = Just $ i18nHeading $ MsgSheetEditHead tid ssh csh shn -pageHeading (CSheetR tid ssh csh shn SDelR) - = Just $ i18nHeading $ MsgSheetDelHead tid ssh csh shn -pageHeading (CSheetR _tid _ssh _csh shn SSubsR) - = Just $ i18nHeading $ MsgSubmissionsSheet shn -pageHeading (CSheetR tid ssh csh shn SubmissionNewR) - = Just $ i18nHeading $ MsgSubmissionEditHead tid ssh csh shn -pageHeading (CSheetR tid ssh csh shn SubmissionOwnR) - = Just $ i18nHeading $ MsgSubmissionEditHead tid ssh csh shn -pageHeading (CSubmissionR tid ssh csh shn _ SubShowR) -- TODO: Rethink this one! - = Just $ i18nHeading $ MsgSubmissionEditHead tid ssh csh shn --- (CSubmissionR tid csh shn cid SubArchiveR) -- just a download -pageHeading (CSubmissionR tid ssh csh shn cid CorrectionR) - = Just $ i18nHeading $ MsgCorrectionHead tid ssh csh shn cid --- (CSubmissionR tid csh shn cid SubDownloadR) -- just a download --- (CSheetR tid ssh csh shn SFileR) -- just for Downloads - -pageHeading CorrectionsR - = Just $ i18nHeading MsgCorrectionsTitle -pageHeading CorrectionsUploadR - = Just $ i18nHeading MsgCorrUpload -pageHeading CorrectionsCreateR - = Just $ i18nHeading MsgCorrCreate -pageHeading CorrectionsGradeR - = Just $ i18nHeading MsgCorrGrade -pageHeading (MessageR _) - = Just $ i18nHeading MsgSystemMessageHeading -pageHeading MessageListR - = Just $ i18nHeading MsgSystemMessageListHeading - --- TODO: add headings for more single course- and single term-pages -pageHeading _ - = Nothing - - -routeNormalizers :: [Route UniWorX -> WriterT Any DB (Route UniWorX)] -routeNormalizers = - [ normalizeRender - , ncSchool - , ncAllocation - , ncCourse - , ncSheet - , ncMaterial - , ncTutorial - , ncExam - , ncExternalExam - , verifySubmission - , verifyCourseApplication - , verifyCourseNews - ] - where - normalizeRender :: Route UniWorX -> WriterT Any DB (Route UniWorX) - normalizeRender route = route <$ do - YesodRequest{..} <- liftHandler getRequest - let original = (W.pathInfo reqWaiRequest, reqGetParams) - rendered = renderRoute route - if - | (isSuffixOf `on` fst) original rendered -> do -- FIXME: this breaks when subsite prefixes are dynamic - $logDebugS "normalizeRender" [st|#{tshow rendered} matches #{tshow original}|] - | otherwise -> do - $logDebugS "normalizeRender" [st|Redirecting because #{tshow rendered} does not match #{tshow original}|] - tell $ Any True - - maybeOrig :: (Route UniWorX -> MaybeT (WriterT Any DB) (Route UniWorX)) - -> Route UniWorX -> WriterT Any DB (Route UniWorX) - maybeOrig f route = maybeT (return route) $ f route - - caseChanged :: (Eq a, Show a) => CI a -> CI a -> MaybeT (WriterT Any DB) () - caseChanged a b - | ((/=) `on` CI.original) a b = do - $logDebugS "routeNormalizers" [st|#{tshow a} /= #{tshow b}|] - tell $ Any True - | otherwise = return () - - ncSchool = maybeOrig . typesUsing @RouteChildren @SchoolId $ \ssh -> $cachedHereBinary ssh $ do - let schoolShort :: SchoolShorthand - schoolShort = unSchoolKey ssh - Entity ssh' _ <- MaybeT . lift . getBy $ UniqueSchoolShorthand schoolShort - (caseChanged `on` unSchoolKey) ssh ssh' - return ssh' - ncAllocation = maybeOrig $ \route -> do - AllocationR tid ssh ash _ <- return route - Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . lift . getBy $ TermSchoolAllocationShort tid ssh ash - caseChanged ash allocationShorthand - return $ route & typesUsing @RouteChildren @AllocationShorthand . filtered (== ash) .~ allocationShorthand - ncCourse = maybeOrig $ \route -> do - CourseR tid ssh csh _ <- return route - Entity _ Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh - caseChanged csh courseShorthand - return $ route & typesUsing @RouteChildren @CourseShorthand . filtered (== csh) .~ courseShorthand - ncSheet = maybeOrig $ \route -> do - CSheetR tid ssh csh shn _ <- return route - Entity cid Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh - Entity _ Sheet{..} <- MaybeT . $cachedHereBinary (cid, shn) . lift . getBy $ CourseSheet cid shn - caseChanged shn sheetName - return $ route & typesUsing @RouteChildren @SheetName . filtered (== shn) .~ sheetName - ncMaterial = maybeOrig $ \route -> do - CMaterialR tid ssh csh mnm _ <- return route - Entity cid Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh - Entity _ Material{..} <- MaybeT . $cachedHereBinary (cid, mnm) . lift . getBy $ UniqueMaterial cid mnm - caseChanged mnm materialName - return $ route & typesUsing @RouteChildren @MaterialName . filtered (== mnm) .~ materialName - ncTutorial = maybeOrig $ \route -> do - CTutorialR tid ssh csh tutn _ <- return route - Entity cid Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh - Entity _ Tutorial{..} <- MaybeT . $cachedHereBinary (cid, tutn) . lift . getBy $ UniqueTutorial cid tutn - caseChanged tutn tutorialName - return $ route & typesUsing @RouteChildren @TutorialName . filtered (== tutn) .~ tutorialName - ncExam = maybeOrig $ \route -> do - CExamR tid ssh csh examn _ <- return route - Entity cid Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh - Entity _ Exam{..} <- MaybeT . $cachedHereBinary (cid, examn) . lift . getBy $ UniqueExam cid examn - caseChanged examn examName - return $ route & typesUsing @RouteChildren @ExamName . filtered (== examn) .~ examName - ncExternalExam = maybeOrig $ \route -> do - EExamR tid ssh coursen examn _ <- return route - Entity _ ExternalExam{..} <- MaybeT . $cachedHereBinary (tid, ssh, coursen, examn) . lift . getBy $ UniqueExternalExam tid ssh coursen examn - caseChanged coursen externalExamCourseName - caseChanged examn externalExamExamName - return $ route - & typesUsing @RouteChildren @CourseName . filtered (== coursen) .~ externalExamCourseName - & typesUsing @RouteChildren @ExamName . filtered (== examn) .~ externalExamExamName - verifySubmission = maybeOrig $ \route -> do - CSubmissionR _tid _ssh _csh _shn cID sr <- return route - sId <- $cachedHereBinary cID $ decrypt cID - Submission{submissionSheet} <- MaybeT . $cachedHereBinary cID . lift $ get sId - Sheet{sheetCourse, sheetName} <- MaybeT . $cachedHereBinary submissionSheet . lift $ get submissionSheet - Course{courseTerm, courseSchool, courseShorthand} <- MaybeT . $cachedHereBinary sheetCourse . lift $ get sheetCourse - let newRoute = CSubmissionR courseTerm courseSchool courseShorthand sheetName cID sr - tell . Any $ route /= newRoute - return newRoute - verifyCourseApplication = maybeOrig $ \route -> do - CApplicationR _tid _ssh _csh cID sr <- return route - aId <- decrypt cID - CourseApplication{courseApplicationCourse} <- lift . lift $ get404 aId - Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 courseApplicationCourse - let newRoute = CApplicationR courseTerm courseSchool courseShorthand cID sr - tell . Any $ route /= newRoute - return newRoute - verifyCourseNews = maybeOrig $ \route -> do - CNewsR _tid _ssh _csh cID sr <- return route - aId <- decrypt cID - CourseNews{courseNewsCourse} <- lift . lift $ get404 aId - Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 courseNewsCourse - let newRoute = CNewsR courseTerm courseSchool courseShorthand cID sr - tell . Any $ route /= newRoute - return newRoute - - -runSqlPoolRetry :: forall m a backend. - ( MonadUnliftIO m, BackendCompatible SqlBackend backend - , MonadLogger m, MonadMask m - ) - => ReaderT backend m a - -> Pool backend - -> m a -runSqlPoolRetry action pool = do - let policy = Retry.fullJitterBackoff 1e3 & Retry.limitRetriesByCumulativeDelay 10e6 - handlers = Retry.skipAsyncExceptions `snoc` Retry.logRetries suggestRetry logRetry - where suggestRetry :: IOException -> m Bool - suggestRetry ioExc = return $ - ioeGetErrorType ioExc == OtherError - && ioeGetLocation ioExc == "libpq" - logRetry :: forall e. - Exception e - => Bool -- ^ Will retry - -> e - -> Retry.RetryStatus - -> m () - logRetry shouldRetry@False err status = $logErrorS "runSqlPoolRetry" . pack $ Retry.defaultLogMsg shouldRetry err status - logRetry shouldRetry@True err status = $logWarnS "runSqlPoolRetry" . pack $ Retry.defaultLogMsg shouldRetry err status - - Retry.recovering policy handlers $ \Retry.RetryStatus{..} -> do - $logDebugS "runSqlPoolRetry" $ "rsIterNumber = " <> tshow rsIterNumber - runSqlPool action pool - -runDBRead :: ReaderT SqlReadBackend Handler a -> Handler a -runDBRead action = do - $logDebugS "YesodPersist" "runDBRead" - runSqlPoolRetry (withReaderT SqlReadBackend action) =<< appConnPool <$> getYesod - --- How to run database actions. -instance YesodPersist UniWorX where - type YesodPersistBackend UniWorX = SqlBackend - runDB action = do - -- stack <- liftIO currentCallStack - -- $logDebugS "YesodPersist" . unlines $ "runDB" : map pack stack - $logDebugS "YesodPersist" "runDB" - dryRun <- isDryRun - let action' - | dryRun = action <* transactionUndo - | otherwise = action - - runSqlPoolRetry action' =<< appConnPool <$> getYesod - -instance YesodPersistRunner UniWorX where - getDBRunner = do - (DBRunner{..}, cleanup) <- defaultGetDBRunner appConnPool - return . (, cleanup) $ DBRunner (\action -> do - dryRun <- isDryRun - let action' - | dryRun = action <* transactionUndo - | otherwise = action - $logDebugS "YesodPersist" "runDBRunner" - runDBRunner action' - ) - -data CampusUserConversionException - = CampusUserInvalidIdent - | CampusUserInvalidEmail - | CampusUserInvalidDisplayName - | CampusUserInvalidGivenName - | CampusUserInvalidSurname - | CampusUserInvalidTitle - | CampusUserInvalidMatriculation - | CampusUserInvalidSex - | CampusUserInvalidFeaturesOfStudy Text - | CampusUserInvalidAssociatedSchools Text - deriving (Eq, Ord, Read, Show, Generic, Typeable) - deriving anyclass (Exception) - -_upsertCampusUserMode :: Traversal' (Creds UniWorX) UpsertCampusUserMode -_upsertCampusUserMode mMode cs@Creds{..} - | credsPlugin == "dummy" = setMode <$> mMode (UpsertCampusUserDummy $ CI.mk credsIdent) - | credsPlugin `elem` others = setMode <$> mMode (UpsertCampusUserOther $ CI.mk credsIdent) - | otherwise = setMode <$> mMode UpsertCampusUser - where - setMode UpsertCampusUser - = cs{ credsPlugin = "LDAP" } - setMode (UpsertCampusUserDummy ident) - = cs{ credsPlugin = "dummy", credsIdent = CI.original ident } - setMode (UpsertCampusUserOther ident) - = cs{ credsPlugin = bool (NonEmpty.head others) credsPlugin (credsPlugin `elem` others), credsIdent = CI.original ident } - - others = "PWHash" :| [] - -upsertCampusUser :: UpsertCampusUserMode -> Ldap.AttrList [] -> DB (Entity User) -upsertCampusUser plugin ldapData = do - now <- liftIO getCurrentTime - UserDefaultConf{..} <- getsYesod $ view _appUserDefaults - - let - userIdent'' = fold [ v | (k, v) <- ldapData, k == ldapUserPrincipalName ] - userMatrikelnummer' = fold [ v | (k, v) <- ldapData, k == ldapUserMatriculation ] - userEmail' = fold $ do - k' <- toList ldapUserEmail - (k, v) <- ldapData - guard $ k' == k - return v - userDisplayName'' = fold [ v | (k, v) <- ldapData, k == ldapUserDisplayName ] - userFirstName' = fold [ v | (k, v) <- ldapData, k == ldapUserFirstName ] - userSurname' = fold [ v | (k, v) <- ldapData, k == ldapUserSurname ] - userTitle' = fold [ v | (k, v) <- ldapData, k == ldapUserTitle ] - userSex' = fold [ v | (k, v) <- ldapData, k == ldapSex ] - - userAuthentication - | is _UpsertCampusUserOther plugin - = error "PWHash should only work for users that are already known" - | otherwise = AuthLDAP - userLastAuthentication = now <$ guard (isn't _UpsertCampusUserDummy plugin) - - userIdent <- if - | [bs] <- userIdent'' - , Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs - , hasn't _upsertCampusUserIdent plugin || has (_upsertCampusUserIdent . only userIdent') plugin - -> return userIdent' - | Just userIdent' <- plugin ^? _upsertCampusUserIdent - -> return userIdent' - | otherwise - -> throwM CampusUserInvalidIdent - userEmail <- if - | userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') userEmail' - -> return $ CI.mk userEmail - | otherwise - -> throwM CampusUserInvalidEmail - userDisplayName' <- if - | [bs] <- userDisplayName'' - , Right userDisplayName' <- Text.decodeUtf8' bs - -> return userDisplayName' - | otherwise - -> throwM CampusUserInvalidDisplayName - userFirstName <- if - | [bs] <- userFirstName' - , Right userFirstName <- Text.decodeUtf8' bs - -> return userFirstName - | otherwise - -> throwM CampusUserInvalidGivenName - userSurname <- if - | [bs] <- userSurname' - , Right userSurname <- Text.decodeUtf8' bs - -> return userSurname - | otherwise - -> throwM CampusUserInvalidSurname - userTitle <- if - | all ByteString.null userTitle' - -> return Nothing - | [bs] <- userTitle' - , Right userTitle <- Text.decodeUtf8' bs - -> return $ Just userTitle - | otherwise - -> throwM CampusUserInvalidTitle - userMatrikelnummer <- if - | [bs] <- userMatrikelnummer' - , Right userMatrikelnummer <- Text.decodeUtf8' bs - -> return $ Just userMatrikelnummer - | [] <- userMatrikelnummer' - -> return Nothing - | otherwise - -> throwM CampusUserInvalidMatriculation - userSex <- if - | [bs] <- userSex' - , Right userSex'' <- Text.decodeUtf8' bs - , Just userSex''' <- readMay userSex'' - , Just userSex <- userSex''' ^? iso5218 - -> return $ Just userSex - | [] <- userSex' - -> return Nothing - | otherwise - -> throwM CampusUserInvalidSex - - let - newUser = User - { userMaxFavourites = userDefaultMaxFavourites - , userMaxFavouriteTerms = userDefaultMaxFavouriteTerms - , userTheme = userDefaultTheme - , userDateTimeFormat = userDefaultDateTimeFormat - , userDateFormat = userDefaultDateFormat - , userTimeFormat = userDefaultTimeFormat - , userDownloadFiles = userDefaultDownloadFiles - , userWarningDays = userDefaultWarningDays - , userShowSex = userDefaultShowSex - , userNotificationSettings = def - , userLanguages = Nothing - , userCsvOptions = def - , userTokensIssuedAfter = Nothing - , userCreated = now - , userLastLdapSynchronisation = Just now - , userDisplayName = userDisplayName' - , userDisplayEmail = userEmail - , .. - } - userUpdate = [ UserMatrikelnummer =. userMatrikelnummer - -- , UserDisplayName =. userDisplayName - , UserFirstName =. userFirstName - , UserSurname =. userSurname - , UserTitle =. userTitle - , UserEmail =. userEmail - , UserSex =. userSex - , UserLastLdapSynchronisation =. Just now - ] ++ - [ UserLastAuthentication =. Just now | isn't _UpsertCampusUserDummy plugin ] - - user@(Entity userId userRec) <- upsertBy (UniqueAuthentication userIdent) newUser userUpdate - unless (validDisplayName userTitle userFirstName userSurname $ userDisplayName userRec) $ - update userId [ UserDisplayName =. userDisplayName' ] - - let - userStudyFeatures = fmap concat . forM userStudyFeatures' $ parseStudyFeatures userId now - userStudyFeatures' = do - (k, v) <- ldapData - guard $ k == ldapUserStudyFeatures - v' <- v - Right str <- return $ Text.decodeUtf8' v' - return str - - termNames = nubBy ((==) `on` CI.mk) $ do - (k, v) <- ldapData - guard $ k == ldapUserFieldName - v' <- v - Right str <- return $ Text.decodeUtf8' v' - return str - - userSubTermsSemesters = forM userSubTermsSemesters' parseSubTermsSemester - userSubTermsSemesters' = do - (k, v) <- ldapData - guard $ k == ldapUserSubTermsSemester - v' <- v - Right str <- return $ Text.decodeUtf8' v' - return str - - fs' <- either (throwM . CampusUserInvalidFeaturesOfStudy . tshow) return userStudyFeatures - sts <- either (throwM . CampusUserInvalidFeaturesOfStudy . tshow) return userSubTermsSemesters - - let - studyTermCandidates = Set.fromList $ do - let sfKeys = unStudyTermsKey . studyFeaturesField <$> fs' - subTermsKeys = unStudyTermsKey . fst <$> sts - - (,) <$> sfKeys ++ subTermsKeys <*> termNames - - let - assimilateSubTerms :: [(StudyTermsId, Int)] -> [StudyFeatures] -> WriterT (Set (StudyTermsId, Maybe StudyTermsId)) DB [StudyFeatures] - assimilateSubTerms [] xs = return xs - assimilateSubTerms ((subterm, subSemester) : subterms) unusedFeats = do - standalone <- lift $ get subterm - case standalone of - _other - | (match : matches, unusedFeats') <- partition - (\StudyFeatures{..} -> subterm == studyFeaturesField - && subSemester == studyFeaturesSemester - ) unusedFeats - -> do - $logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}” and matching feature “#{tshow match}”|] - (:) match <$> assimilateSubTerms subterms (matches ++ unusedFeats') - | any ((== subterm) . studyFeaturesField) unusedFeats - -> do - $logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}” due to feature of matching field|] - assimilateSubTerms subterms unusedFeats - Just StudyTerms{..} - | Just defDegree <- studyTermsDefaultDegree - , Just defType <- studyTermsDefaultType - -> do - $logDebugS "Campus" [st|Applying default for standalone study term “#{tshow subterm}”|] - (:) (StudyFeatures userId defDegree subterm Nothing defType subSemester now True) <$> assimilateSubTerms subterms unusedFeats - Nothing - | [] <- unusedFeats -> do - $logDebugS "Campus" [st|Saw subterm “#{tshow subterm}” when no fos-terms remain|] - tell $ Set.singleton (subterm, Nothing) - assimilateSubTerms subterms [] - _other -> do - knownParents <- lift $ map (studySubTermsParent . entityVal) <$> selectList [ StudySubTermsChild ==. subterm ] [] - let matchingFeatures = case knownParents of - [] -> filter ((== subSemester) . studyFeaturesSemester) unusedFeats - ps -> filter (\StudyFeatures{studyFeaturesField, studyFeaturesSemester} -> any (== studyFeaturesField) ps && studyFeaturesSemester == subSemester) unusedFeats - when (null knownParents) . forM_ matchingFeatures $ \StudyFeatures{..} -> - tell $ Set.singleton (subterm, Just studyFeaturesField) - if - | not $ null knownParents -> do - $logDebugS "Campus" [st|Applying subterm “#{tshow subterm}” to #{tshow matchingFeatures}|] - let setSuperField sf = sf - & _studyFeaturesSuperField %~ (<|> Just (sf ^. _studyFeaturesField)) - & _studyFeaturesField .~ subterm - (++) (map setSuperField matchingFeatures) <$> assimilateSubTerms subterms (unusedFeats List.\\ matchingFeatures) - | otherwise -> do - $logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}”|] - assimilateSubTerms subterms unusedFeats - $logDebugS "Campus" [st|Terms for “#{userIdent}”: #{tshow (sts, fs')}|] - (fs, studyFieldParentCandidates) <- runWriterT $ assimilateSubTerms sts fs' - - let - studyTermCandidateIncidence - = fromMaybe (error "Could not convert studyTermCandidateIncidence-Hash to UUID") -- Should never happen - . UUID.fromByteString - . fromStrict - . (convert :: Digest (SHAKE128 128) -> ByteString) - . runConduitPure - $ sourceList ((toStrict . Binary.encode <$> Set.toList studyTermCandidates) ++ (toStrict . Binary.encode <$> Set.toList studyFieldParentCandidates)) .| sinkHash - - candidatesRecorded <- E.selectExists . E.from $ \(candidate `E.FullOuterJoin` parentCandidate `E.FullOuterJoin` standaloneCandidate) -> do - E.on $ candidate E.?. StudyTermNameCandidateIncidence E.==. standaloneCandidate E.?. StudyTermStandaloneCandidateIncidence - E.on $ candidate E.?. StudyTermNameCandidateIncidence E.==. parentCandidate E.?. StudySubTermParentCandidateIncidence - E.where_ $ candidate E.?. StudyTermNameCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence) - E.||. parentCandidate E.?. StudySubTermParentCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence) - E.||. standaloneCandidate E.?. StudyTermStandaloneCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence) - - unless candidatesRecorded $ do - let - studyTermCandidates' = do - (studyTermNameCandidateKey, studyTermNameCandidateName) <- Set.toList studyTermCandidates - let studyTermNameCandidateIncidence = studyTermCandidateIncidence - return StudyTermNameCandidate{..} - insertMany_ studyTermCandidates' - - let - studySubTermParentCandidates' = do - (StudyTermsKey' studySubTermParentCandidateKey, Just (StudyTermsKey' studySubTermParentCandidateParent)) <- Set.toList studyFieldParentCandidates - let studySubTermParentCandidateIncidence = studyTermCandidateIncidence - return StudySubTermParentCandidate{..} - insertMany_ studySubTermParentCandidates' - - let - studyTermStandaloneCandidates' = do - (StudyTermsKey' studyTermStandaloneCandidateKey, Nothing) <- Set.toList studyFieldParentCandidates - let studyTermStandaloneCandidateIncidence = studyTermCandidateIncidence - return StudyTermStandaloneCandidate{..} - insertMany_ studyTermStandaloneCandidates' - - E.updateWhere [StudyFeaturesUser ==. userId] [StudyFeaturesValid =. False] - forM_ fs $ \f@StudyFeatures{..} -> do - insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing - insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing Nothing Nothing - oldFs <- selectKeysList - ([ StudyFeaturesUser ==. studyFeaturesUser - , StudyFeaturesDegree ==. studyFeaturesDegree - , StudyFeaturesField ==. studyFeaturesField - , StudyFeaturesType ==. studyFeaturesType - , StudyFeaturesSemester ==. studyFeaturesSemester - ]) - [] - case oldFs of - [oldF] -> update oldF - [ StudyFeaturesUpdated =. now - , StudyFeaturesValid =. True - , StudyFeaturesField =. studyFeaturesField - , StudyFeaturesSuperField =. studyFeaturesSuperField - ] - _other -> void $ upsert f - [ StudyFeaturesUpdated =. now - , StudyFeaturesValid =. True - , StudyFeaturesSuperField =. studyFeaturesSuperField - ] - associateUserSchoolsByTerms userId - - let - userAssociatedSchools = fmap concat $ forM userAssociatedSchools' parseLdapSchools - userAssociatedSchools' = do - (k, v) <- ldapData - guard $ k == ldapUserSchoolAssociation - v' <- v - Right str <- return $ Text.decodeUtf8' v' - return str - - ss <- either (throwM . CampusUserInvalidAssociatedSchools . tshow) return userAssociatedSchools - - forM_ ss $ \frag -> void . runMaybeT $ do - let - exactMatch = MaybeT . getBy $ UniqueOrgUnit frag - infixMatch = (hoistMaybe . preview _head =<<) . lift . E.select . E.from $ \schoolLdap -> do - E.where_ $ E.val frag `E.isInfixOf` schoolLdap E.^. SchoolLdapOrgUnit - E.&&. E.not_ (E.isNothing $ schoolLdap E.^. SchoolLdapSchool) - return schoolLdap - Entity _ SchoolLdap{..} <- exactMatch <|> infixMatch - ssh <- hoistMaybe schoolLdapSchool - - lift . void $ insertUnique UserSchool - { userSchoolUser = userId - , userSchoolSchool = ssh - , userSchoolIsOptOut = False - } - - forM_ ss $ void . insertUnique . SchoolLdap Nothing - - return user - where - insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ()) - -associateUserSchoolsByTerms :: UserId -> DB () -associateUserSchoolsByTerms uid = do - sfs <- selectList [StudyFeaturesUser ==. uid] [] - - forM_ sfs $ \(Entity _ StudyFeatures{..}) -> do - schoolTerms <- selectList [SchoolTermsTerms ==. studyFeaturesField] [] - forM_ schoolTerms $ \(Entity _ SchoolTerms{..}) -> - void $ insertUnique UserSchool - { userSchoolUser = uid - , userSchoolSchool = schoolTermsSchool - , userSchoolIsOptOut = False - } - -updateUserLanguage :: Maybe Lang -> DB (Maybe Lang) -updateUserLanguage (Just lang) = do - unless (lang `elem` appLanguages) $ - invalidArgs ["Unsupported language"] - - muid <- maybeAuthId - for_ muid $ \uid -> do - langs <- languages - update uid [ UserLanguages =. Just (Languages $ lang : nub (filter ((&&) <$> (`elem` appLanguages) <*> (/= lang)) langs)) ] - setRegisteredCookie CookieLang lang - return $ Just lang -updateUserLanguage Nothing = runMaybeT $ do - uid <- MaybeT maybeAuthId - User{..} <- MaybeT $ get uid - setLangs <- toList . selectLanguages appLanguages <$> languages - highPrioSetLangs <- toList . selectLanguages appLanguages <$> highPrioRequestedLangs - let userLanguages' = toList . selectLanguages appLanguages <$> userLanguages ^? _Just . _Wrapped - lang <- case (userLanguages', setLangs, highPrioSetLangs) of - (_, _, hpl : _) - -> lift $ hpl <$ update uid [ UserLanguages =. Just (Languages highPrioSetLangs) ] - (Just (l : _), _, _) - -> return l - (Nothing, l : _, _) - -> lift $ l <$ update uid [ UserLanguages =. Just (Languages setLangs) ] - (Just [], l : _, _) - -> return l - (_, [], _) - -> mzero - setRegisteredCookie CookieLang lang - return lang - - -instance YesodAuth UniWorX where - type AuthId UniWorX = UserId - - -- Where to send a user after successful login - loginDest _ = NewsR - -- Where to send a user after logout - logoutDest _ = NewsR - -- Override the above two destinations when a Referer: header is present - redirectToReferer _ = True - - loginHandler = do - toParent <- getRouteToParent - liftHandler . defaultLayout $ do - plugins <- getsYesod authPlugins - $logDebugS "Auth" $ "Enabled plugins: " <> Text.intercalate ", " (map apName plugins) - - setTitleI MsgLoginTitle - $(widgetFile "login") - - authenticate creds@Creds{..} = liftHandler . runDB $ do - now <- liftIO getCurrentTime - - let - uAuth = UniqueAuthentication $ CI.mk credsIdent - upsertMode = creds ^? _upsertCampusUserMode - - isDummy = is (_Just . _UpsertCampusUserDummy) upsertMode - isOther = is (_Just . _UpsertCampusUserOther) upsertMode - - excRecovery res - | isDummy || isOther - = do - case res of - UserError err -> addMessageI Error err - ServerError err -> addMessage Error $ toHtml err - _other -> return () - acceptExisting - | otherwise - = return res - - excHandlers = - [ C.Handler $ \case - CampusUserNoResult -> do - $logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent - excRecovery . UserError $ IdentifierNotFound credsIdent - CampusUserAmbiguous -> do - $logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent - excRecovery . UserError $ IdentifierNotFound credsIdent - err -> do - $logErrorS "LDAP" $ tshow err - mr <- getMessageRender - excRecovery . ServerError $ mr MsgInternalLdapError - , C.Handler $ \(cExc :: CampusUserConversionException) -> do - $logErrorS "LDAP" $ tshow cExc - mr <- getMessageRender - excRecovery . ServerError $ mr cExc - ] - - acceptExisting = do - res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth - case res of - Authenticated uid - -> associateUserSchoolsByTerms uid - _other - -> return () - case res of - Authenticated uid - | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ] - _other -> return res - - $logDebugS "auth" $ tshow Creds{..} - UniWorX{ appSettings' = AppSettings{ appUserDefaults = UserDefaultConf{..}, ..}, .. } <- getYesod - - flip catches excHandlers $ case appLdapPool of - Just ldapPool - | Just upsertMode' <- upsertMode -> do - ldapData <- campusUser ldapPool campusUserFailoverMode Creds{..} - $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData - Authenticated . entityKey <$> upsertCampusUser upsertMode' ldapData - _other - -> acceptExisting - - authPlugins (UniWorX{ appSettings' = AppSettings{..}, appLdapPool }) = catMaybes - [ flip campusLogin campusUserFailoverMode <$> appLdapPool - , Just . hashLogin $ pwHashAlgorithm appAuthPWHash - , dummyLogin <$ guard appAuthDummyLogin - ] - - authHttpManager = getsYesod appHttpManager - - onLogin = liftHandler $ do - mlang <- runDB $ updateUserLanguage Nothing - app <- getYesod - let mr | Just lang <- mlang = renderMessage app . map (Text.intercalate "-") . reverse . inits $ Text.splitOn "-" lang - | otherwise = renderMessage app [] - addMessage Success . toHtml $ mr Auth.NowLoggedIn - - onErrorHtml dest msg = do - addMessage Error $ toHtml msg - redirect dest - - renderAuthMessage _ ls = case lang of - ("en" : _) -> Auth.englishMessage - _other -> Auth.germanMessage - where lang = Text.splitOn "-" $ selectLanguage' appLanguages ls - -campusUserFailoverMode :: FailoverMode -campusUserFailoverMode = FailoverUnlimited - -instance YesodAuthPersist UniWorX where - getAuthEntity = liftHandler . runDBRead . get - - -unsafeHandler :: UniWorX -> Handler a -> IO a -unsafeHandler f h = do - logger <- makeLogger f - Unsafe.fakeHandlerGetLogger (const logger) f h - - -instance YesodMail UniWorX where - defaultFromAddress = getsYesod $ view _appMailFrom - mailObjectIdDomain = getsYesod $ view _appMailObjectDomain - mailVerp = getsYesod $ view _appMailVerp - mailDateTZ = return appTZ - mailSmtp act = do - pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool - withResource pool act - mailT ctx mail = defMailT ctx $ do - void setMailObjectIdRandom - setDateCurrent - replaceMailHeader "Sender" . Just =<< getsYesod (view $ _appMailFrom . _addressEmail) - - (mRes, smtpData) <- listen mail - unless (view _MailSmtpDataSet smtpData) - setMailSmtpData - - return mRes - - -instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where - type MonadCryptoKey m = CryptoIDKey - cryptoIDKey f = getsYesod appCryptoIDKey >>= f - -instance {-# OVERLAPPING #-} (Monad m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadSecretBox m where - secretBoxKey = getsYesod appSecretBoxKey - --- Note: Some functionality previously present in the scaffolding has been --- moved to documentation in the Wiki. Following are some hopefully helpful --- links: --- --- https://github.com/yesodweb/yesod/wiki/Sending-email --- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain --- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding - - -embedRenderMessage ''UniWorX ''ButtonSubmit id - -embedRenderMessage ''UniWorX ''CampusUserConversionException id +import Foundation.Instances as Foundation (ButtonClass(..), unsafeHandler) +import Foundation.Authorization as Foundation +import Foundation.SiteLayout as Foundation +import Foundation.DB as Foundation +import Foundation.Navigation as Foundation (evalAccessCorrector) +import Foundation.Yesod.Middleware as Foundation (updateFavourites) diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs new file mode 100644 index 000000000..991224b2f --- /dev/null +++ b/src/Foundation/Authorization.hs @@ -0,0 +1,1475 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + +module Foundation.Authorization + ( evalAccess, evalAccessFor, evalAccessWith + , evalAccessDB, evalAccessForDB, evalAccessWithDB + , hasReadAccessTo, hasWriteAccessTo + , wouldHaveReadAccessTo, wouldHaveWriteAccessTo + , wouldHaveReadAccessToIff, wouldHaveWriteAccessToIff + , AuthContext(..), getAuthContext + , isDryRun + , maybeBearerToken, requireBearerToken + , requireCurrentBearerRestrictions, maybeCurrentBearerRestrictions + , BearerAuthSite + , routeAuthTags + , orAR, andAR, notAR, trueAR, falseAR + ) where + +import Import.NoFoundation + +import Foundation.Type +import Foundation.Routes +import Foundation.I18n + +import Foundation.DB + +import Handler.Utils.ExamOffice.Exam +import Handler.Utils.ExamOffice.ExternalExam +import Utils.Course (courseIsVisible) + +import qualified Data.Set as Set +import qualified Data.Aeson as JSON +import qualified Data.HashSet as HashSet +import qualified Data.Map as Map +import Data.Map ((!?)) +import qualified Data.Text as Text +import Data.List (findIndex) + +import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E + +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Writer.Class (MonadWriter(..)) +import Control.Monad.Memo.Class (MonadMemo(..), for4) + +import Data.Aeson.Lens hiding (_Value, key) + + +type BearerAuthSite site + = ( MonadCrypto (HandlerFor site) + , CryptoIDKey ~ MonadCryptoKey (HandlerFor site) + , MonadCrypto (ReaderT SqlBackend (HandlerFor site)) + , CryptoIDKey ~ MonadCryptoKey (ReaderT SqlBackend (HandlerFor site)) + , MonadCrypto (ExceptT AuthResult (HandlerFor site)) + , CryptoIDKey ~ MonadCryptoKey (ExceptT AuthResult (HandlerFor site)) + , MonadCrypto (MaybeT (HandlerFor site)) + , CryptoIDKey ~ MonadCryptoKey (MaybeT (HandlerFor site)) + , MonadCrypto (ExceptT AuthResult (ReaderT SqlReadBackend (HandlerFor site))) + , CryptoIDKey ~ MonadCryptoKey (ExceptT AuthResult (ReaderT SqlReadBackend (HandlerFor site))) + , MonadCrypto (ReaderT SqlReadBackend (HandlerFor site)) + , CryptoIDKey ~ MonadCryptoKey (ReaderT SqlReadBackend (HandlerFor site)) + , MonadCrypto (MaybeT (WriterT Any (ReaderT SqlReadBackend (HandlerFor site)))) + , CryptoIDKey ~ MonadCryptoKey (MaybeT (WriterT Any (ReaderT SqlReadBackend (HandlerFor site)))) + , MonadCrypto (MaybeT (ReaderT SqlReadBackend (HandlerFor site))) + , CryptoIDKey ~ MonadCryptoKey (MaybeT (ReaderT SqlReadBackend (HandlerFor site))) + , UserId ~ AuthId site, User ~ AuthEntity site + , YesodAuthPersist site + ) + + +-- Access Control +newtype InvalidAuthTag = InvalidAuthTag Text + deriving (Eq, Ord, Show, Read, Generic, Typeable) +instance Exception InvalidAuthTag + + +data AccessPredicate + = APPure (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Reader MsgRenderer AuthResult) + | APHandler (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX AuthResult) + | APDB (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT SqlReadBackend (HandlerFor UniWorX) AuthResult) + +class (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => MonadAP m where + evalAccessPred :: AccessPredicate -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult + +instance {-# INCOHERENT #-} (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => MonadAP m where + evalAccessPred aPred aid r w = liftHandler $ case aPred of + (APPure p) -> runReader (p aid r w) <$> getMsgRenderer + (APHandler p) -> p aid r w + (APDB p) -> runDBRead $ p aid r w + +instance (MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlReadBackend backend, BearerAuthSite UniWorX) => MonadAP (ReaderT backend m) where + evalAccessPred aPred aid r w = mapReaderT liftHandler . withReaderT (projectBackend @SqlReadBackend) $ case aPred of + (APPure p) -> lift $ runReader (p aid r w) <$> getMsgRenderer + (APHandler p) -> lift $ p aid r w + (APDB p) -> p aid r w + + +orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult +orAR _ Authorized _ = Authorized +orAR _ _ Authorized = Authorized +orAR _ AuthenticationRequired _ = AuthenticationRequired +orAR _ _ AuthenticationRequired = AuthenticationRequired +orAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedOr x y +-- and +andAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedAnd x y +andAR _ reason@(Unauthorized _) _ = reason +andAR _ _ reason@(Unauthorized _) = reason +andAR _ Authorized other = other +andAR _ AuthenticationRequired _ = AuthenticationRequired + +notAR :: RenderMessage UniWorX msg => MsgRenderer -> msg -> AuthResult -> AuthResult +notAR _ _ (Unauthorized _) = Authorized +notAR _ _ AuthenticationRequired = AuthenticationRequired +notAR mr msg Authorized = Unauthorized . render mr . MsgUnauthorizedNot $ render mr msg + +trueAR, falseAR :: MsgRendererS UniWorX -> AuthResult +trueAR = const Authorized +falseAR = Unauthorized . ($ MsgUnauthorized) . render + +trueAP, _falseAP :: AccessPredicate +trueAP = APPure . const . const . const $ trueAR <$> ask +_falseAP = APPure . const . const . const $ falseAR <$> ask -- included for completeness + + +data AuthContext = AuthContext + { authCtxAuth :: Maybe (AuthId UniWorX) + , authCtxBearer :: Maybe (BearerToken UniWorX) + , authActiveTags :: AuthTagActive + } deriving (Generic, Typeable) + +deriving instance Eq (AuthId UniWorX) => Eq AuthContext +deriving instance (Read (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Read AuthContext +deriving instance (Show (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Show AuthContext +deriving anyclass instance Hashable (AuthId UniWorX) => Hashable AuthContext +deriving anyclass instance (Binary (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Binary AuthContext + +getAuthContext :: forall m. + ( MonadHandler m, HandlerSite m ~ UniWorX + , BearerAuthSite UniWorX + ) + => m AuthContext +getAuthContext = liftHandler $ do + authCtx <- AuthContext + <$> maybeAuthId + <*> runMaybeT (exceptTMaybe askBearerUnsafe) + <*> (fromMaybe def <$> lookupSessionJson SessionActiveAuthTags) + + $logDebugS "getAuthContext" $ tshow authCtx + + return authCtx + +isDryRun :: forall m. + ( MonadHandler m, HandlerSite m ~ UniWorX + , BearerAuthSite UniWorX + ) + => m Bool +isDryRun = $cachedHere . liftHandler $ orM + [ hasGlobalPostParam PostDryRun + , hasGlobalGetParam GetDryRun + , and2M bearerDryRun bearerRequired + ] + where + bearerDryRun = has (_Just . _Object . ix "dry-run") <$> maybeCurrentBearerRestrictions @Value + bearerRequired = maybeT (return True) . catchIfMaybeT cPred . liftHandler $ do + mAuthId <- maybeAuthId + currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute + isWrite <- isWriteRequest currentRoute + + let noTokenAuth :: AuthDNF -> AuthDNF + noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar + + dnf <- either throwM return $ routeAuthTags currentRoute + guardAuthResult <=< fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth dnf) mAuthId currentRoute isWrite + + return False + + cPred err = any ($ err) + [ is $ _HCError . _PermissionDenied + , is $ _HCError . _NotAuthenticated + ] + + +askBearerUnsafe :: forall m. + ( MonadHandler m, HandlerSite m ~ UniWorX + , BearerAuthSite UniWorX + ) + => ExceptT AuthResult m (BearerToken UniWorX) +-- | This performs /no/ meaningful validation of the `BearerToken` +-- +-- Use `requireBearerToken` or `maybeBearerToken` instead +askBearerUnsafe = ExceptT . $cachedHere . liftHandler . runExceptT $ do + bearer <- maybeMExceptT (unauthorizedI MsgUnauthorizedNoToken) askBearer + catch (decodeBearer bearer) $ \case + BearerTokenExpired -> throwError =<< unauthorizedI MsgUnauthorizedTokenExpired + BearerTokenNotStarted -> throwError =<< unauthorizedI MsgUnauthorizedTokenNotStarted + other -> do + $logWarnS "AuthToken" $ tshow other + throwError =<< unauthorizedI MsgUnauthorizedTokenInvalid + +validateBearer :: BearerAuthSite UniWorX + => Maybe (AuthId UniWorX) + -> Route UniWorX + -> Bool -- ^ @isWrite@ + -> BearerToken UniWorX + -> ReaderT SqlReadBackend (HandlerFor UniWorX) AuthResult +validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo validateBearer' mAuthId' route' isWrite' token' + where + validateBearer' :: _ -> _ -> _ -> _ -> CachedMemoT (Maybe (AuthId UniWorX), Route UniWorX, Bool, BearerToken UniWorX) AuthResult (ReaderT SqlReadBackend (HandlerFor UniWorX)) AuthResult + validateBearer' mAuthId route isWrite BearerToken{..} = lift . exceptT return return $ do + guardMExceptT (maybe True (HashSet.member route) bearerRoutes) (unauthorizedI MsgUnauthorizedTokenInvalidRoute) + + bearerAuthority' <- flip foldMapM bearerAuthority $ \case + Left tVal + | JSON.Success groupName <- JSON.fromJSON tVal -> maybeT (throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityGroup) . hoist lift $ do + Entity _ UserGroupMember{..} <- MaybeT . getBy $ UniquePrimaryUserGroupMember groupName Active + return $ Set.singleton userGroupMemberUser + | otherwise -> throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityValue + Right uid -> return $ Set.singleton uid + + let + -- Prevent infinite loops + noTokenAuth :: AuthDNF -> AuthDNF + noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar + + guardMExceptT (not $ Set.null bearerAuthority') $ unauthorizedI MsgUnauthorizedTokenInvalidNoAuthority + + forM_ bearerAuthority' $ \uid -> do + User{userTokensIssuedAfter} <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthority) $ get uid + guardMExceptT (Just bearerIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired) + + authorityVal <- do + dnf <- either throwM return $ routeAuthTags route + fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth dnf) (Just uid) route isWrite + guardExceptT (is _Authorized authorityVal) authorityVal + + whenIsJust bearerAddAuth $ \addDNF -> do + $logDebugS "validateToken" $ tshow addDNF + additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth addDNF) mAuthId route isWrite + guardExceptT (is _Authorized additionalVal) additionalVal + + return Authorized + +maybeBearerToken :: ( MonadHandler m, HandlerSite m ~ UniWorX + , BearerAuthSite UniWorX + ) => m (Maybe (BearerToken UniWorX)) +maybeBearerToken = liftHandler . runMaybeT $ catchIfMaybeT cPred requireBearerToken + where + cPred err = any ($ err) + [ is $ _HCError . _PermissionDenied + , is $ _HCError . _NotAuthenticated + ] + +requireBearerToken :: ( MonadHandler m, HandlerSite m ~ UniWorX + , BearerAuthSite UniWorX + ) + => m (BearerToken UniWorX) +requireBearerToken = liftHandler $ do + bearer <- exceptT (guardAuthResult >=> error "askToken should not throw `Authorized`") return askBearerUnsafe + mAuthId <- maybeAuthId + currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute + isWrite <- isWriteRequest currentRoute + guardAuthResult <=< runDBRead $ validateBearer mAuthId currentRoute isWrite bearer + return bearer + +requireCurrentBearerRestrictions :: forall a m. + ( MonadHandler m, HandlerSite m ~ UniWorX + , FromJSON a, ToJSON a + , BearerAuthSite UniWorX + ) + => m (Maybe a) +requireCurrentBearerRestrictions = liftHandler . runMaybeT $ do + bearer <- requireBearerToken + route <- MaybeT getCurrentRoute + hoistMaybe $ bearer ^? _bearerRestrictionIx route + +maybeCurrentBearerRestrictions :: forall a m. + ( MonadHandler m, HandlerSite m ~ UniWorX + , FromJSON a, ToJSON a + , BearerAuthSite UniWorX + ) + => m (Maybe a) +maybeCurrentBearerRestrictions = liftHandler . runMaybeT $ do + bearer <- MaybeT maybeBearerToken + route <- MaybeT getCurrentRoute + hoistMaybe $ bearer ^? _bearerRestrictionIx route + +tagAccessPredicate :: BearerAuthSite UniWorX + => AuthTag -> AccessPredicate +tagAccessPredicate AuthFree = trueAP +tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of + -- Courses: access only to school admins + CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isAdmin <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` userAdmin) -> do + E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserFunctionSchool + E.where_ $ userAdmin E.^. UserFunctionUser E.==. E.val authId + E.&&. userAdmin E.^. UserFunctionFunction E.==. E.val SchoolAdmin + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin) + return Authorized + -- Allocations: access only to school admins + AllocationR tid ssh ash _ -> $cachedHereBinary (mAuthId, tid, ssh, ash) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isAdmin <- lift . E.selectExists . E.from $ \(allocation `E.InnerJoin` userAdmin) -> do + E.on $ allocation E.^. AllocationSchool E.==. userAdmin E.^. UserFunctionSchool + E.where_ $ userAdmin E.^. UserFunctionUser E.==. E.val authId + E.&&. userAdmin E.^. UserFunctionFunction E.==. E.val SchoolAdmin + E.&&. allocation E.^. AllocationTerm E.==. E.val tid + E.&&. allocation E.^. AllocationSchool E.==. E.val ssh + E.&&. allocation E.^. AllocationShorthand E.==. E.val ash + guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin) + return Authorized + -- Schools: access only to school admins + SchoolR ssh _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isAdmin <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin] + guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin) + return Authorized + -- other routes: access to any admin is granted here + _other -> $cachedHereBinary mAuthId . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + adrights <- lift $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin] [] + guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin) + return Authorized +tagAccessPredicate AuthExamOffice = APDB $ \mAuthId route _ -> case route of + CExamR tid ssh csh examn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, examn) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + hasUsers <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do + E.on $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId + E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId + + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.&&. exam E.^. ExamName E.==. E.val examn + + E.where_ $ examOfficeExamResultAuth (E.val authId) examResult + guardMExceptT hasUsers (unauthorizedI MsgUnauthorizedExamExamOffice) + return Authorized + EExamR tid ssh coursen examn _ -> $cachedHereBinary (mAuthId, tid, ssh, coursen, examn) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + hasUsers <- lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamResult) -> do + E.on $ eexam E.^. ExternalExamId E.==. eexamResult E.^. ExternalExamResultExam + + E.where_ $ eexam E.^. ExternalExamTerm E.==. E.val tid + E.&&. eexam E.^. ExternalExamSchool E.==. E.val ssh + E.&&. eexam E.^. ExternalExamCourseName E.==. E.val coursen + E.&&. eexam E.^. ExternalExamExamName E.==. E.val examn + + E.where_ $ examOfficeExternalExamResultAuth (E.val authId) eexamResult + guardMExceptT hasUsers $ unauthorizedI MsgUnauthorizedExternalExamExamOffice + return Authorized + CourseR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isExamOffice <- lift . existsBy $ UniqueUserFunction authId ssh SchoolExamOffice + guardMExceptT isExamOffice $ unauthorizedI MsgUnauthorizedExamExamOffice + return Authorized + _other -> $cachedHereBinary mAuthId . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isExamOffice <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolExamOffice] + guardMExceptT isExamOffice (unauthorizedI MsgUnauthorizedExamOffice) + return Authorized +tagAccessPredicate AuthEvaluation = APDB $ \mAuthId route _ -> case route of + ParticipantsR _ ssh -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolEvaluation + guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation + return Authorized + CourseR _ ssh _ _ -> $cachedHereBinary(mAuthId, ssh) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolEvaluation + guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation + return Authorized + _other -> $cachedHereBinary mAuthId . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolEvaluation] + guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation + return Authorized +tagAccessPredicate AuthAllocationAdmin = APDB $ \mAuthId route _ -> case route of + AllocationR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolAllocation + guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin + return Authorized + CourseR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolAllocation + guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin + return Authorized + _other -> $cachedHereBinary mAuthId . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAllocation] + guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin + return Authorized +tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $ + lift . validateBearer mAuthId route isWrite =<< askBearerUnsafe +tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of + AdminHijackUserR cID -> $cachedHereBinary (mAuthId, cID) . exceptT return return $ do + myUid <- maybeExceptT AuthenticationRequired $ return mAuthId + uid <- decrypt cID + otherSchoolsFunctions <- lift . $cachedHereBinary uid $ Set.fromList . map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid] [] + mySchools <- lift . $cachedHereBinary myUid $ Set.fromList . map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. myUid, UserFunctionFunction ==. SchoolAdmin] [] + guardMExceptT (otherSchoolsFunctions `Set.isSubsetOf` mySchools) (unauthorizedI MsgUnauthorizedAdminEscalation) + return Authorized + r -> $unsupportedAuthPredicate AuthNoEscalation r +tagAccessPredicate AuthDeprecated = APHandler $ \_ r _ -> do + $logWarnS "AccessControl" ("deprecated route: " <> tshow r) + addMessageI Error MsgDeprecatedRoute + allow <- getsYesod $ view _appAllowDeprecated + return $ bool (Unauthorized "Deprecated Route") Authorized allow +tagAccessPredicate AuthDevelopment = APHandler $ \_ r _ -> do + $logWarnS "AccessControl" ("route in development: " <> tshow r) +#ifdef DEVELOPMENT + return Authorized +#else + return $ Unauthorized "Route under development" +#endif +tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of + CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isLecturer <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` lecturer) -> do + E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse + E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + guardMExceptT isLecturer (unauthorizedI MsgUnauthorizedLecturer) + return Authorized + AllocationR tid ssh ash _ -> $cachedHereBinary (mAuthId, tid, ssh, ash) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isLecturer <- lift . E.selectExists . E.from $ \(allocation `E.InnerJoin` allocationCourse `E.InnerJoin` course `E.InnerJoin` lecturer) -> do + E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse + E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse + E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation + E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId + E.&&. allocation E.^. AllocationTerm E.==. E.val tid + E.&&. allocation E.^. AllocationSchool E.==. E.val ssh + E.&&. allocation E.^. AllocationShorthand E.==. E.val ash + guardMExceptT isLecturer $ unauthorizedI MsgUnauthorizedAllocationLecturer + return Authorized + EExamR tid ssh coursen examn _ -> $cachedHereBinary (mAuthId, tid, ssh, coursen, examn) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isLecturer <- lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` staff) -> do + E.on $ eexam E.^. ExternalExamId E.==. staff E.^. ExternalExamStaffExam + E.where_ $ staff E.^. ExternalExamStaffUser E.==. E.val authId + E.&&. eexam E.^. ExternalExamTerm E.==. E.val tid + E.&&. eexam E.^. ExternalExamSchool E.==. E.val ssh + E.&&. eexam E.^. ExternalExamCourseName E.==. E.val coursen + E.&&. eexam E.^. ExternalExamExamName E.==. E.val examn + guardMExceptT isLecturer $ unauthorizedI MsgUnauthorizedExternalExamLecturer + return Authorized + -- lecturer for any school will do + _ -> $cachedHereBinary mAuthId . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolLecturer] [] + return Authorized +tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + resList <- $cachedHereBinary mAuthId . lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do + E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId + E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId + E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val authId + return (course E.^. CourseId, sheet E.^. SheetId) + let + resMap :: Map CourseId (Set SheetId) + resMap = Map.fromListWith Set.union [ (cid, Set.singleton sid) | (E.Value cid, E.Value sid) <- resList ] + case route of + CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary (mAuthId, cID) . maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do + sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID + Submission{..} <- MaybeT . lift $ get sid + guard $ Just authId == submissionRatingBy + return Authorized + CSheetR tid ssh csh shn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do + Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh + Entity sid _ <- MaybeT . lift . getBy $ CourseSheet cid shn + guard $ sid `Set.member` fromMaybe Set.empty (resMap !? cid) + return Authorized + CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do + Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh + guard $ cid `Set.member` Map.keysSet resMap + return Authorized + _ -> do + guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny) + return Authorized +tagAccessPredicate AuthExamCorrector = APDB $ \mAuthId route _ -> case route of + CExamR tid ssh csh examn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, examn) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isCorrector <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do + E.on $ examCorrector E.^. ExamCorrectorExam E.==. exam E.^. ExamId + E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId + E.where_ $ examCorrector E.^. ExamCorrectorUser E.==. E.val authId + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.&&. exam E.^. ExamName E.==. E.val examn + guardMExceptT isCorrector $ unauthorizedI MsgUnauthorizedExamCorrector + return Authorized + CourseR tid ssh csh _ -> $cachedHereBinary (tid, ssh, csh) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isCorrector <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do + E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse + E.on $ exam E.^. ExamId E.==. examCorrector E.^. ExamCorrectorExam + E.where_ $ examCorrector E.^. ExamCorrectorUser E.==. E.val authId + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + guardMExceptT isCorrector $ unauthorizedI MsgUnauthorizedExamCorrector + return Authorized + r -> $unsupportedAuthPredicate AuthExamCorrector r +tagAccessPredicate AuthTutor = APDB $ \mAuthId route _ -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + resList <- $cachedHereBinary authId . lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do + E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId + E.on $ tutorial E.^. TutorialCourse E.==. course E.^. CourseId + E.where_ $ tutor E.^. TutorUser E.==. E.val authId + return (course E.^. CourseId, tutorial E.^. TutorialId) + let + resMap :: Map CourseId (Set TutorialId) + resMap = Map.fromListWith Set.union [ (cid, Set.singleton tutid) | (E.Value cid, E.Value tutid) <- resList ] + case route of + CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialTutor) $ do + Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh + Entity tutid _ <- $cachedHereBinary (cid, tutn) . MaybeT . lift . getBy $ UniqueTutorial cid tutn + guard $ tutid `Set.member` fromMaybe Set.empty (resMap !? cid) + return Authorized + CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedCourseTutor) $ do + Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh + guard $ cid `Set.member` Map.keysSet resMap + return Authorized + _ -> do + guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedTutor) + return Authorized +tagAccessPredicate AuthTutorControl = APDB $ \_ route _ -> case route of + CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialTutorControl) $ do + Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh + Entity _ Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn + guard tutorialTutorControlled + return Authorized + r -> $unsupportedAuthPredicate AuthTutorControl r +tagAccessPredicate AuthSubmissionGroup = APDB $ \mAuthId route _ -> case route of + CSubmissionR tid ssh csh shn cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionSubmissionGroup) $ do + course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + Entity _ Sheet{..} <- $cachedHereBinary (course, shn) . MaybeT . getBy $ CourseSheet course shn + smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID + groups <- $cachedHereBinary cID . lift . fmap (Set.fromList . fmap E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionUser) -> do + E.on $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. submissionUser E.^. SubmissionUserUser + E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val smId + return $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup + unless (Set.null groups || isn't _RegisteredGroups sheetGrouping) $ do + uid <- hoistMaybe mAuthId + guardM . lift $ exists [SubmissionGroupUserUser ==. uid, SubmissionGroupUserSubmissionGroup <-. Set.toList groups] + return Authorized + CSheetR tid ssh csh sheetn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetSubmissionGroup) $ do + course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + Entity _ Sheet{..} <- $cachedHereBinary (course, sheetn) . MaybeT . getBy $ CourseSheet course sheetn + when (is _RegisteredGroups sheetGrouping) $ do + uid <- hoistMaybe mAuthId + guardM . lift . E.selectExists . E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser) -> do + E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId + E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val course + E.&&. submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid + + return Authorized + r -> $unsupportedAuthPredicate AuthSubmissionGroup r +tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of + CExamR tid ssh csh examn subRoute -> maybeT (unauthorizedI MsgUnauthorizedExamTime) $ do + course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + Entity eId Exam{..} <- $cachedHereBinary (course, examn) . MaybeT . getBy $ UniqueExam course examn + cTime <- liftIO getCurrentTime + registration <- case mAuthId of + Just uid -> $cachedHereBinary (eId, uid) . lift . getBy $ UniqueExamRegistration eId uid + Nothing -> return Nothing + + let visible = NTop examVisibleFrom <= NTop (Just cTime) + + case subRoute of + EShowR -> guard visible + EUsersR -> guard $ NTop examStart <= NTop (Just cTime) + && NTop (Just cTime) <= NTop examFinished + ERegisterR + | is _Nothing registration + -> guard $ visible + && NTop examRegisterFrom <= NTop (Just cTime) + && NTop (Just cTime) <= NTop examRegisterTo + | otherwise + -> guard $ visible + && NTop (Just cTime) <= NTop examDeregisterUntil + ERegisterOccR occn -> do + occId <- hoistMaybe <=< $cachedHereBinary (eId, occn) . lift . getKeyBy $ UniqueExamOccurrence eId occn + if + | (registration >>= examRegistrationOccurrence . entityVal) == Just occId + -> guard $ visible + && NTop (Just cTime) <= NTop examDeregisterUntil + | otherwise + -> guard $ visible + && NTop examRegisterFrom <= NTop (Just cTime) + && NTop (Just cTime) <= NTop examRegisterTo + ECorrectR -> guard $ NTop (Just cTime) >= NTop examStart + && NTop (Just cTime) <= NTop examFinished + _ -> return () + + return Authorized + + CTutorialR tid ssh csh tutn TRegisterR -> maybeT (unauthorizedI MsgUnauthorizedTutorialTime) $ do + now <- liftIO getCurrentTime + course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + Entity tutId Tutorial{..} <- $cachedHereBinary (course, tutn) . MaybeT . getBy $ UniqueTutorial course tutn + registered <- case mAuthId of + Just uid -> $cachedHereBinary (tutId, uid) . lift . existsBy $ UniqueTutorialParticipant tutId uid + Nothing -> return False + + if + | not registered + , maybe False (now >=) tutorialRegisterFrom + , maybe True (now <=) tutorialRegisterTo + -> return Authorized + | registered + , maybe True (now <=) tutorialDeregisterUntil + -> return Authorized + | otherwise + -> mzero + + CSheetR tid ssh csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do + cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + Entity _sid Sheet{..} <- $cachedHereBinary (cid, shn) . MaybeT . getBy $ CourseSheet cid shn + cTime <- liftIO getCurrentTime + let + visible = NTop sheetVisibleFrom <= NTop (Just cTime) + active = NTop sheetActiveFrom <= NTop (Just cTime) && NTop (Just cTime) <= NTop sheetActiveTo + marking = NTop (Just cTime) > NTop sheetActiveTo + + guard visible + + case subRoute of + -- Single Files + SFileR SheetExercise _ -> guard $ NTop sheetActiveFrom <= NTop (Just cTime) + SFileR SheetHint _ -> guard $ maybe False (<= cTime) sheetHintFrom + SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom + SFileR _ _ -> mzero + -- Archives of SheetFileType + SZipR SheetExercise -> guard $ NTop sheetActiveFrom <= NTop (Just cTime) + SZipR SheetHint -> guard $ maybe False (<= cTime) sheetHintFrom + SZipR SheetSolution -> guard $ maybe False (<= cTime) sheetSolutionFrom + SZipR _ -> mzero + -- Submissions + SubmissionNewR -> guard active + SAssignR -> guard marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change; this is assumed in Corrections.assignHandler + SubmissionR _ SubAssignR -> guard marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change + SubmissionR _ _ -> guard active + _ -> return () + + return Authorized + + CourseR tid ssh csh (MaterialR mnm _) -> maybeT (unauthorizedI MsgUnauthorizedMaterialTime) $ do + cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + Entity _mid Material{materialVisibleFrom} <- $cachedHereBinary (cid, mnm) . MaybeT . getBy $ UniqueMaterial cid mnm + cTime <- liftIO getCurrentTime + let visible = NTop materialVisibleFrom <= NTop (Just cTime) + guard visible + return Authorized + + CourseR tid ssh csh CRegisterR -> do + now <- liftIO getCurrentTime + mbc <- $cachedHereBinary (tid, ssh, csh) . getBy $ TermSchoolCourseShort tid ssh csh + registered <- case (mbc,mAuthId) of + (Just (Entity cid _), Just uid) -> $cachedHereBinary (uid, cid) $ exists [CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive] + _ -> return False + case mbc of + (Just (Entity _ Course{courseRegisterFrom, courseRegisterTo})) + | not registered + , maybe False (now >=) courseRegisterFrom -- Nothing => no registration allowed + , maybe True (now <=) courseRegisterTo -> return Authorized + (Just (Entity cid Course{courseDeregisterUntil})) + | registered + -> maybeT (unauthorizedI MsgUnauthorizedCourseRegistrationTime) $ do + guard $ maybe True (now <=) courseDeregisterUntil + forM_ mAuthId $ \uid -> do + exams <- lift . E.select . E.from $ \exam -> do + E.where_ . E.exists . E.from $ \examRegistration -> + E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId + E.&&. examRegistration E.^. ExamRegistrationUser E.==. E.val uid + E.where_ $ exam E.^. ExamCourse E.==. E.val cid + return $ exam E.^. ExamDeregisterUntil + forM_ exams $ \(E.Value deregUntil) -> + guard $ NTop (Just now) <= NTop deregUntil + + tutorials <- lift . E.select . E.from $ \tutorial -> do + E.where_ . E.exists . E.from $ \tutorialParticipant -> + E.where_ $ tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId + E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. E.val uid + E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid + return $ tutorial E.^. TutorialDeregisterUntil + forM_ tutorials $ \(E.Value deregUntil) -> + guard $ NTop (Just now) <= NTop deregUntil + return Authorized + _other -> unauthorizedI MsgUnauthorizedCourseRegistrationTime + + CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do + Entity course Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh + allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course + allocation <- for allocationCourse $ \(Entity _ AllocationCourse{..}) -> $cachedHereBinary allocationCourseAllocation . MaybeT $ get allocationCourseAllocation + + case allocation of + Nothing -> do + cTime <- liftIO getCurrentTime + guard $ maybe False (cTime >=) courseRegisterFrom + guard $ maybe True (cTime <=) courseRegisterTo + Just Allocation{..} -> do + cTime <- liftIO getCurrentTime + guard $ NTop allocationRegisterFrom <= NTop (Just cTime) + guard $ NTop (Just cTime) <= NTop allocationRegisterTo + + return Authorized + + AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegisterTime) $ do + -- Checks `registerFrom` and `registerTo`, override as further routes become available + now <- liftIO getCurrentTime + Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getBy $ TermSchoolAllocationShort tid ssh ash + guard $ NTop allocationRegisterFrom <= NTop (Just now) + guard $ NTop (Just now) <= NTop allocationRegisterTo + return Authorized + + MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do + smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID + SystemMessage{systemMessageFrom, systemMessageTo} <- $cachedHereBinary smId . MaybeT $ get smId + cTime <- NTop . Just <$> liftIO getCurrentTime + guard $ NTop systemMessageFrom <= cTime + && NTop systemMessageTo >= cTime + return Authorized + + MessageHideR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do + smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID + SystemMessage{systemMessageFrom, systemMessageTo} <- $cachedHereBinary smId . MaybeT $ get smId + cTime <- NTop . Just <$> liftIO getCurrentTime + guard $ NTop systemMessageFrom <= cTime + && NTop systemMessageTo >= cTime + return Authorized + + CNewsR _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedCourseNewsTime) $ do + nId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID + CourseNews{courseNewsVisibleFrom} <- $cachedHereBinary nId . MaybeT $ get nId + cTime <- NTop . Just <$> liftIO getCurrentTime + guard $ NTop courseNewsVisibleFrom <= cTime + return Authorized + + r -> $unsupportedAuthPredicate AuthTime r +tagAccessPredicate AuthStaffTime = APDB $ \_ route isWrite -> case route of + CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do + course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course + allocation <- for allocationCourse $ \(Entity _ AllocationCourse{..}) -> $cachedHereBinary allocationCourseAllocation . MaybeT $ get allocationCourseAllocation + + case allocation of + Nothing -> return () + Just Allocation{..} -> do + cTime <- liftIO getCurrentTime + guard $ NTop allocationStaffAllocationFrom <= NTop (Just cTime) + when isWrite $ + guard $ NTop (Just cTime) <= NTop allocationStaffAllocationTo + + return Authorized + + AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegisterTime) $ do + -- Checks `registerFrom` and `registerTo`, override as further routes become available + now <- liftIO getCurrentTime + Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getBy $ TermSchoolAllocationShort tid ssh ash + guard $ NTop allocationStaffAllocationFrom <= NTop (Just now) + guard $ NTop (Just now) <= NTop allocationStaffAllocationTo + return Authorized + + r -> $unsupportedAuthPredicate AuthStaffTime r +tagAccessPredicate AuthAllocationTime = APDB $ \mAuthId route _ -> case route of + CourseR tid ssh csh CRegisterR -> do + now <- liftIO getCurrentTime + mba <- mbAllocation tid ssh csh + case mba of + Nothing -> return Authorized + Just (cid, Allocation{..}) -> do + registered <- case mAuthId of + Just uid -> $cachedHereBinary (uid, cid) . existsBy $ UniqueParticipant uid cid + _ -> return False + if + | not registered + , NTop allocationRegisterByCourse >= NTop (Just now) + -> unauthorizedI MsgUnauthorizedAllocatedCourseRegister + | registered + , NTop (Just now) >= NTop allocationOverrideDeregister + -> unauthorizedI MsgUnauthorizedAllocatedCourseDeregister + | otherwise + -> return Authorized + + CourseR tid ssh csh CAddUserR -> do + now <- liftIO getCurrentTime + mba <- mbAllocation tid ssh csh + case mba of + Just (_, Allocation{..}) + | NTop allocationRegisterByStaffTo <= NTop (Just now) + || NTop allocationRegisterByStaffFrom >= NTop (Just now) + -> unauthorizedI MsgUnauthorizedAllocatedCourseRegister + _other -> return Authorized + + CourseR tid ssh csh CDeleteR -> do + now <- liftIO getCurrentTime + mba <- mbAllocation tid ssh csh + case mba of + Just (_, Allocation{..}) + | NTop allocationRegisterByStaffTo <= NTop (Just now) + || NTop allocationRegisterByStaffFrom >= NTop (Just now) + -> unauthorizedI MsgUnauthorizedAllocatedCourseDelete + _other -> return Authorized + + r -> $unsupportedAuthPredicate AuthAllocationTime r + where + mbAllocation tid ssh csh = $cachedHereBinary (tid, ssh, csh) . runMaybeT $ do + cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + Entity _ AllocationCourse{..} <- MaybeT . getBy $ UniqueAllocationCourse cid + (cid,) <$> MaybeT (get allocationCourseAllocation) +tagAccessPredicate AuthCourseTime = APDB $ \_mAuthId route _ -> case route of + CourseR tid ssh csh _ -> exceptT return return $ do + now <- liftIO getCurrentTime + courseVisible <- $cachedHereBinary (tid, ssh, csh) . lift . E.selectExists . E.from $ \course -> do + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.&&. courseIsVisible now course Nothing + guardMExceptT courseVisible (unauthorizedI MsgUnauthorizedCourseTime) + return Authorized + r -> $unsupportedAuthPredicate AuthCourseTime r +tagAccessPredicate AuthCourseRegistered = APDB $ \mAuthId route _ -> case route of + CourseR tid ssh csh _ -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isRegistered <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` courseParticipant) -> do + E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse + E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId + E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered) + return Authorized + r -> $unsupportedAuthPredicate AuthCourseRegistered r +tagAccessPredicate AuthTutorialRegistered = APDB $ \mAuthId route _ -> case route of + CTutorialR tid ssh csh tutn _ -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isRegistered <- $cachedHereBinary (authId, tid, ssh, csh, tutn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do + E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial + E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse + E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val authId + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.&&. tutorial E.^. TutorialName E.==. E.val tutn + guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered) + return Authorized + CourseR tid ssh csh _ -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isRegistered <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do + E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial + E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse + E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val authId + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered) + return Authorized + r -> $unsupportedAuthPredicate AuthTutorialRegistered r +tagAccessPredicate AuthExamOccurrenceRegistration = APDB $ \_ route _ -> case route of + CExamR tid ssh csh examn _ -> exceptT return return $ do + isOccurrenceRegistration <- $cachedHereBinary (tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam) -> do + E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.&&. exam E.^. ExamName E.==. E.val examn + E.&&. exam E.^. ExamOccurrenceRule E.==. E.val ExamRoomFifo + guardMExceptT isOccurrenceRegistration (unauthorizedI MsgUnauthorizedExamOccurrenceRegistration) + return Authorized + r -> $unsupportedAuthPredicate AuthExamOccurrenceRegistration r +tagAccessPredicate AuthExamOccurrenceRegistered = APDB $ \mAuthId route _ -> case route of + CExamR tid ssh csh examn (ERegisterOccR occn) -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh, examn, occn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration `E.InnerJoin` examOccurrence) -> do + E.on $ E.just (examOccurrence E.^. ExamOccurrenceId) E.==. examRegistration E.^. ExamRegistrationOccurrence + E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam + E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse + E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId + E.&&. examOccurrence E.^. ExamOccurrenceName E.==. E.val occn + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.&&. exam E.^. ExamName E.==. E.val examn + guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered) + return Authorized + CExamR tid ssh csh examn _ -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do + E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam + E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse + E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.&&. exam E.^. ExamName E.==. E.val examn + E.&&. E.not_ (E.isNothing $ examRegistration E.^. ExamRegistrationOccurrence) + guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered) + return Authorized + CourseR tid ssh csh _ -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do + E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam + E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse + E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.&&. E.not_ (E.isNothing $ examRegistration E.^. ExamRegistrationOccurrence) + guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered) + return Authorized + r -> $unsupportedAuthPredicate AuthExamOccurrenceRegistered r +tagAccessPredicate AuthExamRegistered = APDB $ \mAuthId route _ -> case route of + CExamR tid ssh csh examn _ -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do + E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam + E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse + E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.&&. exam E.^. ExamName E.==. E.val examn + guardMExceptT hasRegistration $ unauthorizedI MsgUnauthorizedRegisteredExam + return Authorized + CSheetR tid ssh csh shn _ -> exceptT return return $ do + requiredExam' <- $cachedHereBinary (tid, ssh, csh, shn) . lift . E.selectMaybe . E.from $ \(course `E.InnerJoin` sheet) -> do + E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.&&. sheet E.^. SheetName E.==. E.val shn + return $ sheet E.^. SheetRequireExamRegistration + requiredExam <- maybeMExceptT (unauthorizedI MsgUnauthorizedRegisteredExam) . return $ E.unValue <$> requiredExam' + whenIsJust requiredExam $ \eId -> do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + isRegistered <- $cachedHereBinary (authId, eId) . lift . E.selectExists . E.from $ \examRegistration -> + E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eId + E.&&. examRegistration E.^. ExamRegistrationUser E.==. E.val authId + guardMExceptT isRegistered $ unauthorizedI MsgUnauthorizedRegisteredExam + return Authorized + CourseR tid ssh csh _ -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do + E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam + E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse + E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + guardMExceptT hasRegistration $ unauthorizedI MsgUnauthorizedRegisteredAnyExam + return Authorized + r -> $unsupportedAuthPredicate AuthExamRegistered r +tagAccessPredicate AuthExamResult = APDB $ \mAuthId route _ -> case route of + CExamR tid ssh csh examn _ -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + hasResult <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do + E.on $ exam E.^. ExamId E.==. examResult E.^. ExamResultExam + E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse + E.where_ $ examResult E.^. ExamResultUser E.==. E.val authId + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.&&. exam E.^. ExamName E.==. E.val examn + hasPartResult <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examPart `E.InnerJoin` examPartResult) -> do + E.on $ examPartResult E.^. ExamPartResultExamPart E.==. examPart E.^. ExamPartId + E.on $ exam E.^. ExamId E.==. examPart E.^. ExamPartExam + E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse + E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val authId + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.&&. exam E.^. ExamName E.==. E.val examn + guardMExceptT (hasResult || hasPartResult) (unauthorizedI MsgUnauthorizedExamResult) + return Authorized + EExamR tid ssh coursen examn _ -> $cachedHereBinary (mAuthId, tid, ssh, coursen, examn) . exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + hasResult <- $cachedHereBinary (authId, tid, ssh, coursen, examn) . lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamResult) -> do + E.on $ eexam E.^. ExternalExamId E.==. eexamResult E.^. ExternalExamResultExam + E.where_ $ eexamResult E.^. ExternalExamResultUser E.==. E.val authId + E.&&. eexam E.^. ExternalExamTerm E.==. E.val tid + E.&&. eexam E.^. ExternalExamSchool E.==. E.val ssh + E.&&. eexam E.^. ExternalExamCourseName E.==. E.val coursen + E.&&. eexam E.^. ExternalExamExamName E.==. E.val examn + guardMExceptT hasResult $ unauthorizedI MsgUnauthorizedExternalExamResult + return Authorized + CourseR tid ssh csh _ -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + hasResult <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do + E.on $ exam E.^. ExamId E.==. examResult E.^. ExamResultExam + E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse + E.where_ $ examResult E.^. ExamResultUser E.==. E.val authId + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + hasPartResult <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examPart `E.InnerJoin` examPartResult) -> do + E.on $ examPartResult E.^. ExamPartResultExamPart E.==. examPart E.^. ExamPartId + E.on $ exam E.^. ExamId E.==. examPart E.^. ExamPartExam + E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse + E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val authId + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + guardMExceptT (hasResult || hasPartResult) (unauthorizedI MsgUnauthorizedExamResult) + return Authorized + r -> $unsupportedAuthPredicate AuthExamRegistered r +tagAccessPredicate AuthAllocationRegistered = APDB $ \mAuthId route _ -> case route of + AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegistered) $ do + uid <- hoistMaybe mAuthId + aId <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getKeyBy $ TermSchoolAllocationShort tid ssh ash + void . MaybeT . $cachedHereBinary (uid, aId) . getKeyBy $ UniqueAllocationUser aId uid + return Authorized + r -> $unsupportedAuthPredicate AuthAllocationRegistered r +tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of + CNewsR tid ssh csh cID _ -> maybeT (unauthorizedI MsgUnauthorizedParticipantSelf) $ do + nId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID + CourseNews{courseNewsParticipantsOnly} <- $cachedHereBinary nId . MaybeT $ get nId + if | courseNewsParticipantsOnly -> do + uid <- hoistMaybe mAuthId + exceptT return (const mzero) . hoist lift $ isCourseParticipant tid ssh csh uid True + | otherwise + -> return Authorized + + CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do + participant <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedParticipant) (const True :: CryptoIDError -> Bool) $ decrypt cID + isCourseParticipant tid ssh csh participant False + unauthorizedI MsgUnauthorizedParticipant + + r -> $unsupportedAuthPredicate AuthParticipant r + + where + isCourseParticipant tid ssh csh participant onlyActive = do + let + authorizedIfExists :: E.From a => (a -> E.SqlQuery b) -> ExceptT AuthResult (ReaderT SqlReadBackend (HandlerFor UniWorX)) () + authorizedIfExists = flip whenExceptT Authorized <=< lift . E.selectExists . E.from + -- participant is currently registered + mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` courseParticipant) -> do + E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse + E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val participant + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + when onlyActive $ + E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive + -- participant has at least one submission + unless onlyActive $ + mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do + E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission + E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet + E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse + E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val participant + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + -- participant is member of a submissionGroup + unless onlyActive $ + mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser) -> do + E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup + E.on $ course E.^. CourseId E.==. submissionGroup E.^. SubmissionGroupCourse + E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val participant + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + -- participant is a sheet corrector + mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do + E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet + E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse + E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val participant + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + -- participant is a tutorial user + unless onlyActive $ + mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialUser) -> do + E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial + E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse + E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val participant + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + -- participant is tutor for this course + mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do + E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial + E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse + E.where_ $ tutor E.^. TutorUser E.==. E.val participant + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + -- participant is exam corrector for this course + mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do + E.on $ exam E.^. ExamId E.==. examCorrector E.^. ExamCorrectorExam + E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse + E.where_ $ examCorrector E.^. ExamCorrectorUser E.==. E.val participant + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + -- participant is lecturer for this course + mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` lecturer) -> do + E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse + E.where_ $ lecturer E.^. LecturerUser E.==. E.val participant + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + -- participant has an exam result for this course + unless onlyActive $ + mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do + E.on $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId + E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse + E.where_ $ examResult E.^. ExamResultUser E.==. E.val participant + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + -- participant is registered for an exam for this course + unless onlyActive $ + mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do + E.on $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId + E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse + E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val participant + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh +tagAccessPredicate AuthApplicant = APDB $ \mAuthId route _ -> case route of + CourseR tid ssh csh (CUserR cID) -> maybeT (unauthorizedI MsgUnauthorizedApplicant) $ do + uid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID + isApplicant <- isCourseApplicant tid ssh csh uid + guard isApplicant + return Authorized + + CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedApplicantSelf) $ do + uid <- hoistMaybe mAuthId + isApplicant <- isCourseApplicant tid ssh csh uid + guard isApplicant + return Authorized + + r -> $unsupportedAuthPredicate AuthApplicant r + where + isCourseApplicant tid ssh csh uid = lift . $cachedHereBinary (uid, tid, ssh, csh) . E.selectExists . E.from $ \(course `E.InnerJoin` courseApplication) -> do + E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse + E.where_ $ courseApplication E.^. CourseApplicationUser E.==. E.val uid + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh +tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of + CExamR tid ssh csh examn (ERegisterOccR occn) -> maybeT (unauthorizedI MsgExamOccurrenceNoCapacity) $ do + cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + eid <- $cachedHereBinary (cid, examn) . MaybeT . getKeyBy $ UniqueExam cid examn + Entity occId ExamOccurrence{..} <- $cachedHereBinary (eid, occn) . MaybeT . getBy $ UniqueExamOccurrence eid occn + registered <- $cachedHereBinary occId . lift $ fromIntegral <$> count [ ExamRegistrationOccurrence ==. Just occId, ExamRegistrationExam ==. eid ] + guard $ examOccurrenceCapacity > registered + return Authorized + CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgTutorialNoCapacity) $ do + cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + Entity tutId Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn + registered <- $cachedHereBinary tutId . lift $ count [ TutorialParticipantTutorial ==. tutId ] + guard $ NTop tutorialCapacity > NTop (Just registered) + return Authorized + CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do + Entity cid Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh + registered <- $cachedHereBinary cid . lift $ count [ CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ] + guard $ NTop courseCapacity > NTop (Just registered) + return Authorized + r -> $unsupportedAuthPredicate AuthCapacity r +tagAccessPredicate AuthRegisterGroup = APDB $ \mAuthId route _ -> case route of + CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialRegisterGroup) $ do + cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + Entity _ Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn + case (tutorialRegGroup, mAuthId) of + (Nothing, _) -> return Authorized + (_, Nothing) -> return AuthenticationRequired + (Just rGroup, Just uid) -> do + hasOther <- $cachedHereBinary (uid, rGroup) . lift . E.selectExists . E.from $ \(tutorial `E.InnerJoin` participant) -> do + E.on $ tutorial E.^. TutorialId E.==. participant E.^. TutorialParticipantTutorial + E.&&. tutorial E.^. TutorialCourse E.==. E.val tutorialCourse + E.&&. tutorial E.^. TutorialRegGroup E.==. E.just (E.val rGroup) + E.&&. participant E.^. TutorialParticipantUser E.==. E.val uid + guard $ not hasOther + return Authorized + r -> $unsupportedAuthPredicate AuthRegisterGroup r +tagAccessPredicate AuthEmpty = APDB $ \mAuthId route _ -> case route of + EExamListR -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + hasExternalExams <- $cachedHereBinary authId . lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamStaff) -> do + E.on $ eexam E.^. ExternalExamId E.==. eexamStaff E.^. ExternalExamStaffExam + E.where_ $ eexamStaff E.^. ExternalExamStaffUser E.==. E.val authId + guardMExceptT (not hasExternalExams) $ unauthorizedI MsgUnauthorizedExternalExamListNotEmpty + return Authorized + CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do + -- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh + cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + assertM_ (<= 0) . $cachedHereBinary cid . lift $ count [ CourseParticipantCourse ==. cid ] + assertM_ not . $cachedHereBinary cid . lift $ E.selectExists . E.from $ \(sheet `E.InnerJoin` submission) -> do + E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet + E.where_ $ sheet E.^. SheetCourse E.==. E.val cid + return Authorized + r -> $unsupportedAuthPredicate AuthEmpty r +tagAccessPredicate AuthMaterials = APDB $ \_ route _ -> case route of + CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do + Entity _ Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh + guard courseMaterialFree + return Authorized + r -> $unsupportedAuthPredicate AuthMaterials r +tagAccessPredicate AuthOwner = APDB $ \mAuthId route _ -> case route of + CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary (mAuthId, cID) . exceptT return return $ do + sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid + return Authorized + r -> $unsupportedAuthPredicate AuthOwner r +tagAccessPredicate AuthPersonalisedSheetFiles = APDB $ \mAuthId route _ -> case route of + CSheetR tid ssh csh shn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, shn) . exceptT return return $ do + Entity shId Sheet{..} <- maybeTMExceptT (unauthorizedI MsgUnauthorizedSubmissionPersonalisedSheetFiles) $ do + cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . getKeyBy $ TermSchoolCourseShort tid ssh csh + MaybeT . $cachedHereBinary (cid, shn) . getBy $ CourseSheet cid shn + if | sheetAllowNonPersonalisedSubmission -> return Authorized + | otherwise -> do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + flip guardMExceptT (unauthorizedI MsgUnauthorizedSubmissionPersonalisedSheetFiles) <=< $cachedHereBinary (shId, authId) . lift $ + E.selectExists . E.from $ \psFile -> + E.where_ $ psFile E.^. PersonalisedSheetFileSheet E.==. E.val shId + E.&&. psFile E.^. PersonalisedSheetFileUser E.==. E.val authId + E.&&. E.not_ (E.isNothing $ psFile E.^. PersonalisedSheetFileContent) -- directories don't count + return Authorized + r -> $unsupportedAuthPredicate AuthPersonalisedSheetFiles r +tagAccessPredicate AuthRated = APDB $ \_ route _ -> case route of + CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary cID . maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do + sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID + sub <- MaybeT $ get sid + guard $ submissionRatingDone sub + return Authorized + r -> $unsupportedAuthPredicate AuthRated r +tagAccessPredicate AuthUserSubmissions = APDB $ \_ route _ -> case route of + CSheetR tid ssh csh shn _ -> $cachedHereBinary (tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do + Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh + Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- MaybeT . getBy $ CourseSheet cid shn + guard $ is _Just submissionModeUser + return Authorized + r -> $unsupportedAuthPredicate AuthUserSubmissions r +tagAccessPredicate AuthCorrectorSubmissions = APDB $ \_ route _ -> case route of + CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do + Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh + Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- $cachedHereBinary (cid, shn) . MaybeT . getBy $ CourseSheet cid shn + guard submissionModeCorrector + return Authorized + r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r +tagAccessPredicate AuthSelf = APDB $ \mAuthId route _ -> exceptT return return $ do + referencedUser' <- case route of + AdminUserR cID -> return $ Left cID + AdminUserDeleteR cID -> return $ Left cID + AdminHijackUserR cID -> return $ Left cID + UserNotificationR cID -> return $ Left cID + UserPasswordR cID -> return $ Left cID + CourseR _ _ _ (CUserR cID) -> return $ Left cID + CApplicationR _ _ _ cID _ -> do + appId <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt cID + CourseApplication{..} <- maybeMExceptT (unauthorizedI MsgUnauthorizedSelf) . $cachedHereBinary appId $ get appId + return $ Right courseApplicationUser + _other -> throwError =<< $unsupportedAuthPredicate AuthSelf route + referencedUser <- case referencedUser' of + Right uid -> return uid + Left cID -> catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt cID + case mAuthId of + Just uid + | uid == referencedUser -> return Authorized + Nothing -> return AuthenticationRequired + _other -> unauthorizedI MsgUnauthorizedSelf +tagAccessPredicate AuthIsLDAP = APDB $ \_ route _ -> exceptT return return $ do + referencedUser <- case route of + AdminUserR cID -> return cID + AdminUserDeleteR cID -> return cID + AdminHijackUserR cID -> return cID + UserNotificationR cID -> return cID + UserPasswordR cID -> return cID + CourseR _ _ _ (CUserR cID) -> return cID + _other -> throwError =<< $unsupportedAuthPredicate AuthIsLDAP route + referencedUser' <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt referencedUser + maybeTMExceptT (unauthorizedI MsgUnauthorizedLDAP) $ do + User{..} <- MaybeT $ get referencedUser' + guard $ userAuthentication == AuthLDAP + return Authorized +tagAccessPredicate AuthIsPWHash = APDB $ \_ route _ -> exceptT return return $ do + referencedUser <- case route of + AdminUserR cID -> return cID + AdminUserDeleteR cID -> return cID + AdminHijackUserR cID -> return cID + UserNotificationR cID -> return cID + UserPasswordR cID -> return cID + CourseR _ _ _ (CUserR cID) -> return cID + _other -> throwError =<< $unsupportedAuthPredicate AuthIsPWHash route + referencedUser' <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt referencedUser + maybeTMExceptT (unauthorizedI MsgUnauthorizedPWHash) $ do + User{..} <- MaybeT $ get referencedUser' + guard $ is _AuthPWHash userAuthentication + return Authorized +tagAccessPredicate AuthAuthentication = APDB $ \mAuthId route _ -> case route of + MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do + smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID + SystemMessage{..} <- $cachedHereBinary smId . MaybeT $ get smId + let isAuthenticated = isJust mAuthId + guard $ not systemMessageAuthenticatedOnly || isAuthenticated + return Authorized + MessageHideR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do + smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID + SystemMessage{..} <- $cachedHereBinary smId . MaybeT $ get smId + let isAuthenticated = isJust mAuthId + guard $ not systemMessageAuthenticatedOnly || isAuthenticated + return Authorized + r -> $unsupportedAuthPredicate AuthAuthentication r +tagAccessPredicate AuthRead = APPure $ \_ _ isWrite -> do + MsgRenderer mr <- ask + return $ bool Authorized (Unauthorized $ mr MsgUnauthorizedWrite) isWrite +tagAccessPredicate AuthWrite = APPure $ \_ _ isWrite -> do + MsgRenderer mr <- ask + return $ bool (Unauthorized $ mr MsgUnauthorized) Authorized isWrite + + +authTagSpecificity :: AuthTag -> AuthTag -> Ordering +-- ^ Heuristic for which `AuthTag`s to evaluate first +authTagSpecificity = comparing $ NTop . flip findIndex eqClasses . elem + where + eqClasses :: [[AuthTag]] + -- ^ Constructors of `AuthTag` ordered (increasing) by execution order + eqClasses = + [ [ AuthFree, AuthDeprecated, AuthDevelopment ] -- Route wide + , [ AuthRead, AuthWrite, AuthToken ] -- Request wide + , [ AuthAdmin ] -- Site wide + , [ AuthLecturer, AuthCourseRegistered, AuthParticipant, AuthCourseTime, AuthTime, AuthMaterials, AuthUserSubmissions, AuthCorrectorSubmissions, AuthCapacity, AuthEmpty ] ++ [ AuthSelf, AuthNoEscalation ] ++ [ AuthAuthentication ] -- Course/User/SystemMessage wide + , [ AuthCorrector ] ++ [ AuthTutor ] ++ [ AuthTutorialRegistered, AuthRegisterGroup ] -- Tutorial/Material/Sheet wide + , [ AuthOwner, AuthRated ] -- Submission wide + ] + +defaultAuthDNF :: AuthDNF +defaultAuthDNF = PredDNF $ Set.fromList + [ impureNonNull . Set.singleton $ PLVariable AuthAdmin + , impureNonNull . Set.singleton $ PLVariable AuthToken + ] + +routeAuthTags :: Route UniWorX -> Either InvalidAuthTag AuthDNF +-- ^ DNF up to entailment: +-- +-- > (A_1 && A_2 && ...) OR' B OR' ... +-- +-- > A OR' B := ((A |- B) ==> A) && (A || B) +routeAuthTags = fmap (PredDNF . Set.mapMonotonic impureNonNull) . ofoldM partition' (Set.mapMonotonic toNullable $ dnfTerms defaultAuthDNF) . routeAttrs + where + partition' :: Set (Set AuthLiteral) -> Text -> Either InvalidAuthTag (Set (Set AuthLiteral)) + partition' prev t + | Just (Set.fromList . toNullable -> authTags) <- fromNullable =<< mapM fromPathPiece (Text.splitOn "AND" t) + = if + | oany (authTags `Set.isSubsetOf`) prev + -> Right prev + | otherwise + -> Right . Set.insert authTags $ Set.filter (not . (`Set.isSubsetOf` authTags)) prev + | otherwise + = Left $ InvalidAuthTag t + +evalAuthTags :: forall m. MonadAP m => AuthTagActive -> AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult +-- ^ `tell`s disabled predicates, identified as pivots +evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnfTerms -> authDNF') mAuthId route isWrite + = do + mr <- getMsgRenderer + let + authVarSpecificity = authTagSpecificity `on` plVar + authDNF = sortBy (authVarSpecificity `on` maximumBy authVarSpecificity . impureNonNull) $ map (sortBy authVarSpecificity) authDNF' + + authTagIsInactive = not . authTagIsActive + + evalAuthTag :: AuthTag -> WriterT (Set AuthTag) m AuthResult + evalAuthTag authTag = lift . ($runCachedMemoT :: CachedMemoT (AuthTag, Maybe UserId, Route UniWorX, Bool) AuthResult m _ -> m _) $ for4 memo evalAccessPred' authTag mAuthId route isWrite + where + evalAccessPred' authTag' mAuthId' route' isWrite' = lift $ do + $logDebugS "evalAccessPred" $ tshow (authTag', mAuthId', route', isWrite') + evalAccessPred (tagAccessPredicate authTag') mAuthId' route' isWrite' + + evalAuthLiteral :: AuthLiteral -> WriterT (Set AuthTag) m AuthResult + evalAuthLiteral PLVariable{..} = evalAuthTag plVar + evalAuthLiteral PLNegated{..} = notAR mr plVar <$> evalAuthTag plVar + + orAR', andAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult + orAR' = shortCircuitM (is _Authorized) (orAR mr) + andAR' = shortCircuitM (is _Unauthorized) (andAR mr) + + evalDNF :: [[AuthLiteral]] -> WriterT (Set AuthTag) m AuthResult + evalDNF = maybe (return $ falseAR mr) (ofoldr1 orAR') . fromNullable . map evalConj + where + evalConj = maybe (return $ trueAR mr) (ofoldr1 andAR') . fromNullable . map evalAuthLiteral + + $logDebugS "evalAuthTags" . tshow . (route, isWrite, ) $ map (map $ id &&& authTagIsActive . plVar) authDNF + + result <- evalDNF $ filter (all $ authTagIsActive . plVar) authDNF + + unless (is _Authorized result) . forM_ (filter (any $ authTagIsInactive . plVar) authDNF) $ \conj -> + whenM (allM conj (\aTag -> (return . not . authTagIsActive $ plVar aTag) `or2M` (not . is _Unauthorized <$> evalAuthLiteral aTag))) $ do + let pivots = filter (authTagIsInactive . plVar) conj + whenM (allM pivots $ fmap (is _Authorized) . evalAuthLiteral) $ do + let pivots' = plVar <$> pivots + $logDebugS "evalAuthTags" [st|Recording pivots: #{tshow pivots'}|] + tell $ Set.fromList pivots' + + return result + +evalAccessFor :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult +evalAccessFor mAuthId route isWrite = do + dnf <- either throwM return $ routeAuthTags route + fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) dnf mAuthId route isWrite + +evalAccessForDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlReadBackend backend) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT backend m AuthResult +evalAccessForDB = evalAccessFor + +evalAccessWith :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> m AuthResult +evalAccessWith assumptions route isWrite = do + mAuthId <- liftHandler maybeAuthId + tagActive <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags + dnf <- either throwM return $ routeAuthTags route + let dnf' = ala Endo foldMap (map ((=<<) . uncurry dnfAssumeValue) assumptions) $ Just dnf + case dnf' of + Nothing -> return Authorized + Just dnf'' -> do + (result, deactivated) <- runWriterT $ evalAuthTags tagActive dnf'' mAuthId route isWrite + result <$ tellSessionJson SessionInactiveAuthTags deactivated + +evalAccessWithDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlReadBackend backend) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> ReaderT backend m AuthResult +evalAccessWithDB = evalAccessWith + +evalAccess :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Route UniWorX -> Bool -> m AuthResult +evalAccess = evalAccessWith [] + +evalAccessDB :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlReadBackend backend) => Route UniWorX -> Bool -> ReaderT backend m AuthResult +evalAccessDB = evalAccess + +-- | Check whether the current user is authorized by `evalAccess` for the given route +-- Convenience function for a commonly used code fragment +hasAccessTo :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Route UniWorX -> Bool -> m Bool +hasAccessTo route isWrite = (== Authorized) <$> evalAccess route isWrite + +-- | Check whether the current user is authorized by `evalAccess` to read from the given route +-- Convenience function for a commonly used code fragment +hasReadAccessTo :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Route UniWorX -> m Bool +hasReadAccessTo = flip hasAccessTo False + +-- | Check whether the current user is authorized by `evalAccess` to rwrite to the given route +-- Convenience function for a commonly used code fragment +hasWriteAccessTo :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Route UniWorX -> m Bool +hasWriteAccessTo = flip hasAccessTo True + +wouldHaveAccessTo :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX ) + => [(AuthTag, Bool)] -- ^ Assumptions + -> Route UniWorX + -> Bool + -> m Bool +wouldHaveAccessTo assumptions route isWrite = (== Authorized) <$> evalAccessWith assumptions route isWrite + +wouldHaveReadAccessTo, wouldHaveWriteAccessTo + :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX ) + => [(AuthTag, Bool)] -- ^ Assumptions + -> Route UniWorX + -> m Bool +wouldHaveReadAccessTo assumptions route = wouldHaveAccessTo assumptions route False +wouldHaveWriteAccessTo assumptions route = wouldHaveAccessTo assumptions route True + +wouldHaveReadAccessToIff, wouldHaveWriteAccessToIff + :: ( MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX ) + => [(AuthTag, Bool)] -- ^ Assumptions + -> Route UniWorX + -> m Bool +wouldHaveReadAccessToIff assumptions route = and2M (not <$> hasReadAccessTo route) $ wouldHaveReadAccessTo assumptions route +wouldHaveWriteAccessToIff assumptions route = and2M (not <$> hasWriteAccessTo route) $ wouldHaveWriteAccessTo assumptions route diff --git a/src/Foundation/DB.hs b/src/Foundation/DB.hs new file mode 100644 index 000000000..5261af6a2 --- /dev/null +++ b/src/Foundation/DB.hs @@ -0,0 +1,46 @@ +module Foundation.DB + ( runDBRead + , runSqlPoolRetry + ) where + +import Import.NoFoundation hiding (runDB, getDBRunner) + +import Foundation.Type + +import qualified Control.Retry as Retry +import GHC.IO.Exception (IOErrorType(OtherError)) + +import Database.Persist.Sql (runSqlPool, SqlReadBackend(..)) + + +runSqlPoolRetry :: forall m a backend. + ( MonadUnliftIO m, BackendCompatible SqlBackend backend + , MonadLogger m, MonadMask m + ) + => ReaderT backend m a + -> Pool backend + -> m a +runSqlPoolRetry action pool = do + let policy = Retry.fullJitterBackoff 1e3 & Retry.limitRetriesByCumulativeDelay 10e6 + handlers = Retry.skipAsyncExceptions `snoc` Retry.logRetries suggestRetry logRetry + where suggestRetry :: IOException -> m Bool + suggestRetry ioExc = return $ + ioeGetErrorType ioExc == OtherError + && ioeGetLocation ioExc == "libpq" + logRetry :: forall e. + Exception e + => Bool -- ^ Will retry + -> e + -> Retry.RetryStatus + -> m () + logRetry shouldRetry@False err status = $logErrorS "runSqlPoolRetry" . pack $ Retry.defaultLogMsg shouldRetry err status + logRetry shouldRetry@True err status = $logWarnS "runSqlPoolRetry" . pack $ Retry.defaultLogMsg shouldRetry err status + + Retry.recovering policy handlers $ \Retry.RetryStatus{..} -> do + $logDebugS "runSqlPoolRetry" $ "rsIterNumber = " <> tshow rsIterNumber + runSqlPool action pool + +runDBRead :: ReaderT SqlReadBackend (HandlerFor UniWorX) a -> (HandlerFor UniWorX) a +runDBRead action = do + $logDebugS "YesodPersist" "runDBRead" + runSqlPoolRetry (withReaderT SqlReadBackend action) . appConnPool =<< getYesod diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index 3178424a9..aa514a72d 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -1,11 +1,12 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Foundation.I18n - ( appLanguages + ( appLanguages, appLanguagesOpts , UniWorXMessage(..) , ShortTermIdentifier(..) , MsgLanguage(..) , ShortSex(..) + , ShortWeekDay(..) , SheetTypeHeader(..) , SheetArchiveFileTypeDirectory(..) , ShortStudyDegree(..) @@ -34,16 +35,17 @@ import qualified Data.Text as Text import Utils.Form -import GHC.Exts (IsList(..)) +import qualified GHC.Exts (IsList(..)) import Yesod.Form.I18n.German import Yesod.Form.I18n.English -import qualified Data.Foldable as F import qualified Data.Char as Char import Text.Unidecode (unidecode) import Data.Text.Lens (packed) +import Data.List ((!!)) + appLanguages :: NonEmpty Lang appLanguages = "de-de-formal" :| ["en-eu"] @@ -116,7 +118,7 @@ ordinalEN (toMessage -> numStr) = case lastChar of Just '3' -> [st|#{numStr}rd|] _other -> [st|#{numStr}th|] where - lastChar = last <$> fromNullable numStr + lastChar = last <$> fromNullable numStr -- Convenience Type for Messages, since Yesod messages cannot deal with compound type identifiers @@ -178,11 +180,25 @@ instance RenderMessage UniWorX MsgLanguage where | ("de" : "DE" : _) <- lang' = mr MsgGermanGermany | ("de" : _) <- lang' = mr MsgGerman | ("en" : "EU" : _) <- lang' = mr MsgEnglishEurope - | ("en" : _) <- lang' = mr MsgEnglish + | ("en" : _) <- lang' = mr MsgEnglish | otherwise = lang where mr = renderMessage foundation $ lang : filter (/= lang) ls +appLanguagesOpts :: ( MonadHandler m + , RenderMessage (HandlerSite m) MsgLanguage + ) => m (OptionList Lang) +-- ^ Authoritive list of supported Languages +appLanguagesOpts = do + MsgRenderer mr <- getMsgRenderer + let mkOption l = Option + { optionDisplay = mr $ MsgLanguage l + , optionInternalValue = l + , optionExternalValue = l + } + langOptions = map mkOption $ toList appLanguages + return $ mkOptionList langOptions + embedRenderMessage ''UniWorX ''MessageStatus ("Message" <>) embedRenderMessage ''UniWorX ''NotificationTrigger $ ("NotificationTrigger" <>) . concat . drop 1 . splitCamel embedRenderMessage ''UniWorX ''StudyFieldType id @@ -255,7 +271,7 @@ instance RenderMessage UniWorX StudyDegreeTerm where where mr :: RenderMessage UniWorX msg => msg -> Text mr = renderMessage foundation ls - + newtype ShortStudyFieldType = ShortStudyFieldType StudyFieldType embedRenderMessageVariant ''UniWorX ''ShortStudyFieldType ("Short" <>) @@ -341,7 +357,7 @@ instance RenderMessage UniWorX UniWorXMessages where uniworxMessages :: [UniWorXMessage] -> UniWorXMessages uniworxMessages = UniWorXMessages . map SomeMessage - + -- This instance is required to use forms. You can modify renderMessage to -- achieve customized and internationalized form validation messages. instance RenderMessage UniWorX FormMessage where @@ -364,6 +380,23 @@ instance RenderMessage UniWorX (ValueRequired UniWorX) where mr :: forall msg. RenderMessage UniWorX msg => msg -> Text mr = renderMessage foundation ls +instance RenderRoute UniWorX => RenderMessage UniWorX (UnsupportedAuthPredicate AuthTag (Route UniWorX)) where + renderMessage f ls (UnsupportedAuthPredicate tag route) = mr . MsgUnsupportedAuthPredicate (mr tag) $ Text.intercalate "/" pieces + where + mr :: forall msg. RenderMessage UniWorX msg => msg -> Text + mr = renderMessage f ls + (pieces, _) = renderRoute route + +instance RenderMessage UniWorX WeekDay where + renderMessage _ ls wDay = pack . fst $ wDays (getTimeLocale' ls) !! (fromEnum wDay `mod` 7) + +newtype ShortWeekDay = ShortWeekDay { longWeekDay :: WeekDay } + +instance RenderMessage UniWorX ShortWeekDay where + renderMessage _ ls (ShortWeekDay wDay) = pack . snd $ wDays (getTimeLocale' ls) !! (fromEnum wDay `mod` 7) + +embedRenderMessage ''UniWorX ''ButtonSubmit id + unRenderMessage' :: (Eq a, Finite a, RenderMessage master a) => (Text -> Text -> Bool) -> master -> Text -> [a] unRenderMessage' cmp foundation inp = nub $ do @@ -371,7 +404,7 @@ unRenderMessage' cmp foundation inp = nub $ do x <- universeF guard $ renderMessage foundation (l : filter (/= l) appLanguages') x `cmp` inp return x - where appLanguages' = F.toList appLanguages + where appLanguages' = toList appLanguages unRenderMessage :: (Eq a, Finite a, RenderMessage master a) => master -> Text -> [a] unRenderMessage = unRenderMessage' (==) @@ -379,3 +412,7 @@ unRenderMessage = unRenderMessage' (==) unRenderMessageLenient :: (Eq a, Finite a, RenderMessage master a) => master -> Text -> [a] unRenderMessageLenient = unRenderMessage' cmp where cmp = (==) `on` mk . under packed (filter Char.isAlphaNum . concatMap unidecode) + + +instance Default DateTimeFormatter where + def = mkDateTimeFormatter (getTimeLocale' []) def appTZ diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs new file mode 100644 index 000000000..a5d305981 --- /dev/null +++ b/src/Foundation/Instances.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE UndecidableInstances #-} -- for `MonadCrypto` and `MonadSecretBox` +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Foundation.Instances + ( ButtonClass(..), YesodPersistBackend, AuthId, MonadCryptoKey + , unsafeHandler + ) where + +import Import.NoFoundation + +import qualified Data.Text as Text +import qualified Data.List as List +import Data.List (inits) + +import qualified Yesod.Core.Unsafe as Unsafe +import qualified Yesod.Auth.Message as Auth + +import Utils.Form +import Auth.LDAP +import Auth.PWHash +import Auth.Dummy + +import qualified Foundation.Yesod.Session as UniWorX +import qualified Foundation.Yesod.Middleware as UniWorX +import qualified Foundation.Yesod.ErrorHandler as UniWorX +import qualified Foundation.Yesod.StaticContent as UniWorX +import qualified Foundation.Yesod.Persist as UniWorX +import qualified Foundation.Yesod.Auth as UniWorX + +import Foundation.SiteLayout +import Foundation.Type +import Foundation.I18n +import Foundation.Authorization +import Foundation.Yesod.Auth hiding (authenticate) +import Foundation.Routes +import Foundation.DB + +import Network.Wai.Parse (lbsBackEnd) + +import Control.Monad.Writer.Class (MonadWriter(..)) +import UnliftIO.Pool (withResource) + + +data instance ButtonClass UniWorX + = BCIsButton + | BCDefault + | BCPrimary + | BCSuccess + | BCInfo + | BCWarning + | BCDanger + | BCLink + | BCMassInputAdd | BCMassInputDelete + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) + deriving anyclass (Universe, Finite) + +instance PathPiece (ButtonClass UniWorX) where + toPathPiece BCIsButton = "btn" + toPathPiece bClass = ("btn-" <>) . camelToPathPiece' 1 $ tshow bClass + fromPathPiece = flip List.lookup $ map (toPathPiece &&& id) universeF + +instance Button UniWorX ButtonSubmit where + btnClasses BtnSubmit = [BCIsButton, BCPrimary] + + + +-- Please see the documentation for the Yesod typeclass. There are a number +-- of settings which can be configured by overriding methods here. +instance Yesod UniWorX where + -- Controls the base of generated URLs. For more information on modifying, + -- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot + approot = ApprootRequest $ \app req -> + case app ^. _appRoot of + Nothing -> getApprootText guessApproot app req + Just root -> root + + makeSessionBackend = UniWorX.makeSessionBackend + + maximumContentLength app _ = app ^. _appMaximumContentLength + + -- Yesod Middleware allows you to run code before and after each handler function. + -- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks. + -- Some users may also want to add the defaultCsrfMiddleware, which: + -- a) Sets a cookie with a CSRF token in it. + -- 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 = UniWorX.yesodMiddleware + + -- Since we implement `errorHandler` ourselves we don't need `defaultMessageWidget` + defaultMessageWidget _title _body = error "defaultMessageWidget: undefined" + + errorHandler = UniWorX.errorHandler + + defaultLayout = siteLayout' Nothing + + -- The page to be redirected to when authentication is required. + authRoute _ = Just $ AuthR LoginR + + isAuthorized = evalAccess + + addStaticContent = UniWorX.addStaticContent + + fileUpload _site _length = FileUploadMemory lbsBackEnd + + -- What messages should be logged. The following includes all messages when + -- in development, and warnings and errors in production. + shouldLogIO app _source level = do + LogSettings{..} <- readTVarIO $ appLogSettings app + return $ logAll || level >= logMinimumLevel + + makeLogger = readTVarIO . snd . appLogger + +unsafeHandler :: UniWorX -> HandlerFor UniWorX a -> IO a +unsafeHandler f h = do + logger <- makeLogger f + Unsafe.fakeHandlerGetLogger (const logger) f h + + +-- How to run database actions. +instance YesodPersist UniWorX where + type YesodPersistBackend UniWorX = SqlBackend + runDB = UniWorX.runDB + +instance YesodPersistRunner UniWorX where + getDBRunner = UniWorX.getDBRunner + + +instance YesodAuth UniWorX where + type AuthId UniWorX = UserId + + -- Where to send a user after successful login + loginDest _ = NewsR + -- Where to send a user after logout + logoutDest _ = NewsR + -- Override the above two destinations when a Referer: header is present + redirectToReferer _ = True + + loginHandler = do + toParent <- getRouteToParent + liftHandler . defaultLayout $ do + plugins <- getsYesod authPlugins + $logDebugS "Auth" $ "Enabled plugins: " <> Text.intercalate ", " (map apName plugins) + + setTitleI MsgLoginTitle + $(widgetFile "login") + + authenticate = UniWorX.authenticate + + authPlugins UniWorX{ appSettings' = AppSettings{..}, appLdapPool } = catMaybes + [ flip campusLogin campusUserFailoverMode <$> appLdapPool + , Just . hashLogin $ pwHashAlgorithm appAuthPWHash + , dummyLogin <$ guard appAuthDummyLogin + ] + + authHttpManager = getsYesod appHttpManager + + onLogin = liftHandler $ do + mlang <- runDB $ updateUserLanguage Nothing + app <- getYesod + let mr | Just lang <- mlang = renderMessage app . map (Text.intercalate "-") . reverse . inits $ Text.splitOn "-" lang + | otherwise = renderMessage app [] + addMessage Success . toHtml $ mr Auth.NowLoggedIn + + onErrorHtml dest msg = do + addMessage Error $ toHtml msg + redirect dest + + renderAuthMessage _ ls = case lang of + ("en" : _) -> Auth.englishMessage + _other -> Auth.germanMessage + where lang = Text.splitOn "-" $ selectLanguage' appLanguages ls + +instance YesodAuthPersist UniWorX where + getAuthEntity = liftHandler . runDBRead . get + + +instance YesodMail UniWorX where + defaultFromAddress = getsYesod $ view _appMailFrom + mailObjectIdDomain = getsYesod $ view _appMailObjectDomain + mailVerp = getsYesod $ view _appMailVerp + mailDateTZ = return appTZ + mailSmtp act = do + pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool + withResource pool act + mailT ctx mail = defMailT ctx $ do + void setMailObjectIdRandom + setDateCurrent + replaceMailHeader "Sender" . Just =<< getsYesod (view $ _appMailFrom . _addressEmail) + + (mRes, smtpData) <- listen mail + unless (view _MailSmtpDataSet smtpData) + setMailSmtpData + + return mRes + + +instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where + type MonadCryptoKey m = CryptoIDKey + cryptoIDKey f = getsYesod appCryptoIDKey >>= f + +instance {-# OVERLAPPING #-} (Monad m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadSecretBox m where + secretBoxKey = getsYesod appSecretBoxKey diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs new file mode 100644 index 000000000..d4b3a1030 --- /dev/null +++ b/src/Foundation/Navigation.hs @@ -0,0 +1,2308 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{-# LANGUAGE UndecidableInstances #-} -- for `ChildrenNavChildren` +{-# LANGUAGE DuplicateRecordFields #-} -- for `navLabel` + +module Foundation.Navigation + ( NavQuickView(..), NavType(..), NavLevel(..), NavHeaderRole(..), NavLink(..), Nav(..), NavChildren + , _navModal, _navMethod, _navData, _navLabel, _navType, _navForceActive, _navHeaderRole, _navIcon, _navLink, _navChildren + , _NavHeader, _NavHeaderContainer, _NavPageActionPrimary, _NavPageActionSecondary, _NavFooter + , pageActions + , pageQuickActions + , defaultLinks + , navAccess + , navQuick + , evalAccessCorrector + ) where + +import Import.NoFoundation + +import Foundation.Type +import Foundation.Routes +import Foundation.I18n +import Foundation.Authorization +import Foundation.DB + +import Handler.Utils.Memcached +import Handler.Utils.ExamOffice.Course +import Utils.Sheet + +import qualified Data.CaseInsensitive as CI +import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E + +import Control.Monad.Trans.State (execStateT) + +import Yesod.Core.Types (HandlerContents) + + +-- Define breadcrumbs. +i18nCrumb :: (RenderMessage (HandlerSite m) msg, MonadHandler m) + => msg + -> Maybe (Route (HandlerSite m)) + -> m (Text, Maybe (Route (HandlerSite m))) +i18nCrumb msg mbR = do + mr <- getMessageRender + return (mr msg, mbR) + +-- `breadcrumb` _really_ needs to be total for _all_ routes +-- +-- Even if routes are POST only or don't usually use `siteLayout` they will if +-- an error occurs. +-- +-- Keep in mind that Breadcrumbs are also shown by the 403-Handler, +-- i.e. information might be leaked by not performing permission checks if the +-- breadcrumb value depends on sensitive content (like an user's name). +instance BearerAuthSite UniWorX => YesodBreadcrumbs UniWorX where + breadcrumb (AuthR _) = i18nCrumb MsgMenuLogin $ Just NewsR + breadcrumb (StaticR _) = i18nCrumb MsgBreadcrumbStatic Nothing + breadcrumb (WellKnownR _) = i18nCrumb MsgBreadcrumbWellKnown Nothing + breadcrumb MetricsR = i18nCrumb MsgBreadcrumbMetrics Nothing + + breadcrumb NewsR = i18nCrumb MsgMenuNews Nothing + breadcrumb UsersR = i18nCrumb MsgMenuUsers $ Just AdminR + breadcrumb AdminUserAddR = i18nCrumb MsgMenuUserAdd $ Just UsersR + breadcrumb (AdminUserR cID) = maybeT (i18nCrumb MsgBreadcrumbUser $ Just UsersR) $ do + guardM . hasReadAccessTo $ AdminUserR cID + uid <- decrypt cID + User{..} <- MaybeT . runDBRead $ get uid + return (userDisplayName, Just UsersR) + breadcrumb (AdminUserDeleteR cID) = i18nCrumb MsgBreadcrumbUserDelete . Just $ AdminUserR cID + breadcrumb (AdminHijackUserR cID) = i18nCrumb MsgBreadcrumbUserHijack . Just $ AdminUserR cID + breadcrumb (UserNotificationR cID) = do + mayList <- hasReadAccessTo UsersR + if + | mayList + -> i18nCrumb MsgMenuUserNotifications . Just $ AdminUserR cID + | otherwise + -> i18nCrumb MsgMenuUserNotifications $ Just ProfileR + breadcrumb (UserPasswordR cID) = do + mayList <- hasReadAccessTo UsersR + if + | mayList + -> i18nCrumb MsgMenuUserPassword . Just $ AdminUserR cID + | otherwise + -> i18nCrumb MsgMenuUserPassword $ Just ProfileR + breadcrumb AdminNewFunctionaryInviteR = i18nCrumb MsgMenuLecturerInvite $ Just UsersR + breadcrumb AdminFunctionaryInviteR = i18nCrumb MsgBreadcrumbFunctionaryInvite Nothing + + breadcrumb AdminR = i18nCrumb MsgAdminHeading Nothing + breadcrumb AdminFeaturesR = i18nCrumb MsgAdminFeaturesHeading $ Just AdminR + breadcrumb AdminTestR = i18nCrumb MsgMenuAdminTest $ Just AdminR + breadcrumb AdminErrMsgR = i18nCrumb MsgMenuAdminErrMsg $ Just AdminR + breadcrumb AdminTokensR = i18nCrumb MsgMenuAdminTokens $ Just AdminR + breadcrumb AdminCrontabR = i18nCrumb MsgBreadcrumbAdminCrontab $ Just AdminR + + breadcrumb SchoolListR = i18nCrumb MsgMenuSchoolList $ Just AdminR + breadcrumb (SchoolR ssh SchoolEditR) = maybeT (i18nCrumb MsgBreadcrumbSchool $ Just SchoolListR) $ do + School{..} <- MaybeT . runDBRead $ get ssh + return (CI.original schoolName, Just SchoolListR) + breadcrumb SchoolNewR = i18nCrumb MsgMenuSchoolNew $ Just SchoolListR + + breadcrumb (ExamOfficeR EOExamsR) = i18nCrumb MsgMenuExamOfficeExams Nothing + breadcrumb (ExamOfficeR EOFieldsR) = i18nCrumb MsgMenuExamOfficeFields . Just $ ExamOfficeR EOExamsR + breadcrumb (ExamOfficeR EOUsersR) = i18nCrumb MsgMenuExamOfficeUsers . Just $ ExamOfficeR EOExamsR + breadcrumb (ExamOfficeR EOUsersInviteR) = i18nCrumb MsgBreadcrumbExamOfficeUserInvite Nothing + + breadcrumb InfoR = i18nCrumb MsgMenuInformation Nothing + breadcrumb InfoLecturerR = i18nCrumb MsgInfoLecturerTitle $ Just InfoR + breadcrumb LegalR = i18nCrumb MsgMenuLegal $ Just InfoR + breadcrumb InfoAllocationR = i18nCrumb MsgBreadcrumbAllocationInfo $ Just InfoR + breadcrumb VersionR = i18nCrumb MsgMenuVersion $ Just InfoR + breadcrumb FaqR = i18nCrumb MsgBreadcrumbFaq $ Just InfoR + + + breadcrumb HelpR = i18nCrumb MsgMenuHelp Nothing + + + breadcrumb HealthR = i18nCrumb MsgMenuHealth Nothing + breadcrumb InstanceR = i18nCrumb MsgMenuInstance Nothing + + breadcrumb ProfileR = i18nCrumb MsgBreadcrumbProfile Nothing + breadcrumb SetDisplayEmailR = i18nCrumb MsgUserDisplayEmail $ Just ProfileR + breadcrumb ProfileDataR = i18nCrumb MsgMenuProfileData $ Just ProfileR + breadcrumb AuthPredsR = i18nCrumb MsgMenuAuthPreds $ Just ProfileR + breadcrumb CsvOptionsR = i18nCrumb MsgCsvOptions $ Just ProfileR + breadcrumb LangR = i18nCrumb MsgMenuLanguage $ Just ProfileR + + breadcrumb StorageKeyR = i18nCrumb MsgBreadcrumbStorageKey Nothing + + breadcrumb TermShowR = i18nCrumb MsgMenuTermShow $ Just NewsR + breadcrumb TermCurrentR = i18nCrumb MsgMenuTermCurrent $ Just TermShowR + breadcrumb TermEditR = i18nCrumb MsgMenuTermCreate $ Just TermShowR + breadcrumb (TermEditExistR tid) = i18nCrumb MsgMenuTermEdit . Just $ TermCourseListR tid + breadcrumb (TermCourseListR tid) = maybeT (i18nCrumb MsgBreadcrumbTerm $ Just CourseListR) $ do -- redirect only, used in other breadcrumbs + guardM . lift . runDBRead $ isJust <$> get tid + i18nCrumb (ShortTermIdentifier $ unTermKey tid) $ Just CourseListR + + breadcrumb (TermSchoolCourseListR tid ssh) = maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ TermCourseListR tid) $ do -- redirect only, used in other breadcrumbs + guardM . lift . runDBRead $ + (&&) <$> fmap isJust (get ssh) + <*> fmap isJust (get tid) + return (CI.original $ unSchoolKey ssh, Just $ TermCourseListR tid) + + breadcrumb AllocationListR = i18nCrumb MsgAllocationListTitle $ Just NewsR + breadcrumb (AllocationR tid ssh ash sRoute) = case sRoute of + AShowR -> maybeT (i18nCrumb MsgBreadcrumbAllocation $ Just AllocationListR) $ do + mr <- getMessageRender + Entity _ Allocation{allocationName} <- MaybeT . runDBRead . getBy $ TermSchoolAllocationShort tid ssh ash + return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{CI.original (unSchoolKey ssh)})|], Just AllocationListR) + ARegisterR -> i18nCrumb MsgBreadcrumbAllocationRegister . Just $ AllocationR tid ssh ash AShowR + AApplyR cID -> maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ AllocationR tid ssh ash AShowR) $ do + cid <- decrypt cID + Course{..} <- hoist runDBRead $ do + aid <- MaybeT . getKeyBy $ TermSchoolAllocationShort tid ssh ash + guardM . lift $ exists [ AllocationCourseAllocation ==. aid, AllocationCourseCourse ==. cid ] + MaybeT $ get cid + return (CI.original courseName, Just $ AllocationR tid ssh ash AShowR) + AUsersR -> i18nCrumb MsgBreadcrumbAllocationUsers . Just $ AllocationR tid ssh ash AShowR + APriosR -> i18nCrumb MsgBreadcrumbAllocationPriorities . Just $ AllocationR tid ssh ash AUsersR + AComputeR -> i18nCrumb MsgBreadcrumbAllocationCompute . Just $ AllocationR tid ssh ash AUsersR + AAcceptR -> i18nCrumb MsgBreadcrumbAllocationAccept . Just $ AllocationR tid ssh ash AUsersR + + breadcrumb ParticipantsListR = i18nCrumb MsgBreadcrumbParticipantsList $ Just CourseListR + breadcrumb (ParticipantsR _ _) = i18nCrumb MsgBreadcrumbParticipants $ Just ParticipantsListR + breadcrumb ParticipantsIntersectR = i18nCrumb MsgMenuParticipantsIntersect $ Just ParticipantsListR + + breadcrumb CourseListR = i18nCrumb MsgMenuCourseList Nothing + breadcrumb CourseNewR = i18nCrumb MsgMenuCourseNew $ Just CourseListR + breadcrumb (CourseR tid ssh csh CShowR) = maybeT (i18nCrumb MsgBreadcrumbCourse . Just $ TermSchoolCourseListR tid ssh) $ do + guardM . lift . runDBRead . existsBy $ TermSchoolCourseShort tid ssh csh + return (CI.original csh, Just $ TermSchoolCourseListR tid ssh) + breadcrumb (CourseR tid ssh csh CEditR) = i18nCrumb MsgMenuCourseEdit . Just $ CourseR tid ssh csh CShowR + breadcrumb (CourseR tid ssh csh CUsersR) = i18nCrumb MsgMenuCourseMembers . Just $ CourseR tid ssh csh CShowR + breadcrumb (CourseR tid ssh csh CAddUserR) = i18nCrumb MsgMenuCourseAddMembers . Just $ CourseR tid ssh csh CUsersR + breadcrumb (CourseR tid ssh csh CInviteR) = i18nCrumb MsgBreadcrumbCourseParticipantInvitation . Just $ CourseR tid ssh csh CShowR + breadcrumb (CourseR tid ssh csh CExamOfficeR) = i18nCrumb MsgMenuCourseExamOffice . Just $ CourseR tid ssh csh CShowR + breadcrumb (CourseR tid ssh csh (CUserR cID)) = maybeT (i18nCrumb MsgBreadcrumbUser . Just $ CourseR tid ssh csh CUsersR) $ do + guardM . hasReadAccessTo . CourseR tid ssh csh $ CUserR cID + uid <- decrypt cID + User{userDisplayName} <- MaybeT . runDBRead $ get uid + return (userDisplayName, Just $ CourseR tid ssh csh CUsersR) + breadcrumb (CourseR tid ssh csh CCorrectionsR) = i18nCrumb MsgMenuSubmissions . Just $ CourseR tid ssh csh CShowR + breadcrumb (CourseR tid ssh csh CAssignR) = i18nCrumb MsgMenuCorrectionsAssign . Just $ CourseR tid ssh csh CCorrectionsR + breadcrumb (CourseR tid ssh csh SheetListR) = i18nCrumb MsgMenuSheetList . Just $ CourseR tid ssh csh CShowR + breadcrumb (CourseR tid ssh csh SheetNewR ) = i18nCrumb MsgMenuSheetNew . Just $ CourseR tid ssh csh SheetListR + breadcrumb (CourseR tid ssh csh SheetCurrentR) = i18nCrumb MsgMenuSheetCurrent . Just $ CourseR tid ssh csh SheetListR + breadcrumb (CourseR tid ssh csh SheetOldUnassignedR) = i18nCrumb MsgMenuSheetOldUnassigned . Just $ CourseR tid ssh csh SheetListR + breadcrumb (CourseR tid ssh csh CCommR ) = i18nCrumb MsgMenuCourseCommunication . Just $ CourseR tid ssh csh CShowR + breadcrumb (CourseR tid ssh csh CTutorialListR) = i18nCrumb MsgMenuTutorialList . Just $ CourseR tid ssh csh CShowR + breadcrumb (CourseR tid ssh csh CTutorialNewR) = i18nCrumb MsgMenuTutorialNew . Just $ CourseR tid ssh csh CTutorialListR + breadcrumb (CourseR tid ssh csh CFavouriteR) = i18nCrumb MsgBreadcrumbCourseFavourite . Just $ CourseR tid ssh csh CShowR + breadcrumb (CourseR tid ssh csh CRegisterR) = i18nCrumb MsgBreadcrumbCourseRegister . Just $ CourseR tid ssh csh CShowR + breadcrumb (CourseR tid ssh csh CRegisterTemplateR) = i18nCrumb MsgBreadcrumbCourseRegisterTemplate . Just $ CourseR tid ssh csh CShowR + breadcrumb (CourseR tid ssh csh CLecInviteR) = i18nCrumb MsgBreadcrumbLecturerInvite . Just $ CourseR tid ssh csh CShowR + breadcrumb (CourseR tid ssh csh CDeleteR) = i18nCrumb MsgMenuCourseDelete . Just $ CourseR tid ssh csh CShowR + breadcrumb (CourseR tid ssh csh CHiWisR) = i18nCrumb MsgBreadcrumbHiWis . Just $ CourseR tid ssh csh CShowR + breadcrumb (CourseR tid ssh csh CNotesR) = i18nCrumb MsgBreadcrumbCourseNotes . Just $ CourseR tid ssh csh CShowR + + breadcrumb (CourseR tid ssh csh CNewsNewR) = i18nCrumb MsgMenuCourseNewsNew . Just $ CourseR tid ssh csh CShowR + breadcrumb (CourseR tid ssh csh (CourseNewsR cID sRoute)) = case sRoute of + CNShowR -> i18nCrumb MsgBreadcrumbCourseNews . Just $ CourseR tid ssh csh CShowR + CNEditR -> i18nCrumb MsgMenuCourseNewsEdit . Just $ CNewsR tid ssh csh cID CNShowR + CNDeleteR -> i18nCrumb MsgBreadcrumbCourseNewsDelete . Just $ CNewsR tid ssh csh cID CNShowR + CNArchiveR -> i18nCrumb MsgBreadcrumbCourseNewsArchive . Just $ CNewsR tid ssh csh cID CNShowR + CNFileR _ -> i18nCrumb MsgBreadcrumbCourseNewsFile . Just $ CNewsR tid ssh csh cID CNShowR + + breadcrumb (CourseR tid ssh csh CEventsNewR) = i18nCrumb MsgMenuCourseEventNew . Just $ CourseR tid ssh csh CShowR + breadcrumb (CourseR tid ssh csh (CourseEventR _cID sRoute)) = case sRoute of + CEvEditR -> i18nCrumb MsgMenuCourseEventEdit . Just $ CourseR tid ssh csh CShowR + CEvDeleteR -> i18nCrumb MsgBreadcrumbCourseEventDelete . Just $ CourseR tid ssh csh CShowR + + breadcrumb (CourseR tid ssh csh CExamListR) = i18nCrumb MsgMenuExamList . Just $ CourseR tid ssh csh CShowR + breadcrumb (CourseR tid ssh csh CExamNewR) = i18nCrumb MsgMenuExamNew . Just $ CourseR tid ssh csh CExamListR + + breadcrumb (CourseR tid ssh csh CApplicationsR) = i18nCrumb MsgMenuCourseApplications . Just $ CourseR tid ssh csh CShowR + breadcrumb (CourseR tid ssh csh CAppsFilesR) = i18nCrumb MsgBreadcrumbCourseAppsFiles . Just $ CourseR tid ssh csh CApplicationsR + + breadcrumb (CourseR tid ssh csh (CourseApplicationR cID sRoute)) = case sRoute of + CAEditR -> maybeT (i18nCrumb MsgBreadcrumbApplicant . Just $ CourseR tid ssh csh CApplicationsR) $ do + guardM . hasReadAccessTo $ CApplicationR tid ssh csh cID CAEditR + appId <- decrypt cID + User{..} <- hoist runDBRead $ MaybeT (get appId) >>= MaybeT . get . courseApplicationUser + return (userDisplayName, Just $ CourseR tid ssh csh CApplicationsR) + CAFilesR -> i18nCrumb MsgBreadcrumbApplicationFiles . Just $ CApplicationR tid ssh csh cID CAEditR + + breadcrumb (CourseR tid ssh csh (ExamR examn sRoute)) = case sRoute of + EShowR -> maybeT (i18nCrumb MsgBreadcrumbExam . Just $ CourseR tid ssh csh CExamListR) $ do + guardM . hasReadAccessTo $ CExamR tid ssh csh examn EShowR + return (CI.original examn, Just $ CourseR tid ssh csh CExamListR) + EEditR -> i18nCrumb MsgMenuExamEdit . Just $ CExamR tid ssh csh examn EShowR + EUsersR -> i18nCrumb MsgMenuExamUsers . Just $ CExamR tid ssh csh examn EShowR + EAddUserR -> i18nCrumb MsgMenuExamAddMembers . Just $ CExamR tid ssh csh examn EUsersR + EGradesR -> i18nCrumb MsgMenuExamGrades . Just $ CExamR tid ssh csh examn EShowR + ECInviteR -> i18nCrumb MsgBreadcrumbExamCorrectorInvite . Just $ CExamR tid ssh csh examn EShowR + EInviteR -> i18nCrumb MsgBreadcrumbExamParticipantInvite . Just $ CExamR tid ssh csh examn EShowR + ERegisterR -> i18nCrumb MsgBreadcrumbExamRegister . Just $ CExamR tid ssh csh examn EShowR + ERegisterOccR _occn -> i18nCrumb MsgBreadcrumbExamRegister . Just $ CExamR tid ssh csh examn EShowR + EAutoOccurrenceR -> i18nCrumb MsgBreadcrumbExamAutoOccurrence . Just $ CExamR tid ssh csh examn EUsersR + ECorrectR -> i18nCrumb MsgMenuExamCorrect . Just $ CExamR tid ssh csh examn EShowR + + breadcrumb (CourseR tid ssh csh (TutorialR tutn sRoute)) = case sRoute of + TUsersR -> maybeT (i18nCrumb MsgBreadcrumbTutorial . Just $ CourseR tid ssh csh CTutorialListR) $ do + guardM . hasReadAccessTo $ CTutorialR tid ssh csh tutn TUsersR + return (CI.original tutn, Just $ CourseR tid ssh csh CTutorialListR) + TEditR -> i18nCrumb MsgMenuTutorialEdit . Just $ CTutorialR tid ssh csh tutn TUsersR + TDeleteR -> i18nCrumb MsgMenuTutorialDelete . Just $ CTutorialR tid ssh csh tutn TUsersR + TCommR -> i18nCrumb MsgMenuTutorialComm . Just $ CTutorialR tid ssh csh tutn TUsersR + TRegisterR -> i18nCrumb MsgBreadcrumbTutorialRegister . Just $ CourseR tid ssh csh CShowR + TInviteR -> i18nCrumb MsgBreadcrumbTutorInvite . Just $ CTutorialR tid ssh csh tutn TUsersR + + breadcrumb (CourseR tid ssh csh (SheetR shn sRoute)) = case sRoute of + SShowR -> maybeT (i18nCrumb MsgBreadcrumbSheet . Just $ CourseR tid ssh csh SheetListR) $ do + guardM . hasReadAccessTo $ CSheetR tid ssh csh shn SShowR + return (CI.original shn, Just $ CourseR tid ssh csh SheetListR) + SEditR -> i18nCrumb MsgMenuSheetEdit . Just $ CSheetR tid ssh csh shn SShowR + SDelR -> i18nCrumb MsgMenuSheetDelete . Just $ CSheetR tid ssh csh shn SShowR + SSubsR -> i18nCrumb MsgMenuSubmissions . Just $ CSheetR tid ssh csh shn SShowR + SAssignR -> i18nCrumb MsgMenuCorrectionsAssign . Just $ CSheetR tid ssh csh shn SSubsR + SubmissionNewR -> i18nCrumb MsgMenuSubmissionNew . Just $ CSheetR tid ssh csh shn SShowR + SubmissionOwnR -> i18nCrumb MsgMenuSubmissionOwn . Just $ CSheetR tid ssh csh shn SShowR + SubmissionR cid sRoute' -> case sRoute' of + SubShowR -> do + mayList <- hasReadAccessTo $ CSheetR tid ssh csh shn SSubsR + if + | mayList + -> i18nCrumb MsgBreadcrumbSubmission . Just $ CSheetR tid ssh csh shn SSubsR + | otherwise + -> i18nCrumb MsgBreadcrumbSubmission . Just $ CSheetR tid ssh csh shn SShowR + CorrectionR -> i18nCrumb MsgMenuCorrection . Just $ CSubmissionR tid ssh csh shn cid SubShowR + SubDelR -> i18nCrumb MsgMenuSubmissionDelete . Just $ CSubmissionR tid ssh csh shn cid SubShowR + SubAssignR -> i18nCrumb MsgCorrectorAssignTitle . Just $ CSubmissionR tid ssh csh shn cid SubShowR + SInviteR -> i18nCrumb MsgBreadcrumbSubmissionUserInvite . Just $ CSubmissionR tid ssh csh shn cid SubShowR + SubArchiveR sft -> i18nCrumb sft . Just $ CSubmissionR tid ssh csh shn cid SubShowR + SubDownloadR _ _ -> i18nCrumb MsgBreadcrumbSubmissionFile . Just $ CSubmissionR tid ssh csh shn cid SubShowR + SArchiveR -> i18nCrumb MsgBreadcrumbSheetArchive . Just $ CSheetR tid ssh csh shn SShowR + SIsCorrR -> i18nCrumb MsgBreadcrumbSheetIsCorrector . Just $ CSheetR tid ssh csh shn SShowR + SPseudonymR -> i18nCrumb MsgBreadcrumbSheetPseudonym . Just $ CSheetR tid ssh csh shn SShowR + SCorrInviteR -> i18nCrumb MsgBreadcrumbSheetCorrectorInvite . Just $ CSheetR tid ssh csh shn SShowR + SZipR sft -> i18nCrumb sft . Just $ CSheetR tid ssh csh shn SShowR + SFileR _ _ -> i18nCrumb MsgBreadcrumbSheetFile . Just $ CSheetR tid ssh csh shn SShowR + SPersonalFilesR -> i18nCrumb MsgBreadcrumbSheetPersonalisedFiles . Just $ CSheetR tid ssh csh shn SShowR + + breadcrumb (CourseR tid ssh csh MaterialListR) = i18nCrumb MsgMenuMaterialList . Just $ CourseR tid ssh csh CShowR + breadcrumb (CourseR tid ssh csh MaterialNewR ) = i18nCrumb MsgMenuMaterialNew . Just $ CourseR tid ssh csh MaterialListR + breadcrumb (CourseR tid ssh csh (MaterialR mnm sRoute)) = case sRoute of + MShowR -> maybeT (i18nCrumb MsgBreadcrumbMaterial . Just $ CourseR tid ssh csh MaterialListR) $ do + guardM . hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR + return (CI.original mnm, Just $ CourseR tid ssh csh MaterialListR) + MEditR -> i18nCrumb MsgMenuMaterialEdit . Just $ CMaterialR tid ssh csh mnm MShowR + MDelR -> i18nCrumb MsgMenuMaterialDelete . Just $ CMaterialR tid ssh csh mnm MShowR + MArchiveR -> i18nCrumb MsgBreadcrumbMaterialArchive . Just $ CMaterialR tid ssh csh mnm MShowR + MFileR _ -> i18nCrumb MsgBreadcrumbMaterialFile . Just $ CMaterialR tid ssh csh mnm MShowR + + breadcrumb (CourseR tid ssh csh CPersonalFilesR) = i18nCrumb MsgBreadcrumbCourseSheetPersonalisedFiles . Just $ CourseR tid ssh csh CShowR + + breadcrumb CorrectionsR = i18nCrumb MsgMenuCorrections Nothing + breadcrumb CorrectionsUploadR = i18nCrumb MsgMenuCorrectionsUpload $ Just CorrectionsR + breadcrumb CorrectionsCreateR = i18nCrumb MsgMenuCorrectionsCreate $ Just CorrectionsR + breadcrumb CorrectionsGradeR = i18nCrumb MsgMenuCorrectionsGrade $ Just CorrectionsR + breadcrumb CorrectionsDownloadR = i18nCrumb MsgMenuCorrectionsDownload $ Just CorrectionsR + + breadcrumb (CryptoUUIDDispatchR _) = i18nCrumb MsgBreadcrumbCryptoIDDispatch Nothing + + breadcrumb (MessageR _) = do + mayList <- (== Authorized) <$> evalAccess MessageListR False + if + | mayList -> i18nCrumb MsgBreadcrumbSystemMessage $ Just MessageListR + | otherwise -> i18nCrumb MsgBreadcrumbSystemMessage $ Just NewsR + breadcrumb MessageListR = i18nCrumb MsgMenuMessageList $ Just AdminR + breadcrumb (MessageHideR cID) = i18nCrumb MsgBreadcrumbMessageHide . Just $ MessageR cID + + breadcrumb GlossaryR = i18nCrumb MsgMenuGlossary $ Just InfoR + + breadcrumb EExamListR = i18nCrumb MsgMenuExternalExamList Nothing + breadcrumb EExamNewR = do + isEO <- hasReadAccessTo $ ExamOfficeR EOExamsR + i18nCrumb MsgBreadcrumbExternalExamNew . Just $ if + | isEO -> ExamOfficeR EOExamsR + | otherwise -> EExamListR + breadcrumb (EExamR tid ssh coursen examn sRoute) = case sRoute of + EEShowR -> do + isEO <- hasReadAccessTo $ ExamOfficeR EOExamsR + maybeT (i18nCrumb MsgBreadcrumbExternalExam . Just $ bool EExamListR (ExamOfficeR EOExamsR) isEO) $ do + guardM . hasReadAccessTo $ EExamR tid ssh coursen examn EEShowR + i18nCrumb (MsgBreadcrumbExternalExamShow coursen examn) . Just $ if + | isEO -> ExamOfficeR EOExamsR + | otherwise -> EExamListR + EEEditR -> i18nCrumb MsgBreadcrumbExternalExamEdit . Just $ EExamR tid ssh coursen examn EEShowR + EEUsersR -> i18nCrumb MsgBreadcrumbExternalExamUsers . Just $ EExamR tid ssh coursen examn EEShowR + EEGradesR -> i18nCrumb MsgBreadcrumbExternalExamGrades . Just $ EExamR tid ssh coursen examn EEShowR + EEStaffInviteR -> i18nCrumb MsgBreadcrumbExternalExamStaffInvite . Just $ EExamR tid ssh coursen examn EEShowR + EECorrectR -> i18nCrumb MsgBreadcrumbExternalExamCorrect . Just $ EExamR tid ssh coursen examn EEShowR + + +data NavQuickView + = NavQuickViewFavourite + | NavQuickViewPageActionSecondary + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) + deriving (Universe, Finite) + +navQuick :: NavQuickView -> (NavQuickView -> Any) +navQuick x x' = Any $ x == x' + +data NavType + = NavTypeLink + { navModal :: Bool + } + | NavTypeButton + { navMethod :: StdMethod + , navData :: [(Text, Text)] + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (Binary) + +makeLenses_ ''NavType +makePrisms ''NavType + +data NavLevel = NavLevelTop | NavLevelInner + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) + +data NavHeaderRole = NavHeaderPrimary | NavHeaderSecondary + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) + +data NavLink = forall msg route. (RenderMessage UniWorX msg, HasRoute UniWorX route, RedirectUrl UniWorX route) => NavLink + { navLabel :: msg + , navRoute :: route + , navAccess' :: Handler Bool + , navType :: NavType + , navQuick' :: NavQuickView -> Any + , navForceActive :: Bool + } + +makeLenses_ ''NavLink + +instance HasRoute UniWorX NavLink where + urlRoute NavLink{..} = urlRoute navRoute +instance RedirectUrl UniWorX NavLink where + toTextUrl NavLink{..} = toTextUrl navRoute +instance RenderMessage UniWorX NavLink where + renderMessage app ls NavLink{..} = renderMessage app ls navLabel + +data Nav + = NavHeader + { navHeaderRole :: NavHeaderRole + , navIcon :: Icon + , navLink :: NavLink + } + | NavHeaderContainer + { navHeaderRole :: NavHeaderRole + , navLabel :: SomeMessage UniWorX + , navIcon :: Icon + , navChildren :: [NavLink] + } + | NavPageActionPrimary + { navLink :: NavLink + , navChildren :: [NavLink] + } + | NavPageActionSecondary + { navLink :: NavLink + } + | NavFooter + { navLink :: NavLink + } deriving (Generic, Typeable) + +makeLenses_ ''Nav +makePrisms ''Nav + +data NavChildren +type instance Children NavChildren a = ChildrenNavChildren a +type family ChildrenNavChildren a where + ChildrenNavChildren (SomeMessage UniWorX) = '[] + + ChildrenNavChildren a = Children ChGeneric a + +navAccess :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, BearerAuthSite UniWorX) => Nav -> MaybeT m Nav +navAccess = execStateT $ do + guardM $ preuse _navLink >>= maybe (return True) navLinkAccess + + _navChildren <~ (filterM navLinkAccess =<< use _navChildren) + whenM (hasn't _navLink <$> use id) $ + guardM $ not . null <$> use _navChildren + +navLinkAccess :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, BearerAuthSite UniWorX) => NavLink -> m Bool +navLinkAccess NavLink{..} = handle shortCircuit $ liftHandler navAccess' `and2M` accessCheck navType navRoute + where + shortCircuit :: HandlerContents -> m Bool + shortCircuit _ = return False + + accessCheck :: HasRoute UniWorX route => NavType -> route -> m Bool + accessCheck nt (urlRoute -> route) = do + authCtx <- getAuthContext + $memcachedByHere (Just $ Right 120) (authCtx, nt, route) $ + bool hasWriteAccessTo hasReadAccessTo (is _NavTypeLink nt) route + +defaultLinks :: (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => m [Nav] +defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the header. + [ return NavHeader + { navHeaderRole = NavHeaderSecondary + , navIcon = IconMenuLogout + , navLink = NavLink + { navLabel = MsgMenuLogout + , navRoute = AuthR LogoutR + , navAccess' = is _Just <$> maybeAuthId + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + } + , return NavHeader + { navHeaderRole = NavHeaderSecondary + , navIcon = IconMenuLogin + , navLink = NavLink + { navLabel = MsgMenuLogin + , navRoute = AuthR LoginR + , navAccess' = is _Nothing <$> maybeAuthId + , navType = NavTypeLink { navModal = True } + , navQuick' = mempty + , navForceActive = False + } + } + , return NavHeader + { navHeaderRole = NavHeaderSecondary + , navIcon = IconMenuProfile + , navLink = NavLink + { navLabel = MsgMenuProfile + , navRoute = ProfileR + , navAccess' = is _Just <$> maybeAuthId + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + } + , do + mCurrentRoute <- getCurrentRoute + + activeLang <- selectLanguage appLanguages + + let navChildren = flip map (toList appLanguages) $ \lang -> NavLink + { navLabel = MsgLanguage lang + , navRoute = (LangR, [(toPathPiece GetReferer, toPathPiece currentRoute) | currentRoute <- hoistMaybe mCurrentRoute ]) + , navAccess' = return True + , navType = NavTypeButton + { navMethod = POST + , navData = [(toPathPiece PostLanguage, lang)] + } + , navQuick' = mempty + , navForceActive = lang == activeLang + } + + guard $ length navChildren > 1 + + return NavHeaderContainer + { navHeaderRole = NavHeaderSecondary + , navLabel = SomeMessage MsgMenuLanguage + , navIcon = IconLanguage + , navChildren + } + , do + mCurrentRoute <- getCurrentRoute + + return NavHeader + { navHeaderRole = NavHeaderSecondary + , navIcon = IconMenuHelp + , navLink = NavLink + { navLabel = MsgMenuHelp + , navRoute = (HelpR, [(toPathPiece GetReferer, toPathPiece currentRoute) | currentRoute <- hoistMaybe mCurrentRoute ]) + , navAccess' = return True + , navType = NavTypeLink { navModal = True } + , navQuick' = mempty + , navForceActive = False + } + } + , return $ NavFooter NavLink + { navLabel = MsgMenuDataProt + , navRoute = LegalR :#: ("data-protection" :: Text) + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , return $ NavFooter NavLink + { navLabel = MsgMenuTermsUse + , navRoute = LegalR :#: ("terms-of-use" :: Text) + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , return $ NavFooter NavLink + { navLabel = MsgMenuCopyright + , navRoute = LegalR :#: ("copyright" :: Text) + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , return $ NavFooter NavLink + { navLabel = MsgMenuImprint + , navRoute = LegalR :#: ("imprint" :: Text) + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , return $ NavFooter NavLink + { navLabel = MsgMenuInformation + , navRoute = InfoR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , return $ NavFooter NavLink + { navLabel = MsgMenuFaq + , navRoute = FaqR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , return $ NavFooter NavLink + { navLabel = MsgMenuGlossary + , navRoute = GlossaryR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , return NavHeader + { navHeaderRole = NavHeaderPrimary + , navIcon = IconMenuNews + , navLink = NavLink + { navLabel = MsgMenuNews + , navRoute = NewsR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + } + , return NavHeader + { navHeaderRole = NavHeaderPrimary + , navIcon = IconMenuCourseList + , navLink = NavLink + { navLabel = MsgMenuCourseList + , navRoute = CourseListR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + } + , return NavHeader + { navHeaderRole = NavHeaderPrimary + , navIcon = IconMenuCorrections + , navLink = NavLink + { navLabel = MsgMenuCorrections + , navRoute = CorrectionsR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + } + , return NavHeader + { navHeaderRole = NavHeaderPrimary + , navIcon = IconMenuExams + , navLink = NavLink + { navLabel = MsgMenuExamOfficeExams + , navRoute = ExamOfficeR EOExamsR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + } + , return NavHeaderContainer + { navHeaderRole = NavHeaderPrimary + , navLabel = SomeMessage MsgAdminHeading + , navIcon = IconMenuAdmin + , navChildren = + [ NavLink + { navLabel = MsgMenuUsers + , navRoute = UsersR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , NavLink + { navLabel = MsgMenuSchoolList + , navRoute = SchoolListR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , NavLink + { navLabel = MsgAdminFeaturesHeading + , navRoute = AdminFeaturesR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , NavLink + { navLabel = MsgMenuMessageList + , navRoute = MessageListR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , NavLink + { navLabel = MsgMenuAdminErrMsg + , navRoute = AdminErrMsgR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , NavLink + { navLabel = MsgMenuAdminTokens + , navRoute = AdminTokensR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , NavLink + { navLabel = MsgMenuAdminCrontab + , navRoute = AdminCrontabR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , NavLink + { navLabel = MsgMenuAdminTest + , navRoute = AdminTestR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + ] + } + , return NavHeaderContainer + { navHeaderRole = NavHeaderPrimary + , navLabel = SomeMessage (mempty :: Text) + , navIcon = IconMenuExtra + , navChildren = + [ NavLink + { navLabel = MsgMenuCourseNew + , navRoute = CourseNewR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , NavLink + { navLabel = MsgMenuExternalExamList + , navRoute = EExamListR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , NavLink + { navLabel = MsgMenuTermShow + , navRoute = TermShowR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , NavLink + { navLabel = MsgMenuAllocationList + , navRoute = AllocationListR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , NavLink + { navLabel = MsgInfoLecturerTitle + , navRoute = InfoLecturerR + , navAccess' = hasWriteAccessTo CourseNewR + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + ] + } + ] + +pageActions :: ( MonadHandler m + , HandlerSite m ~ UniWorX + , MonadCatch m + , BearerAuthSite UniWorX + ) + => Route UniWorX -> m [Nav] +pageActions NewsR = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuOpenCourses + , navRoute = (CourseListR, [("courses-openregistration", toPathPiece True)]) + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuOpenAllocations + , navRoute = (AllocationListR, [("allocations-active", toPathPiece True)]) + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions (CourseR tid ssh csh CShowR) = do + materialListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh MaterialListR + tutorialListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh CTutorialListR + sheetListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh SheetListR + examListSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh CExamListR + membersSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh CUsersR + + let examListBound :: Num a => a + examListBound = 4 -- guaranteed random; chosen by fair dice roll + examListExams <- liftHandler . runDBRead $ do + examNames <- E.select . E.from $ \(course `E.InnerJoin` exam) -> do + E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.limit $ succ examListBound + return $ exam E.^. ExamName + return $ do + E.Value examn <- examNames + return NavLink + { navLabel = examn + , navRoute = CExamR tid ssh csh examn EShowR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = navQuick NavQuickViewFavourite + , navForceActive = False + } + let showExamList = length examListExams <= examListBound + + let + navMembers = NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuCourseMembers + , navRoute = CourseR tid ssh csh CUsersR + , navAccess' = + let courseWhere course = course <$ do + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + hasParticipants = E.selectExists . E.from $ \(course `E.InnerJoin` courseParticipant) -> do + E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse + E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive + void $ courseWhere course + mayRegister = hasWriteAccessTo $ CourseR tid ssh csh CAddUserR + in runDBRead $ mayRegister `or2M` hasParticipants + , navType = NavTypeLink { navModal = False } + , navQuick' = navQuick NavQuickViewFavourite + , navForceActive = False + } + , navChildren = membersSecondary + } + showMembers <- maybeT (return False) $ True <$ navAccess navMembers + + return $ + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuMaterialList + , navRoute = CourseR tid ssh csh MaterialListR + , navAccess' = + let lecturerAccess = hasWriteAccessTo $ CourseR tid ssh csh MaterialNewR -- Always show for lecturers to create new material + materialAccess mnm = hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR -- otherwise show only if the user can see at least one of the contents + existsVisible = do + matNames <- E.select . E.from $ \(course `E.InnerJoin` material) -> do + E.on $ course E.^. CourseId E.==. material E.^. MaterialCourse + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + return $ material E.^. MaterialName + anyM matNames (materialAccess . E.unValue) + in runDBRead $ lecturerAccess `or2M` existsVisible + , navType = NavTypeLink { navModal = False } + , navQuick' = navQuick NavQuickViewFavourite + , navForceActive = False + } + , navChildren = materialListSecondary + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuSheetList + , navRoute = CourseR tid ssh csh SheetListR + , navAccess' = + let lecturerAccess = hasWriteAccessTo $ CourseR tid ssh csh SheetNewR -- Always show for lecturers to create new sheets + sheetAccess shn = hasReadAccessTo $ CSheetR tid ssh csh shn SShowR -- othwerwise show only if the user can see at least one of the contents + existsVisible = do + sheetNames <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do + E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + return $ sheet E.^. SheetName + anyM sheetNames $ sheetAccess . E.unValue + in runDBRead $ lecturerAccess `or2M` existsVisible + , navType = NavTypeLink { navModal = False } + , navQuick' = navQuick NavQuickViewFavourite + , navForceActive = False + } + , navChildren = sheetListSecondary + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuTutorialList + , navRoute = CourseR tid ssh csh CTutorialListR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = navQuick NavQuickViewFavourite + , navForceActive = False + } + , navChildren = tutorialListSecondary + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExamList + , navRoute = CourseR tid ssh csh CExamListR + , navAccess' = + let lecturerAccess = hasWriteAccessTo $ CourseR tid ssh csh CExamNewR + examAccess examn = hasReadAccessTo $ CExamR tid ssh csh examn EShowR + existsVisible = do + examNames <- E.select . E.from $ \(course `E.InnerJoin` exam) -> do + E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + return $ exam E.^. ExamName + anyM examNames $ examAccess . E.unValue + in runDBRead $ lecturerAccess `or2M` existsVisible + , navType = NavTypeLink { navModal = False } + , navQuick' = bool (navQuick NavQuickViewFavourite) mempty showExamList + , navForceActive = False + } + , navChildren = examListSecondary ++ guardOnM showExamList examListExams + } + , navMembers + ] ++ guardOnM (not showMembers) [ NavPageActionPrimary{ navLink, navChildren = [] } | navLink <- membersSecondary ] ++ + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuCourseCommunication + , navRoute = CourseR tid ssh csh CCommR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = navQuick NavQuickViewFavourite + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionSecondary + { navLink = NavLink + { navLabel = MsgMenuCourseExamOffice + , navRoute = CourseR tid ssh csh CExamOfficeR + , navAccess' = do + uid <- requireAuthId + runDBRead $ do + cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh + E.selectExists $ do + (_school, isForced) <- courseExamOfficeSchools (E.val uid) (E.val cid) + E.where_ $ E.not_ isForced + , navType = NavTypeLink { navModal = True } + , navQuick' = mempty + , navForceActive = False + } + } + , NavPageActionSecondary + { navLink = NavLink + { navLabel = MsgMenuCourseEdit + , navRoute = CourseR tid ssh csh CEditR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + } + , NavPageActionSecondary + { navLink = NavLink + { navLabel = MsgMenuCourseClone + , navRoute = ( CourseNewR + , [("tid", toPathPiece tid), ("ssh", toPathPiece ssh), ("csh", toPathPiece csh)] + ) + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + } + , NavPageActionSecondary + { navLink = NavLink + { navLabel = MsgMenuCourseDelete + , navRoute = CourseR tid ssh csh CDeleteR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + } + ] +pageActions (ExamOfficeR EOExamsR) = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExamOfficeFields + , navRoute = ExamOfficeR EOFieldsR + , navAccess' = return True + , navType = NavTypeLink { navModal = True } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExamOfficeUsers + , navRoute = ExamOfficeR EOUsersR + , navAccess' = return True + , navType = NavTypeLink { navModal = True } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions SchoolListR = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuSchoolNew + , navRoute = SchoolNewR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions UsersR = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuLecturerInvite + , navRoute = AdminNewFunctionaryInviteR + , navAccess' = return True + , navType = NavTypeLink { navModal = True } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuUserAdd + , navRoute = AdminUserAddR + , navAccess' = return True + , navType = NavTypeLink { navModal = True } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions (AdminUserR cID) = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuUserNotifications + , navRoute = UserNotificationR cID + , navAccess' = return True + , navType = NavTypeLink { navModal = True } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuUserPassword + , navRoute = UserPasswordR cID + , navAccess' = do + uid <- decrypt cID + User{userAuthentication} <- runDBRead $ get404 uid + return $ is _AuthPWHash userAuthentication + , navType = NavTypeLink { navModal = True } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions InfoR = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgInfoLecturerTitle + , navRoute = InfoLecturerR + , navAccess' = hasWriteAccessTo CourseNewR + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuLegal + , navRoute = LegalR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuFaq + , navRoute = FaqR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuGlossary + , navRoute = GlossaryR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions VersionR = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgInfoLecturerTitle + , navRoute = InfoLecturerR + , navAccess' = hasWriteAccessTo CourseNewR + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuLegal + , navRoute = LegalR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuFaq + , navRoute = FaqR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuGlossary + , navRoute = GlossaryR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions HealthR = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuInstance + , navRoute = InstanceR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions InstanceR = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuHealth + , navRoute = HealthR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions HelpR = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuFaq + , navRoute = FaqR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgInfoLecturerTitle + , navRoute = InfoLecturerR + , navAccess' = hasWriteAccessTo CourseNewR + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = do + (section, navLabel) <- + [ ("courses", MsgInfoLecturerCourses) + , ("exercises", MsgInfoLecturerExercises) + , ("tutorials", MsgInfoLecturerTutorials) + , ("exams", MsgInfoLecturerExams) + , ("allocations", MsgInfoLecturerAllocations) + ] :: [(Text, UniWorXMessage)] + return NavLink + { navLabel + , navRoute = InfoLecturerR :#: section + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuGlossary + , navRoute = GlossaryR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions ProfileR = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuProfileData + , navRoute = ProfileDataR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuAuthPreds + , navRoute = AuthPredsR + , navAccess' = return True + , navType = NavTypeLink { navModal = True } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgCsvOptions + , navRoute = CsvOptionsR + , navAccess' = return True + , navType = NavTypeLink { navModal = True } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions TermShowR = do + participantsSecondary <- pageQuickActions NavQuickViewPageActionSecondary ParticipantsListR + return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuTermCreate + , navRoute = TermEditR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuParticipantsList + , navRoute = ParticipantsListR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = participantsSecondary + } + ] +pageActions (AllocationR tid ssh ash AShowR) = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuAllocationInfo + , navRoute = InfoAllocationR + , navAccess' = return True + , navType = NavTypeLink { navModal = True } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuAllocationUsers + , navRoute = AllocationR tid ssh ash AUsersR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuAllocationCompute + , navRoute = AllocationR tid ssh ash AComputeR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions (AllocationR tid ssh ash AUsersR) = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuAllocationPriorities + , navRoute = AllocationR tid ssh ash APriosR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuAllocationCompute + , navRoute = AllocationR tid ssh ash AComputeR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions CourseListR = do + participantsSecondary <- pageQuickActions NavQuickViewPageActionSecondary ParticipantsListR + return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuCourseNew + , navRoute = CourseNewR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuAllocationList + , navRoute = AllocationListR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuParticipantsList + , navRoute = ParticipantsListR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = participantsSecondary + } + ] +pageActions CourseNewR = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgInfoLecturerTitle + , navRoute = InfoLecturerR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions (CourseR tid ssh csh CCorrectionsR) = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuCorrectionsAssign + , navRoute = CourseR tid ssh csh CAssignR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuCorrectionsOwn + , navRoute = ( CorrectionsR + , [ ("corrections-term", toPathPiece tid) + , ("corrections-school", toPathPiece ssh) + , ("corrections-course", toPathPiece csh) + ] + ) + , navAccess' = do + muid <- maybeAuthId + case muid of + Nothing -> return False + (Just uid) -> do + runDBRead . E.selectExists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission) -> do + E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId + E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId + E.where_ $ submission E.^. SubmissionRatingBy E.==. E.just (E.val uid) + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + , navType = NavTypeLink { navModal = False } + , navQuick' = navQuick NavQuickViewPageActionSecondary + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions (CourseR tid ssh csh SheetListR) = do + correctionsSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CourseR tid ssh csh CCorrectionsR + + let + navCorrections = NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuSubmissions + , navRoute = CourseR tid ssh csh CCorrectionsR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite + , navForceActive = False + } + , navChildren = correctionsSecondary + } + showCorrections <- maybeT (return False) $ True <$ navAccess navCorrections + + return $ + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuSheetCurrent + , navRoute = CourseR tid ssh csh SheetCurrentR + , navAccess' = + runDBRead . maybeT (return False) $ do + void . MaybeT $ sheetCurrent tid ssh csh + return True + , navType = NavTypeLink { navModal = False } + , navQuick' = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuSheetOldUnassigned + , navRoute = CourseR tid ssh csh SheetOldUnassignedR + , navAccess' = + runDBRead . maybeT (return False) $ do + void . MaybeT $ sheetOldUnassigned tid ssh csh + return True + , navType = NavTypeLink { navModal = False } + , navQuick' = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite + , navForceActive = False + } + , navChildren = [] + } + , navCorrections + ] ++ guardOnM (not showCorrections) [ NavPageActionPrimary{ navLink, navChildren = [] } | navLink <- correctionsSecondary ] ++ + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuSheetNew + , navRoute = CourseR tid ssh csh SheetNewR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions (CourseR tid ssh csh CUsersR) = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuCourseAddMembers + , navRoute = CourseR tid ssh csh CAddUserR + , navAccess' = return True + , navType = NavTypeLink { navModal = True } + , navQuick' = navQuick NavQuickViewPageActionSecondary + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuCourseApplications + , navRoute = CourseR tid ssh csh CApplicationsR + , navAccess' = + let courseWhere course = course <$ do + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + existsApplications = E.selectExists . E.from $ \(course `E.InnerJoin` courseApplication) -> do + E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse + void $ courseWhere course + courseApplications = fmap (any E.unValue) . E.select . E.from $ \course -> do + void $ courseWhere course + return $ course E.^. CourseApplicationsRequired + courseAllocation = E.selectExists . E.from $ \(course `E.InnerJoin` allocationCourse) -> do + E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse + void $ courseWhere course + in runDBRead $ courseAllocation `or2M` courseApplications `or2M` existsApplications + , navType = NavTypeLink { navModal = False } + , navQuick' = navQuick NavQuickViewPageActionSecondary <> navQuick NavQuickViewFavourite + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions (CourseR tid ssh csh MaterialListR) = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuMaterialNew + , navRoute = CourseR tid ssh csh MaterialNewR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = navQuick NavQuickViewPageActionSecondary + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions (CMaterialR tid ssh csh mnm MShowR) = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuMaterialEdit + , navRoute = CMaterialR tid ssh csh mnm MEditR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionSecondary + { navLink = NavLink + { navLabel = MsgMenuMaterialDelete + , navRoute = CMaterialR tid ssh csh mnm MDelR + , navAccess' = return True + , navType = NavTypeLink { navModal = True } + , navQuick' = mempty + , navForceActive = False + } + } + ] +pageActions (CourseR tid ssh csh CTutorialListR) = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuTutorialNew + , navRoute = CourseR tid ssh csh CTutorialNewR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = navQuick NavQuickViewPageActionSecondary + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions (CTutorialR tid ssh csh tutn TEditR) = return + [ NavPageActionSecondary + { navLink = NavLink + { navLabel = MsgMenuTutorialDelete + , navRoute = CTutorialR tid ssh csh tutn TDeleteR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + } + ] +pageActions (CTutorialR tid ssh csh tutn TUsersR) = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuTutorialComm + , navRoute = CTutorialR tid ssh csh tutn TCommR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuTutorialEdit + , navRoute = CTutorialR tid ssh csh tutn TEditR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionSecondary + { navLink = NavLink + { navLabel = MsgMenuTutorialDelete + , navRoute = CTutorialR tid ssh csh tutn TDeleteR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + } + ] +pageActions (CourseR tid ssh csh CExamListR) = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExamNew + , navRoute = CourseR tid ssh csh CExamNewR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = navQuick NavQuickViewPageActionSecondary + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions (CExamR tid ssh csh examn EShowR) = do + usersSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CExamR tid ssh csh examn EUsersR + + return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExamEdit + , navRoute = CExamR tid ssh csh examn EEditR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExamUsers + , navRoute = CExamR tid ssh csh examn EUsersR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = usersSecondary + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExamGrades + , navRoute = CExamR tid ssh csh examn EGradesR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExamCorrect + , navRoute = CExamR tid ssh csh examn ECorrectR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions (CExamR tid ssh csh examn ECorrectR) = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExamUsers + , navRoute = CExamR tid ssh csh examn EUsersR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExamGrades + , navRoute = CExamR tid ssh csh examn EGradesR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionSecondary + { navLink = NavLink + { navLabel = MsgMenuExamEdit + , navRoute = CExamR tid ssh csh examn EEditR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + } + ] +pageActions (CExamR tid ssh csh examn EUsersR) = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExamAddMembers + , navRoute = CExamR tid ssh csh examn EAddUserR + , navAccess' = return True + , navType = NavTypeLink { navModal = True } + , navQuick' = navQuick NavQuickViewPageActionSecondary + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExamGrades + , navRoute = CExamR tid ssh csh examn EGradesR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExamCorrect + , navRoute = CExamR tid ssh csh examn ECorrectR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions (CExamR tid ssh csh examn EGradesR) = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExamUsers + , navRoute = CExamR tid ssh csh examn EUsersR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = navQuick NavQuickViewPageActionSecondary + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExamCorrect + , navRoute = CExamR tid ssh csh examn ECorrectR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions (CSheetR tid ssh csh shn SShowR) = do + subsSecondary <- pageQuickActions NavQuickViewPageActionSecondary $ CSheetR tid ssh csh shn SSubsR + let + navSubmissions = NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuSubmissions + , navRoute = CSheetR tid ssh csh shn SSubsR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = subsSecondary + } + showSubmissions <- maybeT (return False) $ True <$ navAccess navSubmissions + + return $ + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuSubmissionOwn + , navRoute = CSheetR tid ssh csh shn SubmissionOwnR + , navAccess' = + runDBRead . maybeT (return False) $ do + uid <- MaybeT $ liftHandler maybeAuthId + submissions <- lift $ submissionList tid csh shn uid + guard . not $ null submissions + return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , navSubmissions + ] ++ guardOnM (not showSubmissions) [ NavPageActionPrimary{ navLink, navChildren = [] } | navLink <- subsSecondary ] ++ + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuSheetPersonalisedFiles + , navRoute = CSheetR tid ssh csh shn SPersonalFilesR + , navAccess' = + let onlyPersonalised = fmap (maybe False $ not . E.unValue) . E.selectMaybe . E.from $ \(sheet `E.InnerJoin` course) -> do + E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId + E.where_$ sheet E.^. SheetName E.==. E.val shn + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + return $ sheet E.^. SheetAllowNonPersonalisedSubmission + hasPersonalised = E.selectExists . E.from $ \(sheet `E.InnerJoin` course `E.InnerJoin` personalisedSheetFile) -> do + E.on $ personalisedSheetFile E.^. PersonalisedSheetFileSheet E.==. sheet E.^. SheetId + E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId + E.where_$ sheet E.^. SheetName E.==. E.val shn + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + in runDBRead $ or2M onlyPersonalised hasPersonalised + , navType = NavTypeLink { navModal = True } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuSheetEdit + , navRoute = CSheetR tid ssh csh shn SEditR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionSecondary + { navLink = NavLink + { navLabel = MsgMenuSheetClone + , navRoute = (CourseR tid ssh csh SheetNewR, [("shn", toPathPiece shn)]) + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + } + , NavPageActionSecondary + { navLink = NavLink + { navLabel = MsgMenuSheetDelete + , navRoute = CSheetR tid ssh csh shn SDelR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + } + ] +pageActions (CSheetR tid ssh csh shn SSubsR) = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuSubmissionNew + , navRoute = CSheetR tid ssh csh shn SubmissionNewR + , navAccess' = + let submissionAccess = hasWriteAccessTo $ CSheetR tid ssh csh shn SSubsR + hasNoSubmission = maybeT (return False) $ do + uid <- MaybeT $ liftHandler maybeAuthId + submissions <- lift $ submissionList tid csh shn uid + guard $ null submissions + return True + in runDBRead $ hasNoSubmission `or2M` submissionAccess + , navType = NavTypeLink { navModal = True } + , navQuick' = navQuick NavQuickViewPageActionSecondary + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuCorrectionsOwn + , navRoute = ( CorrectionsR + , [ ("corrections-term", toPathPiece tid) + , ("corrections-school", toPathPiece ssh) + , ("corrections-course", toPathPiece csh) + , ("corrections-sheet", toPathPiece shn) + ] + ) + , navAccess' = (== Authorized) <$> evalAccessCorrector tid ssh csh + , navType = NavTypeLink { navModal = False } + , navQuick' = navQuick NavQuickViewPageActionSecondary + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuCorrectionsAssign + , navRoute = CSheetR tid ssh csh shn SAssignR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = navQuick NavQuickViewPageActionSecondary + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions (CSubmissionR tid ssh csh shn cid SubShowR) = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuCorrection + , navRoute = CSubmissionR tid ssh csh shn cid CorrectionR + , navAccess' = hasWriteAccessTo $ CSubmissionR tid ssh csh shn cid CorrectionR + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgCorrectorAssignTitle + , navRoute = CSubmissionR tid ssh csh shn cid SubAssignR + , navAccess' = return True + , navType = NavTypeLink { navModal = True } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionSecondary + { navLink = NavLink + { navLabel = MsgMenuSubmissionDelete + , navRoute = CSubmissionR tid ssh csh shn cid SubDelR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + } + ] +pageActions (CSubmissionR tid ssh csh shn cid CorrectionR) = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgCorrectorAssignTitle + , navRoute = CSubmissionR tid ssh csh shn cid SubAssignR + , navAccess' = return True + , navType = NavTypeLink { navModal = True } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionSecondary + { navLink = NavLink + { navLabel = MsgMenuSubmissionDelete + , navRoute = CSubmissionR tid ssh csh shn cid SubDelR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + } + ] +pageActions (CourseR tid ssh csh CApplicationsR) = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuCourseApplicationsFiles + , navRoute = CourseR tid ssh csh CAppsFilesR + , navAccess' = + let appAccess (E.Value appId) = do + cID <- encrypt appId + hasReadAccessTo $ CApplicationR tid ssh csh cID CAFilesR + appSource = E.selectSource . E.from $ \(course `E.InnerJoin` courseApplication) -> do + E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.where_ . E.exists . E.from $ \courseApplicationFile -> + E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. courseApplication E.^. CourseApplicationId + return $ courseApplication E.^. CourseApplicationId + in runDBRead . runConduit $ appSource .| anyMC appAccess + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuCourseMembers + , navRoute = CourseR tid ssh csh CUsersR + , navAccess' = + runDBRead $ do + cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh + exists [ CourseParticipantCourse ==. cid ] + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions CorrectionsR = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuCorrectionsDownload + , navRoute = CorrectionsDownloadR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = navQuick NavQuickViewPageActionSecondary + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuCorrectionsUpload + , navRoute = CorrectionsUploadR + , navAccess' = return True + , navType = NavTypeLink { navModal = True } + , navQuick' = navQuick NavQuickViewPageActionSecondary + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuCorrectionsCreate + , navRoute = CorrectionsCreateR + , navAccess' = runDBRead . maybeT (return False) $ do + uid <- MaybeT $ liftHandler maybeAuthId + sheets <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do + E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse + let + isCorrector' = E.exists . E.from $ \sheetCorrector -> E.where_ + $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid + E.&&. sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId + isLecturer = E.exists . E.from $ \lecturer -> E.where_ + $ lecturer E.^. LecturerUser E.==. E.val uid + E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId + E.where_ $ isCorrector' E.||. isLecturer + return $ sheet E.^. SheetSubmissionMode + return $ orOf (traverse . _Value . _submissionModeCorrector) sheets + , navType = NavTypeLink { navModal = False } + , navQuick' = navQuick NavQuickViewPageActionSecondary + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuCorrectionsGrade + , navRoute = CorrectionsGradeR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions CorrectionsGradeR = do + correctionsSecondary <- pageQuickActions NavQuickViewPageActionSecondary CorrectionsR + return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuCorrections + , navRoute = CorrectionsR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = correctionsSecondary + } + ] +pageActions EExamListR = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExternalExamNew + , navRoute = EExamNewR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions (EExamR tid ssh coursen examn EEShowR) = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExternalExamEdit + , navRoute = EExamR tid ssh coursen examn EEEditR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExternalExamUsers + , navRoute = EExamR tid ssh coursen examn EEUsersR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExternalExamGrades + , navRoute = EExamR tid ssh coursen examn EEGradesR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExternalExamCorrect + , navRoute = EExamR tid ssh coursen examn EECorrectR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions (EExamR tid ssh coursen examn EEGradesR) = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExternalExamCorrect + , navRoute = EExamR tid ssh coursen examn EECorrectR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExternalExamUsers + , navRoute = EExamR tid ssh coursen examn EEUsersR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExternalExamEdit + , navRoute = EExamR tid ssh coursen examn EEEditR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions (EExamR tis ssh coursen examn EECorrectR) = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExternalExamGrades + , navRoute = EExamR tid ssh coursen examn EEGradesR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExternalExamUsers + , navRoute = EExamR tid ssh coursen examn EEUsersR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExternalExamEdit + , navRoute = EExamR tid ssh coursen examn EEEditR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions (EExamR tid ssh coursen examn EEUsersR) = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExternalExamGrades + , navRoute = EExamR tid ssh coursen examn EEGradesR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExternalExamCorrect + , navRoute = EExamR tid ssh coursen examn EECorrectR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuExternalExamEdit + , navRoute = EExamR tid ssh coursen examn EEEditR + , navAccess' = return True + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions ParticipantsListR = return + [ NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgCsvOptions + , navRoute = CsvOptionsR + , navAccess' = return True + , navType = NavTypeLink { navModal = True } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } + + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuParticipantsIntersect + , navRoute = ParticipantsIntersectR + , navAccess' = return True + , navType = NavTypeLink { navModal = False} + , navQuick' = navQuick NavQuickViewPageActionSecondary + , navForceActive = False + } + , navChildren = [] + } + ] +pageActions _ = return [] + +submissionList :: ( MonadIO m + , BackendCompatible SqlReadBackend backend + ) + => TermId -> CourseShorthand -> SheetName -> UserId -> ReaderT backend m [E.Value SubmissionId] +submissionList tid csh shn uid = withReaderT (projectBackend @SqlReadBackend) . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do + E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId + E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId + E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId + + E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid + E.&&. sheet E.^. SheetName E.==. E.val shn + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.&&. course E.^. CourseTerm E.==. E.val tid + + return $ submission E.^. SubmissionId + + +pageQuickActions :: ( MonadCatch m + , MonadHandler m + , HandlerSite m ~ UniWorX + , BearerAuthSite UniWorX + ) + => NavQuickView -> Route UniWorX -> m [NavLink] +pageQuickActions qView route = do + items'' <- pageActions route + items' <- catMaybes <$> mapM (runMaybeT . navAccess) items'' + filterM navLinkAccess $ items' ^.. typesUsing @NavChildren @NavLink . filtered (getAny . ($ qView) . navQuick') + +-- | Verify that the currently logged in user is lecturer or corrector for at least one sheet for the given course +evalAccessCorrector + :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) + => TermId -> SchoolId -> CourseShorthand -> m AuthResult +evalAccessCorrector tid ssh csh = evalAccess (CourseR tid ssh csh CNotesR) False diff --git a/src/Foundation/Routes.hs b/src/Foundation/Routes.hs index afe77ba0e..52ca3f87c 100644 --- a/src/Foundation/Routes.hs +++ b/src/Foundation/Routes.hs @@ -21,8 +21,8 @@ import Foundation.Routes.Definitions -- http://www.yesodweb.com/book/scaffolding-and-the-site-template#scaffolding-and-the-site-template_foundation_and_application_modules -- -- This function also generates the following type synonyms: --- type Handler x = HandlerT UniWorX IO x --- type Widget = WidgetT UniWorX IO () +-- type Handler x = HandlerFor UniWorX x +-- type Widget = WidgetFor UniWorX () mkYesodData "UniWorX" uniworxRoutes deriving instance Generic CourseR @@ -75,11 +75,11 @@ pattern CSubmissionR tid ssh csh shn cid ptn pattern CApplicationR :: TermId -> SchoolId -> CourseShorthand -> CryptoFileNameCourseApplication -> CourseApplicationR -> Route UniWorX pattern CApplicationR tid ssh csh appId ptn = CourseR tid ssh csh (CourseApplicationR appId ptn) - + pattern CNewsR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> CourseNewsR -> Route UniWorX pattern CNewsR tid ssh csh nId ptn = CourseR tid ssh csh (CourseNewsR nId ptn) - + pattern CEventR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseEvent -> CourseEventR -> Route UniWorX pattern CEventR tid ssh csh nId ptn = CourseR tid ssh csh (CourseEventR nId ptn) diff --git a/src/Foundation/SiteLayout.hs b/src/Foundation/SiteLayout.hs new file mode 100644 index 000000000..765c1b70f --- /dev/null +++ b/src/Foundation/SiteLayout.hs @@ -0,0 +1,569 @@ +{-# LANGUAGE UndecidableInstances #-} -- for `MemcachedKeyFavourites` + +module Foundation.SiteLayout + ( siteLayout', siteLayout + , siteLayoutMsg', siteLayoutMsg + , getSystemMessageState + ) where + +import Import.NoFoundation hiding (embedFile) + +import Foundation.Type +import Foundation.Authorization +import Foundation.Routes +import Foundation.Navigation +import Foundation.I18n +import Foundation.DB + +import Utils.SystemMessage +import Utils.Form +import Utils.Course +import Utils.Metrics + +import Handler.Utils.Routes +import Handler.Utils.Memcached + +import qualified Data.Text as Text +import qualified Data.Set as Set +import qualified Data.HashMap.Strict as HashMap + +import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E + +import qualified Data.Conduit.Combinators as C + +import Text.Cassius (cassiusFile) +import Text.Hamlet (hamletFile) +import Data.FileEmbed (embedFile) + + +data MemcachedKeyFavourites + = MemcachedKeyFavouriteQuickActions CourseId AuthContext (NonEmpty Lang) + deriving (Generic, Typeable) + +deriving instance Eq AuthContext => Eq MemcachedKeyFavourites +deriving instance Read AuthContext => Read MemcachedKeyFavourites +deriving instance Show AuthContext => Show MemcachedKeyFavourites +deriving instance Hashable AuthContext => Hashable MemcachedKeyFavourites +deriving instance Binary AuthContext => Binary MemcachedKeyFavourites + +data MemcachedLimitKeyFavourites + = MemcachedLimitKeyFavourites + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (Hashable, Binary) + + +siteLayoutMsg :: (RenderMessage site msg, site ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), Button UniWorX ButtonSubmit) => msg -> WidgetFor UniWorX () -> HandlerFor UniWorX Html +siteLayoutMsg = siteLayout . i18n + +{-# DEPRECATED siteLayoutMsg' "Use siteLayoutMsg" #-} +siteLayoutMsg' :: (RenderMessage site msg, site ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), Button UniWorX ButtonSubmit) => msg -> WidgetFor UniWorX () -> HandlerFor UniWorX Html +siteLayoutMsg' = siteLayoutMsg + +siteLayout :: ( BearerAuthSite UniWorX + , BackendCompatible SqlBackend (YesodPersistBackend UniWorX) + , Button UniWorX ButtonSubmit + ) + => WidgetFor UniWorX () -- ^ `pageHeading` + -> WidgetFor UniWorX () -> HandlerFor UniWorX Html +siteLayout = siteLayout' . Just + +siteLayout' :: ( BearerAuthSite UniWorX + , BackendCompatible SqlBackend (YesodPersistBackend UniWorX) + , Button UniWorX ButtonSubmit + ) + => Maybe (WidgetFor UniWorX ()) -- ^ `pageHeading` + -> WidgetFor UniWorX () -> HandlerFor UniWorX Html +siteLayout' overrideHeading widget = do + AppSettings { appUserDefaults = UserDefaultConf{..}, .. } <- getsYesod $ view appSettings + + isModal <- hasCustomHeader HeaderIsModal + + primaryLanguage <- unsafeHead . Text.splitOn "-" <$> selectLanguage appLanguages + + mcurrentRoute <- getCurrentRoute + let currentHandler = classifyHandler <$> mcurrentRoute + + currentApproot' <- siteApproot <$> getYesod <*> (reqWaiRequest <$> getRequest) + + -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance. + let + breadcrumbs' mcRoute = do + mr <- getMessageRender + case mcRoute of + Nothing -> return (mr MsgErrorResponseTitleNotFound, []) + Just cRoute -> do + (title, next) <- breadcrumb cRoute + crumbs <- go [] next + return (title, crumbs) + where + go crumbs Nothing = return crumbs + go crumbs (Just cRoute) = do + hasAccess <- hasReadAccessTo cRoute + (title, next) <- breadcrumb cRoute + go ((cRoute, title, hasAccess) : crumbs) next + (title, parents) <- breadcrumbs' mcurrentRoute + + -- let isParent :: Route UniWorX -> Bool + -- isParent r = r == (fst parents) + + isAuth <- isJust <$> maybeAuthId + + now <- liftIO getCurrentTime + + -- Lookup Favourites & Theme if possible + (favourites', maxFavouriteTerms, currentTheme) <- do + muid <- maybeAuthPair + + favCourses'' <- runDBRead . E.select . E.from $ \(course `E.LeftOuterJoin` courseFavourite) -> do + E.on $ E.just (course E.^. CourseId) E.==. courseFavourite E.?. CourseFavouriteCourse + E.&&. courseFavourite E.?. CourseFavouriteUser E.==. E.val (view _1 <$> muid) + + let isFavourite = E.not_ . E.isNothing $ courseFavourite E.?. CourseFavouriteId + isCurrent + | Just (CourseR tid ssh csh _) <- mcurrentRoute + = course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + | otherwise + = E.false + notBlacklist = E.not_ . E.exists . E.from $ \courseNoFavourite -> + E.where_ $ E.just (courseNoFavourite E.^. CourseNoFavouriteUser) E.==. E.val (view _1 <$> muid) + E.&&. courseNoFavourite E.^. CourseNoFavouriteCourse E.==. course E.^. CourseId + isParticipant = E.exists . E.from $ \participant -> + E.where_ $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId + E.&&. E.just (participant E.^. CourseParticipantUser) E.==. E.val (view _1 <$> muid) + E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive + isLecturer = E.exists . E.from $ \lecturer -> + E.where_ $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId + E.&&. E.just (lecturer E.^. LecturerUser) E.==. E.val (view _1 <$> muid) + isCorrector = E.exists . E.from $ \(corrector `E.InnerJoin` sheet) -> do + E.on $ corrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId + E.&&. sheet E.^. SheetCourse E.==. course E.^. CourseId + E.where_ $ E.just (corrector E.^. SheetCorrectorUser) E.==. E.val (view _1 <$> muid) + isTutor = E.exists . E.from $ \(tutor `E.InnerJoin` tutorial) -> do + E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId + E.&&. tutorial E.^. TutorialCourse E.==. course E.^. CourseId + E.where_ $ E.just (tutor E.^. TutorUser) E.==. E.val (view _1 <$> muid) + isAssociated = isParticipant E.||. isLecturer E.||. isCorrector E.||. isTutor + courseVisible = courseIsVisible now course Nothing + + reason = E.case_ + [ E.when_ isCurrent E.then_ . E.just $ E.val FavouriteCurrent + , E.when_ isAssociated E.then_ . E.just $ E.val FavouriteParticipant + ] (E.else_ $ courseFavourite E.?. CourseFavouriteReason) + + E.where_ $ ((isFavourite E.||. isAssociated) E.&&. notBlacklist) E.||. isCurrent + + return (course, reason, courseVisible) + + favCourses' <- forM favCourses'' $ \(course@(Entity _ Course{..}), reason, E.Value courseVisible) -> do + mayView <- hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CShowR + mayEdit <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR + return (course, reason, courseVisible, mayView, mayEdit) + + let favCourses = favCourses' & filter (\(_, _, _, mayView, _) -> mayView) + + return ( favCourses + , maybe userDefaultMaxFavouriteTerms userMaxFavouriteTerms $ view _2 <$> muid + , maybe userDefaultTheme userTheme $ view _2 <$> muid + ) + + let favouriteTerms :: [TermIdentifier] + favouriteTerms = take maxFavouriteTerms . Set.toDescList $ foldMap (\(Entity _ Course{..}, _, _, _, _) -> Set.singleton $ unTermKey courseTerm) favourites' + + favourites <- fmap catMaybes . forM favourites' $ \(Entity cId c@Course{..}, E.Value mFavourite, courseVisible, mayView, mayEdit) + -> let courseRoute = CourseR courseTerm courseSchool courseShorthand CShowR + favouriteReason = fromMaybe FavouriteCurrent mFavourite + in runMaybeT . guardOnM (unTermKey courseTerm `elem` favouriteTerms) . lift $ do + ctx <- getAuthContext + MsgRenderer mr <- getMsgRenderer + langs <- selectLanguages appLanguages <$> languages + let cK = MemcachedKeyFavouriteQuickActions cId ctx langs + $logDebugS "FavouriteQuickActions" $ tshow cK <> " Checking..." + items <- memcachedLimitedKeyTimeoutBy + MemcachedLimitKeyFavourites appFavouritesQuickActionsBurstsize appFavouritesQuickActionsAvgInverseRate 1 + (Right <$> appFavouritesQuickActionsCacheTTL) + appFavouritesQuickActionsTimeout + cK + cK + . observeFavouritesQuickActionsDuration $ do + $logDebugS "FavouriteQuickActions" $ tshow cK <> " Starting..." + items' <- pageQuickActions NavQuickViewFavourite courseRoute + items <- forM items' $ \n@NavLink{navLabel} -> (mr navLabel,) <$> toTextUrl n + $logDebugS "FavouriteQuickActions" $ tshow cK <> " Done." + return items + $logDebugS "FavouriteQuickActions" $ tshow cK <> " returning " <> tshow (is _Just items) + return (c, courseRoute, items, favouriteReason, courseVisible, mayView, mayEdit) + + nav'' <- mconcat <$> sequence + [ defaultLinks + , maybe (return []) pageActions mcurrentRoute + ] + nav' <- catMaybes <$> mapM (runMaybeT . navAccess) nav'' + nav <- forM nav' $ \n -> (n,,,) <$> newIdent <*> traverse toTextUrl (n ^? _navLink) <*> traverse (\nc -> (nc,, ) <$> newIdent <*> toTextUrl nc) (n ^. _navChildren) + + mmsgs <- if + | isModal -> return mempty + | otherwise -> do + applySystemMessages + authTagPivots <- fromMaybe Set.empty <$> takeSessionJson SessionInactiveAuthTags + forM_ authTagPivots $ + \authTag -> addMessageWidget Info $ msgModal [whamlet|_{MsgUnauthorizedDisabledTag authTag}|] (Left $ SomeRoute (AuthPredsR, catMaybes [(toPathPiece GetReferer, ) . toPathPiece <$> mcurrentRoute])) + getMessages + + -- (langFormView, langFormEnctype) <- generateFormPost $ identifyForm FIDLanguage langForm + -- let langFormView' = wrapForm langFormView def + -- { formAction = Just $ SomeRoute LangR + -- , formSubmit = FormAutoSubmit + -- , formEncoding = langFormEnctype + -- } + + let highlight :: HasRoute UniWorX url => url -> Bool + -- ^ highlight last route in breadcrumbs, favorites taking priority + highlight = (highR ==) . Just . urlRoute + where crumbs = mcons mcurrentRoute $ view _1 <$> reverse parents + navItems = map (view _2) favourites ++ toListOf (folded . typesUsing @NavChildren @NavLink . to urlRoute) nav + highR = find (`elem` navItems) . uncurry (++) $ partition (`elem` map (view _2) favourites) crumbs + highlightNav = (||) <$> navForceActive <*> highlight + favouriteTermReason :: TermIdentifier -> FavouriteReason -> [(Course, Route UniWorX, Maybe [(Text, Text)], FavouriteReason, Bool, Bool, Bool)] + favouriteTermReason tid favReason' = favourites + & filter (\(Course{..}, _, _, favReason, _, _, _) -> unTermKey courseTerm == tid && favReason == favReason') + & sortOn (\(Course{..}, _, _, _, _, _, _) -> courseName) + + -- We break up the default layout into two components: + -- default-layout is the contents of the body tag, and + -- default-layout-wrapper is the entire page. Since the final + -- value passed to hamletToRepHtml cannot be a widget, this allows + -- you to use normal widget features in default-layout. + + navWidget :: (Nav, Text, Maybe Text, [(NavLink, Text, Text)]) -> WidgetFor UniWorX () + navWidget (n, navIdent, navRoute', navChildren') = case n of + NavHeader{ navLink = navLink@NavLink{..}, .. } + | NavTypeLink{..} <- navType + , navModal + -> customModal Modal + { modalTriggerId = Just navIdent + , modalId = Nothing + , modalTrigger = \mroute ident -> case mroute of + Just route -> $(widgetFile "widgets/navbar/item") + Nothing -> error "navWidget with non-link modal" + , modalContent = Left $ SomeRoute navLink + } + | NavTypeLink{} <- navType + -> let route = navRoute' + ident = navIdent + in $(widgetFile "widgets/navbar/item") + NavPageActionPrimary{ navLink = navLink@NavLink{..} } + -> let pWidget + | NavTypeLink{..} <- navType + , navModal + = customModal Modal + { modalTriggerId = Just navIdent + , modalId = Nothing + , modalTrigger = \mroute ident -> case mroute of + Just route -> $(widgetFile "widgets/pageaction/primary") + Nothing -> error "navWidget with non-link modal" + , modalContent = Left $ SomeRoute navLink + } + | NavTypeLink{} <- navType + = let route = navRoute' + ident = navIdent + in $(widgetFile "widgets/pageaction/primary") + | otherwise + = error "not implemented" + sWidgets = navChildren' + & map (\(l, i, r) -> navWidget (NavPageActionSecondary l, i, Just r, [])) + in $(widgetFile "widgets/pageaction/primary-wrapper") + NavPageActionSecondary{ navLink = navLink@NavLink{..} } + | NavTypeLink{..} <- navType + , navModal + -> customModal Modal + { modalTriggerId = Just navIdent + , modalId = Nothing + , modalTrigger = \mroute ident -> case mroute of + Just route -> $(widgetFile "widgets/pageaction/secondary") + Nothing -> error "navWidget with non-link modal" + , modalContent = Left $ SomeRoute navLink + } + | NavTypeLink{} <- navType + -> let route = navRoute' + ident = navIdent + in $(widgetFile "widgets/pageaction/secondary") + NavHeaderContainer{..} -> $(widgetFile "widgets/navbar/container") + NavFooter{ navLink = navLink@NavLink{..} } + | NavTypeLink{..} <- navType + , not navModal + -> let route = navRoute' + ident = navIdent + in $(widgetFile "widgets/footer/link") + _other -> error "not implemented" + + navContainerItemWidget :: (Nav, Text, Maybe Text, [(NavLink, Text, Text)]) + -> (NavLink, Text, Text) + -> WidgetFor UniWorX () + navContainerItemWidget (n, _navIdent, _navRoute', _navChildren') (iN@NavLink{..}, iNavIdent, iNavRoute) = case n of + NavHeaderContainer{} + | NavTypeLink{..} <- navType + , navModal + -> customModal Modal + { modalTriggerId = Just iNavIdent + , modalId = Nothing + , modalTrigger = \mroute ident -> case mroute of + Just route -> $(widgetFile "widgets/navbar/navbar-container-item--link") + Nothing -> error "navWidget with non-link modal" + , modalContent = Left $ SomeRoute iN + } + | NavTypeLink{} <- navType + -> let route = iNavRoute + ident = iNavIdent + in $(widgetFile "widgets/navbar/navbar-container-item--link") + | NavTypeButton{..} <- navType -> do + csrfToken <- reqToken <$> getRequest + wrapForm $(widgetFile "widgets/navbar/navbar-container-item--button") def + { formMethod = navMethod + , formSubmit = FormNoSubmit + , formAction = Just $ SomeRoute iN + } + _other -> error "not implemented" + + navbar :: WidgetFor UniWorX () + navbar = do + $(widgetFile "widgets/navbar/navbar") + forM_ (filter isNavHeaderContainer nav) $ \(_, containerIdent, _, _) -> + toWidget $(cassiusFile "templates/widgets/navbar/container-radio.cassius") + where isNavHeaderPrimary = has $ _1 . _navHeaderRole . only NavHeaderPrimary + isNavHeaderSecondary = has $ _1 . _navHeaderRole . only NavHeaderSecondary + asidenav :: WidgetFor UniWorX () + asidenav = $(widgetFile "widgets/asidenav/asidenav") + where + logo = preEscapedToMarkup $ decodeUtf8 $(embedFile "assets/lmu/logo.svg") + footer :: WidgetFor UniWorX () + footer = $(widgetFile "widgets/footer/footer") + where isNavFooter = has $ _1 . _NavFooter + alerts :: WidgetFor UniWorX () + alerts = $(widgetFile "widgets/alerts/alerts") + contentHeadline :: Maybe (WidgetFor UniWorX ()) + contentHeadline = overrideHeading <|> (pageHeading =<< mcurrentRoute) + breadcrumbsWgt :: WidgetFor UniWorX () + breadcrumbsWgt = $(widgetFile "widgets/breadcrumbs/breadcrumbs") + pageaction :: WidgetFor UniWorX () + pageaction = $(widgetFile "widgets/pageaction/pageaction") + -- functions to determine if there are page-actions (primary or secondary) + hasPageActions, hasSecondaryPageActions, hasPrimaryPageActions :: Bool + hasPageActions = hasPrimaryPageActions || hasSecondaryPageActions + hasSecondaryPageActions = has (folded . _1 . _NavPageActionSecondary) nav + hasPrimaryPageActions = has (folded . _1 . _NavPageActionPrimary ) nav + hasPrimarySubActions = has (folded . _1 . filtered (is _NavPageActionPrimary) . _navChildren . folded) nav + contentRibbon :: Maybe (WidgetFor UniWorX ()) + contentRibbon = fmap toWidget appRibbon + + isNavHeaderContainer = has $ _1 . _NavHeaderContainer + isPageActionPrimary = has $ _1 . _NavPageActionPrimary + isPageActionSecondary = has $ _1 . _NavPageActionSecondary + + MsgRenderer mr <- getMsgRenderer + let + -- See Utils.Frontend.I18n and files in messages/frontend for message definitions + frontendI18n = toJSON (mr :: FrontendMessage -> Text) + frontendDatetimeLocale <- toJSON <$> selectLanguage frontendDatetimeLocales + + pc <- widgetToPageContent $ do + webpackLinks_main StaticR + toWidget $(juliusFile "templates/i18n.julius") + whenIsJust currentApproot' $ \currentApproot -> + toWidget $(juliusFile "templates/approot.julius") + whenIsJust mcurrentRoute $ \currentRoute' -> do + currentRoute <- toTextUrl currentRoute' + toWidget $(juliusFile "templates/current-route.julius") + wellKnownHtmlLinks + + $(widgetFile "default-layout") + withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") + + +getSystemMessageState :: (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => SystemMessageId -> m UserSystemMessageState +getSystemMessageState smId = liftHandler $ do + muid <- maybeAuthId + reqSt <- $cachedHere getSystemMessageStateRequest + dbSt <- $cachedHere $ maybe (return mempty) getDBSystemMessageState muid + let MergeHashMap smSt = reqSt <> dbSt + smSt' = MergeHashMap $ HashMap.filter (/= mempty) smSt + when (smSt' /= reqSt) $ + setRegisteredCookieJson CookieSystemMessageState + =<< ifoldMapM (\smId' v -> MergeHashMap <$> (HashMap.singleton <$> encrypt smId' <*> pure v :: HandlerFor UniWorX (HashMap CryptoUUIDSystemMessage _))) smSt' + + return . fromMaybe mempty $ HashMap.lookup smId smSt + where + getSystemMessageStateRequest = + (lookupRegisteredCookiesJson id CookieSystemMessageState :: HandlerFor UniWorX (MergeHashMap CryptoUUIDSystemMessage UserSystemMessageState)) + >>= ifoldMapM (\(cID :: CryptoUUIDSystemMessage) v -> MergeHashMap <$> (maybeT (return mempty) . catchMPlus (Proxy @CryptoIDError) $ HashMap.singleton <$> decrypt cID <*> pure v)) + getDBSystemMessageState uid = runDBRead . runConduit $ selectSource [ SystemMessageHiddenUser ==. uid ] [] .| C.foldMap foldSt + where foldSt (Entity _ SystemMessageHidden{..}) + = MergeHashMap . HashMap.singleton systemMessageHiddenMessage $ mempty { userSystemMessageHidden = Just systemMessageHiddenTime } + +applySystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), BearerAuthSite UniWorX) => m () +applySystemMessages = liftHandler . maybeT_ . catchMPlus (Proxy @CryptoIDError) $ do + lift $ maybeAuthId >>= traverse_ syncSystemMessageHidden + + cRoute <- lift getCurrentRoute + guard $ cRoute /= Just NewsR + + lift . runDBRead . runConduit $ selectSource [] [Asc SystemMessageManualPriority] .| C.mapM_ applyMessage + where + syncSystemMessageHidden :: UserId -> HandlerFor UniWorX () + syncSystemMessageHidden uid = runDB . withReaderT projectBackend $ do + smSt <- lookupRegisteredCookiesJson id CookieSystemMessageState :: SqlPersistT (HandlerFor UniWorX) (MergeHashMap CryptoUUIDSystemMessage UserSystemMessageState) + iforM_ smSt $ \cID UserSystemMessageState{..} -> do + smId <- decrypt cID + whenIsJust userSystemMessageHidden $ \systemMessageHiddenTime -> void $ + upsert SystemMessageHidden + { systemMessageHiddenMessage = smId + , systemMessageHiddenUser = uid + , systemMessageHiddenTime + } + [ SystemMessageHiddenTime =. systemMessageHiddenTime ] + + when (maybe False (maybe (const True) (<=) userSystemMessageHidden) userSystemMessageUnhidden) $ do + deleteBy $ UniqueSystemMessageHidden uid smId + + modifyRegisteredCookieJson CookieSystemMessageState $ \(fold -> MergeHashMap hm) + -> fmap MergeHashMap . assertM' (/= mempty) $ + HashMap.update (\smSt' -> assertM' (/= mempty) $ smSt' { userSystemMessageHidden = Nothing, userSystemMessageUnhidden = Nothing }) cID hm + + applyMessage :: Entity SystemMessage -> ReaderT SqlReadBackend (HandlerFor UniWorX) () + applyMessage (Entity smId SystemMessage{..}) = maybeT_ $ do + guard $ not systemMessageNewsOnly + + cID <- encrypt smId + void . assertM (== Authorized) . lift $ evalAccessDB (MessageR cID) False + + now <- liftIO getCurrentTime + guard $ NTop systemMessageFrom <= NTop (Just now) + guard $ NTop (Just now) < NTop systemMessageTo + + UserSystemMessageState{..} <- lift $ getSystemMessageState smId + guard $ userSystemMessageShown <= Just systemMessageLastChanged + guard $ userSystemMessageHidden <= Just systemMessageLastUnhide + + (_, smTrans) <- MaybeT $ getSystemMessage appLanguages smId + let + (summary, content) = case smTrans of + Nothing -> (systemMessageSummary, systemMessageContent) + Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent) + case summary of + Just s -> + addMessageWidget systemMessageSeverity $ msgModal (toWidget s) (Left . SomeRoute $ MessageR cID) + Nothing -> addMessage systemMessageSeverity content + + tellRegisteredCookieJson CookieSystemMessageState . MergeHashMap $ + HashMap.singleton cID mempty{ userSystemMessageShown = Just now } + + +-- FIXME: Move headings into their respective handlers + +-- | Method for specifying page heading for handlers that call defaultLayout +-- +-- All handlers whose code is under our control should use +-- `siteLayout` instead; `pageHeading` is only a fallback solution for +-- e.g. subsites like `AuthR` +pageHeading :: ( YesodPersist UniWorX + , BackendCompatible SqlBackend (YesodPersistBackend UniWorX) + ) => Route UniWorX -> Maybe Widget +pageHeading (AuthR _) + = Just $ i18n MsgLoginHeading +pageHeading NewsR + = Just $ i18n MsgNewsHeading +pageHeading UsersR + = Just $ i18n MsgUsers +pageHeading (AdminUserR _) + = Just $ i18n MsgAdminUserHeading +pageHeading AdminTestR + = Just [whamlet|Internal Code Demonstration Page|] +pageHeading AdminErrMsgR + = Just $ i18n MsgErrMsgHeading + +pageHeading InfoR + = Just $ i18n MsgInfoHeading +pageHeading LegalR + = Just $ i18n MsgLegalHeading +pageHeading VersionR + = Just $ i18n MsgVersionHeading + +pageHeading HelpR + = Just $ i18n MsgHelpRequest + +pageHeading ProfileR + = Just $ i18n MsgProfileHeading +pageHeading ProfileDataR + = Just $ i18n MsgProfileDataHeading + +pageHeading TermShowR + = Just $ i18n MsgTermsHeading +pageHeading TermCurrentR + = Just $ i18n MsgTermCurrent +pageHeading TermEditR + = Just $ i18n MsgTermEditHeading +pageHeading (TermEditExistR tid) + = Just $ i18n $ MsgTermEditTid tid +pageHeading (TermCourseListR tid) + = Just . i18n . MsgTermCourseListHeading $ tid +pageHeading (TermSchoolCourseListR tid ssh) + = Just $ do + School{schoolName=school} <- handlerToWidget . runDB . withReaderT (projectBackend @SqlBackend) $ get404 ssh + i18n $ MsgTermSchoolCourseListHeading tid school + +pageHeading CourseListR + = Just $ i18n MsgCourseListTitle +pageHeading CourseNewR + = Just $ i18n MsgCourseNewHeading +pageHeading (CourseR tid ssh csh CShowR) + = Just $ do + Entity _ Course{..} <- handlerToWidget . runDB . withReaderT (projectBackend @SqlBackend) . getBy404 $ TermSchoolCourseShort tid ssh csh + toWidget courseName +-- (CourseR tid csh CRegisterR) -- just for POST +pageHeading (CourseR tid ssh csh CEditR) + = Just $ i18n $ MsgCourseEditHeading tid ssh csh +pageHeading (CourseR tid ssh csh CCorrectionsR) + = Just $ i18n $ MsgSubmissionsCourse tid ssh csh +pageHeading (CourseR tid ssh csh SheetListR) + = Just $ i18n $ MsgSheetList tid ssh csh +pageHeading (CourseR tid ssh csh SheetNewR) + = Just $ i18n $ MsgSheetNewHeading tid ssh csh +pageHeading (CSheetR tid ssh csh shn SShowR) + = Just $ i18n $ MsgSheetTitle tid ssh csh shn + -- = Just $ i18n $ prependCourseTitle tid ssh csh $ SomeMessage shn -- TODO: for consistency use prependCourseTitle throughout ERROR: circularity +pageHeading (CSheetR tid ssh csh shn SEditR) + = Just $ i18n $ MsgSheetEditHead tid ssh csh shn +pageHeading (CSheetR tid ssh csh shn SDelR) + = Just $ i18n $ MsgSheetDelHead tid ssh csh shn +pageHeading (CSheetR _tid _ssh _csh shn SSubsR) + = Just $ i18n $ MsgSubmissionsSheet shn +pageHeading (CSheetR tid ssh csh shn SubmissionNewR) + = Just $ i18n $ MsgSubmissionEditHead tid ssh csh shn +pageHeading (CSheetR tid ssh csh shn SubmissionOwnR) + = Just $ i18n $ MsgSubmissionEditHead tid ssh csh shn +pageHeading (CSubmissionR tid ssh csh shn _ SubShowR) -- TODO: Rethink this one! + = Just $ i18n $ MsgSubmissionEditHead tid ssh csh shn +-- (CSubmissionR tid csh shn cid SubArchiveR) -- just a download +pageHeading (CSubmissionR tid ssh csh shn cid CorrectionR) + = Just $ i18n $ MsgCorrectionHead tid ssh csh shn cid +-- (CSubmissionR tid csh shn cid SubDownloadR) -- just a download +-- (CSheetR tid ssh csh shn SFileR) -- just for Downloads + +pageHeading CorrectionsR + = Just $ i18n MsgCorrectionsTitle +pageHeading CorrectionsUploadR + = Just $ i18n MsgCorrUpload +pageHeading CorrectionsCreateR + = Just $ i18n MsgCorrCreate +pageHeading CorrectionsGradeR + = Just $ i18n MsgCorrGrade +pageHeading (MessageR _) + = Just $ i18n MsgSystemMessageHeading +pageHeading MessageListR + = Just $ i18n MsgSystemMessageListHeading + +-- TODO: add headings for more single course- and single term-pages +pageHeading _ + = Nothing diff --git a/src/Foundation/Type.hs b/src/Foundation/Type.hs index ee96ec211..5595127e8 100644 --- a/src/Foundation/Type.hs +++ b/src/Foundation/Type.hs @@ -7,6 +7,7 @@ module Foundation.Type , _SessionStorageMemcachedSql, _SessionStorageAcid , SMTPPool , _appSettings', _appStatic, _appConnPool, _appSmtpPool, _appLdapPool, _appWidgetMemcached, _appHttpManager, _appLogger, _appLogSettings, _appCryptoIDKey, _appClusterID, _appInstanceID, _appJobState, _appSessionStore, _appSecretBoxKey, _appJSONWebKeySet, _appHealthReport + , DB, Form, MsgRenderer, MailM ) where import Import.NoFoundation @@ -74,3 +75,9 @@ instance HasCookieSettings RegisteredCookie UniWorX where instance (MonadHandler m, HandlerSite m ~ UniWorX) => ReadLogSettings m where readLogSettings = liftIO . readTVarIO =<< getsYesod (view _appLogSettings) + + +type DB = YesodDB UniWorX +type Form x = Html -> MForm (HandlerFor UniWorX) (FormResult x, WidgetFor UniWorX ()) +type MsgRenderer = MsgRendererS UniWorX -- see Utils +type MailM a = MailT (HandlerFor UniWorX) a diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs new file mode 100644 index 000000000..66941c9f6 --- /dev/null +++ b/src/Foundation/Yesod/Auth.hs @@ -0,0 +1,498 @@ +module Foundation.Yesod.Auth + ( authenticate + , upsertCampusUser + , CampusUserConversionException(..) + , campusUserFailoverMode, updateUserLanguage + ) where + +import Import.NoFoundation hiding (authenticate) + +import Foundation.Type +import Foundation.Types +import Foundation.I18n + +import Handler.Utils.Profile +import Handler.Utils.StudyFeatures +import Handler.Utils.SchoolLdap + +import Yesod.Auth.Message +import Auth.LDAP + +import qualified Data.CaseInsensitive as CI +import qualified Control.Monad.Catch as C (Handler(..)) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Ldap.Client as Ldap +import qualified Data.Text.Encoding as Text +import qualified Data.ByteString as ByteString +import qualified Data.Set as Set +import qualified Data.Conduit.Combinators as C + +import qualified Data.List as List ((\\)) + +import qualified Data.UUID as UUID +import Data.ByteArray (convert) +import Crypto.Hash (SHAKE128) +import qualified Data.Binary as Binary + +import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E + +import Control.Monad.Writer.Class (MonadWriter(..)) +import Crypto.Hash.Conduit (sinkHash) + + +authenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX + , YesodPersist UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX) + , YesodAuth UniWorX, UserId ~ AuthId UniWorX + ) + => Creds UniWorX -> m (AuthenticationResult UniWorX) +authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $ do + now <- liftIO getCurrentTime + + let + uAuth = UniqueAuthentication $ CI.mk credsIdent + upsertMode = creds ^? _upsertCampusUserMode + + isDummy = is (_Just . _UpsertCampusUserDummy) upsertMode + isOther = is (_Just . _UpsertCampusUserOther) upsertMode + + excRecovery res + | isDummy || isOther + = do + case res of + UserError err -> addMessageI Error err + ServerError err -> addMessage Error $ toHtml err + _other -> return () + acceptExisting + | otherwise + = return res + + excHandlers = + [ C.Handler $ \case + CampusUserNoResult -> do + $logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent + excRecovery . UserError $ IdentifierNotFound credsIdent + CampusUserAmbiguous -> do + $logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent + excRecovery . UserError $ IdentifierNotFound credsIdent + err -> do + $logErrorS "LDAP" $ tshow err + mr <- getMessageRender + excRecovery . ServerError $ mr MsgInternalLdapError + , C.Handler $ \(cExc :: CampusUserConversionException) -> do + $logErrorS "LDAP" $ tshow cExc + mr <- getMessageRender + excRecovery . ServerError $ mr cExc + ] + + acceptExisting :: SqlPersistT (HandlerFor UniWorX) (AuthenticationResult UniWorX) + acceptExisting = do + res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth + case res of + Authenticated uid + -> associateUserSchoolsByTerms uid + _other + -> return () + case res of + Authenticated uid + | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ] + _other -> return res + + $logDebugS "auth" $ tshow Creds{..} + UniWorX{..} <- getYesod + + flip catches excHandlers $ case appLdapPool of + Just ldapPool + | Just upsertMode' <- upsertMode -> do + ldapData <- campusUser ldapPool campusUserFailoverMode Creds{..} + $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData + Authenticated . entityKey <$> upsertCampusUser upsertMode' ldapData + _other + -> acceptExisting + + +data CampusUserConversionException + = CampusUserInvalidIdent + | CampusUserInvalidEmail + | CampusUserInvalidDisplayName + | CampusUserInvalidGivenName + | CampusUserInvalidSurname + | CampusUserInvalidTitle + | CampusUserInvalidMatriculation + | CampusUserInvalidSex + | CampusUserInvalidFeaturesOfStudy Text + | CampusUserInvalidAssociatedSchools Text + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (Exception) + +_upsertCampusUserMode :: Traversal' (Creds UniWorX) UpsertCampusUserMode +_upsertCampusUserMode mMode cs@Creds{..} + | credsPlugin == "dummy" = setMode <$> mMode (UpsertCampusUserDummy $ CI.mk credsIdent) + | credsPlugin `elem` others = setMode <$> mMode (UpsertCampusUserOther $ CI.mk credsIdent) + | otherwise = setMode <$> mMode UpsertCampusUser + where + setMode UpsertCampusUser + = cs{ credsPlugin = "LDAP" } + setMode (UpsertCampusUserDummy ident) + = cs{ credsPlugin = "dummy", credsIdent = CI.original ident } + setMode (UpsertCampusUserOther ident) + = cs{ credsPlugin = bool (NonEmpty.head others) credsPlugin (credsPlugin `elem` others), credsIdent = CI.original ident } + + others = "PWHash" :| [] + +upsertCampusUser :: forall m. + ( MonadHandler m, HandlerSite m ~ UniWorX + , MonadThrow m + ) + => UpsertCampusUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User) +upsertCampusUser plugin ldapData = do + now <- liftIO getCurrentTime + UserDefaultConf{..} <- getsYesod $ view _appUserDefaults + + let + userIdent'' = fold [ v | (k, v) <- ldapData, k == ldapUserPrincipalName ] + userMatrikelnummer' = fold [ v | (k, v) <- ldapData, k == ldapUserMatriculation ] + userEmail' = fold $ do + k' <- toList ldapUserEmail + (k, v) <- ldapData + guard $ k' == k + return v + userDisplayName'' = fold [ v | (k, v) <- ldapData, k == ldapUserDisplayName ] + userFirstName' = fold [ v | (k, v) <- ldapData, k == ldapUserFirstName ] + userSurname' = fold [ v | (k, v) <- ldapData, k == ldapUserSurname ] + userTitle' = fold [ v | (k, v) <- ldapData, k == ldapUserTitle ] + userSex' = fold [ v | (k, v) <- ldapData, k == ldapSex ] + + userAuthentication + | is _UpsertCampusUserOther plugin + = error "PWHash should only work for users that are already known" + | otherwise = AuthLDAP + userLastAuthentication = now <$ guard (isn't _UpsertCampusUserDummy plugin) + + userIdent <- if + | [bs] <- userIdent'' + , Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs + , hasn't _upsertCampusUserIdent plugin || has (_upsertCampusUserIdent . only userIdent') plugin + -> return userIdent' + | Just userIdent' <- plugin ^? _upsertCampusUserIdent + -> return userIdent' + | otherwise + -> throwM CampusUserInvalidIdent + userEmail <- if + | userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') userEmail' + -> return $ CI.mk userEmail + | otherwise + -> throwM CampusUserInvalidEmail + userDisplayName' <- if + | [bs] <- userDisplayName'' + , Right userDisplayName' <- Text.decodeUtf8' bs + -> return userDisplayName' + | otherwise + -> throwM CampusUserInvalidDisplayName + userFirstName <- if + | [bs] <- userFirstName' + , Right userFirstName <- Text.decodeUtf8' bs + -> return userFirstName + | otherwise + -> throwM CampusUserInvalidGivenName + userSurname <- if + | [bs] <- userSurname' + , Right userSurname <- Text.decodeUtf8' bs + -> return userSurname + | otherwise + -> throwM CampusUserInvalidSurname + userTitle <- if + | all ByteString.null userTitle' + -> return Nothing + | [bs] <- userTitle' + , Right userTitle <- Text.decodeUtf8' bs + -> return $ Just userTitle + | otherwise + -> throwM CampusUserInvalidTitle + userMatrikelnummer <- if + | [bs] <- userMatrikelnummer' + , Right userMatrikelnummer <- Text.decodeUtf8' bs + -> return $ Just userMatrikelnummer + | [] <- userMatrikelnummer' + -> return Nothing + | otherwise + -> throwM CampusUserInvalidMatriculation + userSex <- if + | [bs] <- userSex' + , Right userSex'' <- Text.decodeUtf8' bs + , Just userSex''' <- readMay userSex'' + , Just userSex <- userSex''' ^? iso5218 + -> return $ Just userSex + | [] <- userSex' + -> return Nothing + | otherwise + -> throwM CampusUserInvalidSex + + let + newUser = User + { userMaxFavourites = userDefaultMaxFavourites + , userMaxFavouriteTerms = userDefaultMaxFavouriteTerms + , userTheme = userDefaultTheme + , userDateTimeFormat = userDefaultDateTimeFormat + , userDateFormat = userDefaultDateFormat + , userTimeFormat = userDefaultTimeFormat + , userDownloadFiles = userDefaultDownloadFiles + , userWarningDays = userDefaultWarningDays + , userShowSex = userDefaultShowSex + , userNotificationSettings = def + , userLanguages = Nothing + , userCsvOptions = def + , userTokensIssuedAfter = Nothing + , userCreated = now + , userLastLdapSynchronisation = Just now + , userDisplayName = userDisplayName' + , userDisplayEmail = userEmail + , .. + } + userUpdate = [ UserMatrikelnummer =. userMatrikelnummer + -- , UserDisplayName =. userDisplayName + , UserFirstName =. userFirstName + , UserSurname =. userSurname + , UserTitle =. userTitle + , UserEmail =. userEmail + , UserSex =. userSex + , UserLastLdapSynchronisation =. Just now + ] ++ + [ UserLastAuthentication =. Just now | isn't _UpsertCampusUserDummy plugin ] + + user@(Entity userId userRec) <- upsertBy (UniqueAuthentication userIdent) newUser userUpdate + unless (validDisplayName userTitle userFirstName userSurname $ userDisplayName userRec) $ + update userId [ UserDisplayName =. userDisplayName' ] + + let + userStudyFeatures = fmap concat . forM userStudyFeatures' $ parseStudyFeatures userId now + userStudyFeatures' = do + (k, v) <- ldapData + guard $ k == ldapUserStudyFeatures + v' <- v + Right str <- return $ Text.decodeUtf8' v' + return str + + termNames = nubBy ((==) `on` CI.mk) $ do + (k, v) <- ldapData + guard $ k == ldapUserFieldName + v' <- v + Right str <- return $ Text.decodeUtf8' v' + return str + + userSubTermsSemesters = forM userSubTermsSemesters' parseSubTermsSemester + userSubTermsSemesters' = do + (k, v) <- ldapData + guard $ k == ldapUserSubTermsSemester + v' <- v + Right str <- return $ Text.decodeUtf8' v' + return str + + fs' <- either (throwM . CampusUserInvalidFeaturesOfStudy . tshow) return userStudyFeatures + sts <- either (throwM . CampusUserInvalidFeaturesOfStudy . tshow) return userSubTermsSemesters + + let + studyTermCandidates = Set.fromList $ do + let sfKeys = unStudyTermsKey . studyFeaturesField <$> fs' + subTermsKeys = unStudyTermsKey . fst <$> sts + + (,) <$> sfKeys ++ subTermsKeys <*> termNames + + let + assimilateSubTerms :: [(StudyTermsId, Int)] -> [StudyFeatures] -> WriterT (Set (StudyTermsId, Maybe StudyTermsId)) (SqlPersistT m) [StudyFeatures] + assimilateSubTerms [] xs = return xs + assimilateSubTerms ((subterm, subSemester) : subterms) unusedFeats = do + standalone <- lift $ get subterm + case standalone of + _other + | (match : matches, unusedFeats') <- partition + (\StudyFeatures{..} -> subterm == studyFeaturesField + && subSemester == studyFeaturesSemester + ) unusedFeats + -> do + $logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}” and matching feature “#{tshow match}”|] + (:) match <$> assimilateSubTerms subterms (matches ++ unusedFeats') + | any ((== subterm) . studyFeaturesField) unusedFeats + -> do + $logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}” due to feature of matching field|] + assimilateSubTerms subterms unusedFeats + Just StudyTerms{..} + | Just defDegree <- studyTermsDefaultDegree + , Just defType <- studyTermsDefaultType + -> do + $logDebugS "Campus" [st|Applying default for standalone study term “#{tshow subterm}”|] + (:) (StudyFeatures userId defDegree subterm Nothing defType subSemester now True) <$> assimilateSubTerms subterms unusedFeats + Nothing + | [] <- unusedFeats -> do + $logDebugS "Campus" [st|Saw subterm “#{tshow subterm}” when no fos-terms remain|] + tell $ Set.singleton (subterm, Nothing) + assimilateSubTerms subterms [] + _other -> do + knownParents <- lift $ map (studySubTermsParent . entityVal) <$> selectList [ StudySubTermsChild ==. subterm ] [] + let matchingFeatures = case knownParents of + [] -> filter ((== subSemester) . studyFeaturesSemester) unusedFeats + ps -> filter (\StudyFeatures{studyFeaturesField, studyFeaturesSemester} -> elem studyFeaturesField ps && studyFeaturesSemester == subSemester) unusedFeats + when (null knownParents) . forM_ matchingFeatures $ \StudyFeatures{..} -> + tell $ Set.singleton (subterm, Just studyFeaturesField) + if + | not $ null knownParents -> do + $logDebugS "Campus" [st|Applying subterm “#{tshow subterm}” to #{tshow matchingFeatures}|] + let setSuperField sf = sf + & _studyFeaturesSuperField %~ (<|> Just (sf ^. _studyFeaturesField)) + & _studyFeaturesField .~ subterm + (++) (map setSuperField matchingFeatures) <$> assimilateSubTerms subterms (unusedFeats List.\\ matchingFeatures) + | otherwise -> do + $logDebugS "Campus" [st|Ignoring subterm “#{tshow subterm}”|] + assimilateSubTerms subterms unusedFeats + $logDebugS "Campus" [st|Terms for “#{userIdent}”: #{tshow (sts, fs')}|] + (fs, studyFieldParentCandidates) <- runWriterT $ assimilateSubTerms sts fs' + + let + studyTermCandidateIncidence + = fromMaybe (error "Could not convert studyTermCandidateIncidence-Hash to UUID") -- Should never happen + . UUID.fromByteString + . fromStrict + . (convert :: Digest (SHAKE128 128) -> ByteString) + . runConduitPure + $ C.yieldMany ((toStrict . Binary.encode <$> Set.toList studyTermCandidates) ++ (toStrict . Binary.encode <$> Set.toList studyFieldParentCandidates)) .| sinkHash + + candidatesRecorded <- E.selectExists . E.from $ \(candidate `E.FullOuterJoin` parentCandidate `E.FullOuterJoin` standaloneCandidate) -> do + E.on $ candidate E.?. StudyTermNameCandidateIncidence E.==. standaloneCandidate E.?. StudyTermStandaloneCandidateIncidence + E.on $ candidate E.?. StudyTermNameCandidateIncidence E.==. parentCandidate E.?. StudySubTermParentCandidateIncidence + E.where_ $ candidate E.?. StudyTermNameCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence) + E.||. parentCandidate E.?. StudySubTermParentCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence) + E.||. standaloneCandidate E.?. StudyTermStandaloneCandidateIncidence E.==. E.just (E.val studyTermCandidateIncidence) + + unless candidatesRecorded $ do + let + studyTermCandidates' = do + (studyTermNameCandidateKey, studyTermNameCandidateName) <- Set.toList studyTermCandidates + let studyTermNameCandidateIncidence = studyTermCandidateIncidence + return StudyTermNameCandidate{..} + insertMany_ studyTermCandidates' + + let + studySubTermParentCandidates' = do + (StudyTermsKey' studySubTermParentCandidateKey, Just (StudyTermsKey' studySubTermParentCandidateParent)) <- Set.toList studyFieldParentCandidates + let studySubTermParentCandidateIncidence = studyTermCandidateIncidence + return StudySubTermParentCandidate{..} + insertMany_ studySubTermParentCandidates' + + let + studyTermStandaloneCandidates' = do + (StudyTermsKey' studyTermStandaloneCandidateKey, Nothing) <- Set.toList studyFieldParentCandidates + let studyTermStandaloneCandidateIncidence = studyTermCandidateIncidence + return StudyTermStandaloneCandidate{..} + insertMany_ studyTermStandaloneCandidates' + + E.updateWhere [StudyFeaturesUser ==. userId] [StudyFeaturesValid =. False] + forM_ fs $ \f@StudyFeatures{..} -> do + insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing + insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing Nothing Nothing + oldFs <- selectKeysList + [ StudyFeaturesUser ==. studyFeaturesUser + , StudyFeaturesDegree ==. studyFeaturesDegree + , StudyFeaturesField ==. studyFeaturesField + , StudyFeaturesType ==. studyFeaturesType + , StudyFeaturesSemester ==. studyFeaturesSemester + ] + [] + case oldFs of + [oldF] -> update oldF + [ StudyFeaturesUpdated =. now + , StudyFeaturesValid =. True + , StudyFeaturesField =. studyFeaturesField + , StudyFeaturesSuperField =. studyFeaturesSuperField + ] + _other -> void $ upsert f + [ StudyFeaturesUpdated =. now + , StudyFeaturesValid =. True + , StudyFeaturesSuperField =. studyFeaturesSuperField + ] + associateUserSchoolsByTerms userId + + let + userAssociatedSchools = concat <$> forM userAssociatedSchools' parseLdapSchools + userAssociatedSchools' = do + (k, v) <- ldapData + guard $ k == ldapUserSchoolAssociation + v' <- v + Right str <- return $ Text.decodeUtf8' v' + return str + + ss <- either (throwM . CampusUserInvalidAssociatedSchools . tshow) return userAssociatedSchools + + forM_ ss $ \frag -> void . runMaybeT $ do + let + exactMatch = MaybeT . getBy $ UniqueOrgUnit frag + infixMatch = (hoistMaybe . preview _head) <=< (lift . E.select . E.from) $ \schoolLdap -> do + E.where_ $ E.val frag `E.isInfixOf` schoolLdap E.^. SchoolLdapOrgUnit + E.&&. E.not_ (E.isNothing $ schoolLdap E.^. SchoolLdapSchool) + return schoolLdap + Entity _ SchoolLdap{..} <- exactMatch <|> infixMatch + ssh <- hoistMaybe schoolLdapSchool + + lift . void $ insertUnique UserSchool + { userSchoolUser = userId + , userSchoolSchool = ssh + , userSchoolIsOptOut = False + } + + forM_ ss $ void . insertUnique . SchoolLdap Nothing + + return user + where + insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ()) + +associateUserSchoolsByTerms :: MonadIO m => UserId -> SqlPersistT m () +associateUserSchoolsByTerms uid = do + sfs <- selectList [StudyFeaturesUser ==. uid] [] + + forM_ sfs $ \(Entity _ StudyFeatures{..}) -> do + schoolTerms <- selectList [SchoolTermsTerms ==. studyFeaturesField] [] + forM_ schoolTerms $ \(Entity _ SchoolTerms{..}) -> + void $ insertUnique UserSchool + { userSchoolUser = uid + , userSchoolSchool = schoolTermsSchool + , userSchoolIsOptOut = False + } + +updateUserLanguage :: ( MonadHandler m, HandlerSite m ~ UniWorX + , YesodAuth UniWorX + , UserId ~ AuthId UniWorX + ) + => Maybe Lang -> SqlPersistT m (Maybe Lang) +updateUserLanguage (Just lang) = do + unless (lang `elem` appLanguages) $ + invalidArgs ["Unsupported language"] + + muid <- maybeAuthId + for_ muid $ \uid -> do + langs <- languages + update uid [ UserLanguages =. Just (Languages $ lang : nub (filter ((&&) <$> (`elem` appLanguages) <*> (/= lang)) langs)) ] + setRegisteredCookie CookieLang lang + return $ Just lang +updateUserLanguage Nothing = runMaybeT $ do + uid <- MaybeT maybeAuthId + User{..} <- MaybeT $ get uid + setLangs <- toList . selectLanguages appLanguages <$> languages + highPrioSetLangs <- toList . selectLanguages appLanguages <$> highPrioRequestedLangs + let userLanguages' = toList . selectLanguages appLanguages <$> userLanguages ^? _Just . _Wrapped + lang <- case (userLanguages', setLangs, highPrioSetLangs) of + (_, _, hpl : _) + -> lift $ hpl <$ update uid [ UserLanguages =. Just (Languages highPrioSetLangs) ] + (Just (l : _), _, _) + -> return l + (Nothing, l : _, _) + -> lift $ l <$ update uid [ UserLanguages =. Just (Languages setLangs) ] + (Just [], l : _, _) + -> return l + (_, [], _) + -> mzero + setRegisteredCookie CookieLang lang + return lang + +campusUserFailoverMode :: FailoverMode +campusUserFailoverMode = FailoverUnlimited + +embedRenderMessage ''UniWorX ''CampusUserConversionException id diff --git a/src/Foundation/Yesod/ErrorHandler.hs b/src/Foundation/Yesod/ErrorHandler.hs new file mode 100644 index 000000000..025b4098d --- /dev/null +++ b/src/Foundation/Yesod/ErrorHandler.hs @@ -0,0 +1,90 @@ +module Foundation.Yesod.ErrorHandler + ( errorHandler + ) where + +import Import.NoFoundation hiding (errorHandler) + +import Utils.Form + +import Foundation.Type +import Foundation.I18n +import Foundation.Authorization +import Foundation.SiteLayout +import Foundation.Routes + +import qualified Data.Aeson as JSON +import qualified Data.Text as Text + + +errorHandler :: ( MonadSecretBox (HandlerFor UniWorX) + , MonadSecretBox (WidgetFor UniWorX) + , BearerAuthSite UniWorX + , Button UniWorX ButtonSubmit + , BackendCompatible SqlBackend (YesodPersistBackend UniWorX) + ) + => ErrorResponse -> HandlerFor UniWorX TypedContent +errorHandler err = do + shouldEncrypt <- do + canDecrypt <- (== Authorized) <$> evalAccess AdminErrMsgR True + shouldEncrypt <- getsYesod $ view _appEncryptErrors + return $ shouldEncrypt && not canDecrypt + + sessErr <- bool return (_InternalError $ encodedSecretBox SecretBoxShort) shouldEncrypt err + setSessionJson SessionError sessErr + + selectRep $ do + provideRep $ do + mr <- getMessageRender + let + encrypted :: ToJSON a => a -> WidgetFor UniWorX () -> WidgetFor UniWorX () + encrypted plaintextJson plaintext = do + if + | shouldEncrypt -> do + ciphertext <- encodedSecretBox SecretBoxPretty plaintextJson + + [whamlet| +
_{MsgErrorResponseEncrypted} +
+ #{ciphertext}
+ |]
+ | otherwise -> plaintext
+
+ errPage = case err of
+ NotFound -> [whamlet|_{MsgErrorResponseNotFound}|]
+ InternalError err' -> encrypted err' [whamlet|
#{err'}|]
+ InvalidArgs errs -> [whamlet|
+
_{MsgErrorResponseNotAuthenticated}|] + PermissionDenied err' -> [whamlet|
#{err'}|] + BadMethod method -> [whamlet|
_{MsgErrorResponseBadMethod (decodeUtf8 method)}|]
+ siteLayout (toWgt . mr $ ErrorResponseTitle err) $ do
+ toWidget
+ [cassius|
+ .errMsg
+ white-space: pre-wrap
+ font-family: monospace
+ |]
+ errPage
+ provideRep . fmap PrettyValue $ case err of
+ PermissionDenied err' -> return $ object [ "message" JSON..= err' ]
+ InternalError err'
+ | shouldEncrypt -> do
+ ciphertext <- encodedSecretBox SecretBoxShort err'
+ return $ object [ "message" JSON..= ciphertext
+ , "encrypted" JSON..= True
+ ]
+ | otherwise -> return $ object [ "message" JSON..= err' ]
+ InvalidArgs errs -> return $ object [ "messages" JSON..= errs ]
+ _other -> return $ object []
+ provideRep $ case err of
+ PermissionDenied err' -> return err'
+ InternalError err'
+ | shouldEncrypt -> do
+ addHeader "Encrypted-Error-Message" "True"
+ encodedSecretBox SecretBoxPretty err'
+ | otherwise -> return err'
+ InvalidArgs errs -> return . Text.unlines . map (Text.replace "\n" "\n\t") $ errs
+ _other -> return Text.empty
diff --git a/src/Foundation/Yesod/Middleware.hs b/src/Foundation/Yesod/Middleware.hs
new file mode 100644
index 000000000..6ba2b61ca
--- /dev/null
+++ b/src/Foundation/Yesod/Middleware.hs
@@ -0,0 +1,251 @@
+module Foundation.Yesod.Middleware
+ ( yesodMiddleware
+ , updateFavourites
+ ) where
+
+import Import.NoFoundation hiding (yesodMiddleware)
+
+import Foundation.Type
+import Foundation.Routes
+import Foundation.I18n
+import Foundation.Authorization
+
+import Utils.Metrics
+
+import qualified Network.Wai as W
+import qualified Data.Aeson as JSON
+import qualified Data.CaseInsensitive as CI
+
+import Control.Monad.Reader.Class (MonadReader(..))
+import Control.Monad.Writer.Class (MonadWriter(..))
+
+import Yesod.Core.Types (GHState(..), HandlerData(..), RunHandlerEnv(rheSite, rheChild))
+
+
+yesodMiddleware :: ( BearerAuthSite UniWorX
+ , BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX)
+ , BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
+ )
+ => HandlerFor UniWorX res -> HandlerFor UniWorX res
+yesodMiddleware = storeBearerMiddleware . csrfMiddleware . dryRunMiddleware . observeYesodCacheSizeMiddleware . languagesMiddleware appLanguages . headerMessagesMiddleware . defaultYesodMiddleware . normalizeRouteMiddleware . updateFavouritesMiddleware
+ where
+ dryRunMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
+ dryRunMiddleware handler = do
+ dryRun <- isDryRun
+ if | dryRun -> do
+ hData <- ask
+ prevState <- readIORef (handlerState hData)
+ let
+ restoreSession =
+ modifyIORef (handlerState hData) $
+ \hst -> hst { ghsSession = ghsSession prevState
+ , ghsCache = ghsCache prevState
+ , ghsCacheBy = ghsCacheBy prevState
+ }
+ site' = (rheSite $ handlerEnv hData) { appMemcached = Nothing }
+ handler' = local (\hd -> hd { handlerEnv = (handlerEnv hd) { rheSite = site', rheChild = site' } }) handler
+
+ addCustomHeader HeaderDryRun $ toPathPiece True
+
+ handler' `finally` restoreSession
+ | otherwise -> handler
+ updateFavouritesMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
+ updateFavouritesMiddleware handler = (*> handler) . runMaybeT $ do
+ route <- MaybeT getCurrentRoute
+ case route of -- update Course Favourites here
+ CourseR tid ssh csh _ -> do
+ void . lift . runDB . runMaybeT $ do
+ guardM . lift $ (== Authorized) <$> evalAccessDB (CourseR tid ssh csh CShowR) False
+ lift . updateFavourites $ Just (tid, ssh, csh)
+ _other -> return ()
+ normalizeRouteMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
+ normalizeRouteMiddleware handler = (*> handler) . runMaybeT $ do
+ route <- MaybeT getCurrentRoute
+ (route', getAny -> changed) <- lift . runDB . runWriterT $ foldM (&) route routeNormalizers
+ when changed $ do
+ $logDebugS "normalizeRouteMiddleware" [st|Redirecting to #{tshow route'}|]
+ redirectWith movedPermanently301 route'
+ headerMessagesMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
+ headerMessagesMiddleware handler = (handler `finally`) . runMaybeT $ do
+ isModal <- hasCustomHeader HeaderIsModal
+ dbTableShortcircuit <- hasCustomHeader HeaderDBTableShortcircuit
+ massInputShortcircuit <- hasCustomHeader HeaderMassInputShortcircuit
+ $logDebugS "headerMessagesMiddleware" $ tshow (isModal, dbTableShortcircuit, massInputShortcircuit)
+ guard $ or
+ [ isModal
+ , dbTableShortcircuit
+ , massInputShortcircuit
+ ]
+
+ lift . bracketOnError getMessages (mapM_ addMessage') $
+ addCustomHeader HeaderAlerts . decodeUtf8 . urlEncode True . toStrict . JSON.encode
+ observeYesodCacheSizeMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
+ observeYesodCacheSizeMiddleware handler = handler `finally` observeYesodCacheSize
+ csrfMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
+ csrfMiddleware handler = do
+ hasBearer <- is _Just <$> lookupBearerAuth
+
+ if | hasBearer -> local (\HandlerData{..} -> HandlerData{ handlerRequest = handlerRequest { reqToken = Nothing }, .. }) handler
+ | otherwise -> csrfSetCookieMiddleware' . defaultCsrfCheckMiddleware $ handler
+ where
+ csrfSetCookieMiddleware' handler' = do
+ mcsrf <- reqToken <$> getRequest
+ whenIsJust mcsrf $ setRegisteredCookie CookieXSRFToken
+ handler'
+ storeBearerMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
+ storeBearerMiddleware handler = do
+ askBearer >>= \case
+ Just (Jwt bs) -> setSessionBS (toPathPiece SessionBearer) bs
+ Nothing -> return ()
+
+ handler
+
+updateFavourites :: forall m backend.
+ ( MonadHandler m, HandlerSite m ~ UniWorX
+ , BackendCompatible SqlBackend backend
+ , YesodAuth UniWorX
+ , UserId ~ AuthId UniWorX
+ )
+ => Maybe (TermId, SchoolId, CourseShorthand) -- ^ Insert course into favourites, as appropriate
+ -> ReaderT backend m ()
+updateFavourites cData = void . withReaderT projectBackend . runMaybeT $ do
+ $logDebugS "updateFavourites" "Updating favourites"
+
+ now <- liftIO getCurrentTime
+ uid <- MaybeT $ liftHandler maybeAuthId
+ mcid <- (for cData $ \(tid, ssh, csh) -> MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh) :: MaybeT (SqlPersistT m) (Maybe CourseId)
+ User{userMaxFavourites} <- MaybeT $ get uid
+
+ -- update Favourites
+ for_ mcid $ \cid ->
+ void . lift $ upsertBy
+ (UniqueCourseFavourite uid cid)
+ (CourseFavourite uid cid FavouriteVisited now)
+ [CourseFavouriteLastVisit =. now]
+ -- prune Favourites to user-defined size
+ oldFavs <- lift $ selectList [CourseFavouriteUser ==. uid] []
+ let deleteFavs = oldFavs
+ & sortOn ((courseFavouriteReason &&& Down . courseFavouriteLastVisit) . entityVal)
+ & drop userMaxFavourites
+ & filter ((<= FavouriteVisited) . courseFavouriteReason . entityVal)
+ & map entityKey
+ unless (null deleteFavs) $
+ lift $ deleteWhere [CourseFavouriteId <-. deleteFavs]
+
+
+routeNormalizers :: forall m backend.
+ ( BackendCompatible SqlReadBackend backend
+ , MonadHandler m, HandlerSite m ~ UniWorX
+ , BearerAuthSite UniWorX
+ ) => [Route UniWorX -> WriterT Any (ReaderT backend m) (Route UniWorX)]
+routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) .)
+ [ normalizeRender
+ , ncSchool
+ , ncAllocation
+ , ncCourse
+ , ncSheet
+ , ncMaterial
+ , ncTutorial
+ , ncExam
+ , ncExternalExam
+ , verifySubmission
+ , verifyCourseApplication
+ , verifyCourseNews
+ ]
+ where
+ normalizeRender :: Route UniWorX -> WriterT Any (ReaderT SqlReadBackend (HandlerFor UniWorX)) (Route UniWorX)
+ normalizeRender route = route <$ do
+ YesodRequest{..} <- liftHandler getRequest
+ let original = (W.pathInfo reqWaiRequest, reqGetParams)
+ rendered = renderRoute route
+ if
+ | (isSuffixOf `on` fst) original rendered -> do -- FIXME: this breaks when subsite prefixes are dynamic
+ $logDebugS "normalizeRender" [st|#{tshow rendered} matches #{tshow original}|]
+ | otherwise -> do
+ $logDebugS "normalizeRender" [st|Redirecting because #{tshow rendered} does not match #{tshow original}|]
+ tell $ Any True
+
+ maybeOrig :: (Route UniWorX -> MaybeT (WriterT Any (ReaderT SqlReadBackend (HandlerFor UniWorX))) (Route UniWorX))
+ -> Route UniWorX -> WriterT Any (ReaderT SqlReadBackend (HandlerFor UniWorX)) (Route UniWorX)
+ maybeOrig f route = maybeT (return route) $ f route
+
+ caseChanged :: (Eq a, Show a) => CI a -> CI a -> MaybeT (WriterT Any (ReaderT SqlReadBackend (HandlerFor UniWorX))) ()
+ caseChanged a b
+ | ((/=) `on` CI.original) a b = do
+ $logDebugS "routeNormalizers" [st|#{tshow a} /= #{tshow b}|]
+ tell $ Any True
+ | otherwise = return ()
+
+ ncSchool = maybeOrig . typesUsing @RouteChildren @SchoolId $ \ssh -> $cachedHereBinary ssh $ do
+ let schoolShort :: SchoolShorthand
+ schoolShort = unSchoolKey ssh
+ Entity ssh' _ <- MaybeT . lift . getBy $ UniqueSchoolShorthand schoolShort
+ (caseChanged `on` unSchoolKey) ssh ssh'
+ return ssh'
+ ncAllocation = maybeOrig $ \route -> do
+ AllocationR tid ssh ash _ <- return route
+ Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . lift . getBy $ TermSchoolAllocationShort tid ssh ash
+ caseChanged ash allocationShorthand
+ return $ route & typesUsing @RouteChildren @AllocationShorthand . filtered (== ash) .~ allocationShorthand
+ ncCourse = maybeOrig $ \route -> do
+ CourseR tid ssh csh _ <- return route
+ Entity _ Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh
+ caseChanged csh courseShorthand
+ return $ route & typesUsing @RouteChildren @CourseShorthand . filtered (== csh) .~ courseShorthand
+ ncSheet = maybeOrig $ \route -> do
+ CSheetR tid ssh csh shn _ <- return route
+ cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
+ Entity _ Sheet{..} <- MaybeT . $cachedHereBinary (cid, shn) . lift . getBy $ CourseSheet cid shn
+ caseChanged shn sheetName
+ return $ route & typesUsing @RouteChildren @SheetName . filtered (== shn) .~ sheetName
+ ncMaterial = maybeOrig $ \route -> do
+ CMaterialR tid ssh csh mnm _ <- return route
+ cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
+ Entity _ Material{..} <- MaybeT . $cachedHereBinary (cid, mnm) . lift . getBy $ UniqueMaterial cid mnm
+ caseChanged mnm materialName
+ return $ route & typesUsing @RouteChildren @MaterialName . filtered (== mnm) .~ materialName
+ ncTutorial = maybeOrig $ \route -> do
+ CTutorialR tid ssh csh tutn _ <- return route
+ cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
+ Entity _ Tutorial{..} <- MaybeT . $cachedHereBinary (cid, tutn) . lift . getBy $ UniqueTutorial cid tutn
+ caseChanged tutn tutorialName
+ return $ route & typesUsing @RouteChildren @TutorialName . filtered (== tutn) .~ tutorialName
+ ncExam = maybeOrig $ \route -> do
+ CExamR tid ssh csh examn _ <- return route
+ cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getKeyBy $ TermSchoolCourseShort tid ssh csh
+ Entity _ Exam{..} <- MaybeT . $cachedHereBinary (cid, examn) . lift . getBy $ UniqueExam cid examn
+ caseChanged examn examName
+ return $ route & typesUsing @RouteChildren @ExamName . filtered (== examn) .~ examName
+ ncExternalExam = maybeOrig $ \route -> do
+ EExamR tid ssh coursen examn _ <- return route
+ Entity _ ExternalExam{..} <- MaybeT . $cachedHereBinary (tid, ssh, coursen, examn) . lift . getBy $ UniqueExternalExam tid ssh coursen examn
+ caseChanged coursen externalExamCourseName
+ caseChanged examn externalExamExamName
+ return $ route
+ & typesUsing @RouteChildren @CourseName . filtered (== coursen) .~ externalExamCourseName
+ & typesUsing @RouteChildren @ExamName . filtered (== examn) .~ externalExamExamName
+ verifySubmission = maybeOrig $ \route -> do
+ CSubmissionR _tid _ssh _csh _shn cID sr <- return route
+ sId <- $cachedHereBinary cID $ decrypt cID
+ Submission{submissionSheet} <- MaybeT . $cachedHereBinary cID . lift $ get sId
+ Sheet{sheetCourse, sheetName} <- MaybeT . $cachedHereBinary submissionSheet . lift $ get submissionSheet
+ Course{courseTerm, courseSchool, courseShorthand} <- MaybeT . $cachedHereBinary sheetCourse . lift $ get sheetCourse
+ let newRoute = CSubmissionR courseTerm courseSchool courseShorthand sheetName cID sr
+ tell . Any $ route /= newRoute
+ return newRoute
+ verifyCourseApplication = maybeOrig $ \route -> do
+ CApplicationR _tid _ssh _csh cID sr <- return route
+ aId <- decrypt cID
+ CourseApplication{courseApplicationCourse} <- lift . lift $ get404 aId
+ Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 courseApplicationCourse
+ let newRoute = CApplicationR courseTerm courseSchool courseShorthand cID sr
+ tell . Any $ route /= newRoute
+ return newRoute
+ verifyCourseNews = maybeOrig $ \route -> do
+ CNewsR _tid _ssh _csh cID sr <- return route
+ aId <- decrypt cID
+ CourseNews{courseNewsCourse} <- lift . lift $ get404 aId
+ Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 courseNewsCourse
+ let newRoute = CNewsR courseTerm courseSchool courseShorthand cID sr
+ tell . Any $ route /= newRoute
+ return newRoute
diff --git a/src/Foundation/Yesod/Persist.hs b/src/Foundation/Yesod/Persist.hs
new file mode 100644
index 000000000..98462eda7
--- /dev/null
+++ b/src/Foundation/Yesod/Persist.hs
@@ -0,0 +1,44 @@
+module Foundation.Yesod.Persist
+ ( runDB, getDBRunner
+ , module Foundation.DB
+ ) where
+
+import Import.NoFoundation hiding (runDB, getDBRunner)
+
+import Foundation.Type
+import Foundation.DB
+import Foundation.Authorization
+
+import Database.Persist.Sql (transactionUndo)
+
+
+runDB :: ( YesodPersistBackend UniWorX ~ SqlBackend
+ , BearerAuthSite UniWorX
+ )
+ => YesodDB UniWorX a -> HandlerFor UniWorX a
+runDB action = do
+ -- stack <- liftIO currentCallStack
+ -- $logDebugS "YesodPersist" . unlines $ "runDB" : map pack stack
+ $logDebugS "YesodPersist" "runDB"
+ dryRun <- isDryRun
+ let action'
+ | dryRun = action <* transactionUndo
+ | otherwise = action
+
+ runSqlPoolRetry action' . appConnPool =<< getYesod
+
+getDBRunner :: ( YesodPersistBackend UniWorX ~ SqlBackend
+ , BearerAuthSite UniWorX
+ )
+ => HandlerFor UniWorX (DBRunner UniWorX, HandlerFor UniWorX ())
+getDBRunner = do
+ (DBRunner{..}, cleanup) <- defaultGetDBRunner appConnPool
+ return . (, cleanup) $ DBRunner
+ (\action -> do
+ dryRun <- isDryRun
+ let action'
+ | dryRun = action <* transactionUndo
+ | otherwise = action
+ $logDebugS "YesodPersist" "runDBRunner"
+ runDBRunner action'
+ )
diff --git a/src/Foundation/Yesod/Session.hs b/src/Foundation/Yesod/Session.hs
new file mode 100644
index 000000000..f8ed7274d
--- /dev/null
+++ b/src/Foundation/Yesod/Session.hs
@@ -0,0 +1,62 @@
+module Foundation.Yesod.Session
+ ( makeSessionBackend
+ ) where
+
+import Import.NoFoundation hiding (makeSessionBackend)
+
+import Foundation.Type
+
+import qualified Web.ServerSession.Core as ServerSession
+import qualified Web.ServerSession.Frontend.Yesod.Jwt as JwtSession
+
+import qualified Network.Wai as W
+import qualified Network.HTTP.Types.Header as W
+import qualified Network.Wai.Middleware.HttpAuth as W (extractBearerAuth)
+
+import Web.Cookie
+
+
+makeSessionBackend :: Yesod UniWorX => UniWorX -> IO (Maybe SessionBackend)
+makeSessionBackend app@UniWorX{ appSettings' = AppSettings{..}, ..} = notForBearer . sameSite $ case appSessionStore of
+ SessionStorageMemcachedSql sqlStore
+ -> mkBackend . stateSettings =<< ServerSession.createState sqlStore
+ SessionStorageAcid acidStore
+ | appServerSessionAcidFallback
+ -> mkBackend . stateSettings =<< ServerSession.createState acidStore
+ _other
+ -> return Nothing
+ where
+ cfg = JwtSession.ServerSessionJwtConfig
+ { sJwtJwkSet = appJSONWebKeySet
+ , sJwtStart = Nothing
+ , sJwtExpiration = appSessionTokenExpiration
+ , sJwtEncoding = appSessionTokenEncoding
+ , sJwtIssueBy = appInstanceID
+ , sJwtIssueFor = appClusterID
+ }
+ mkBackend :: forall sto.
+ ( ServerSession.SessionData sto ~ Map Text ByteString
+ , ServerSession.Storage sto
+ )
+ => ServerSession.State sto -> IO (Maybe SessionBackend)
+ mkBackend = JwtSession.backend cfg (JwtSession.siteApproot app)
+ stateSettings :: forall sto. ServerSession.State sto -> ServerSession.State sto
+ stateSettings = ServerSession.setCookieName (toPathPiece CookieSession) . applyServerSessionSettings appServerSessionConfig
+ sameSite
+ | Just sameSiteStrict == cookieSameSite (getCookieSettings app CookieSession)
+ = strictSameSiteSessions
+ | Just sameSiteLax == cookieSameSite (getCookieSettings app CookieSession)
+ = laxSameSiteSessions
+ | otherwise
+ = id
+ notForBearer :: IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)
+ notForBearer = fmap $ fmap notForBearer'
+ where notForBearer' :: SessionBackend -> SessionBackend
+ notForBearer' (SessionBackend load)
+ = let load' req
+ | aHdrs <- mapMaybe (\(h, v) -> v <$ guard (h == W.hAuthorization)) $ W.requestHeaders req
+ , any (is _Just . W.extractBearerAuth) aHdrs
+ = return (mempty, const $ return [])
+ | otherwise
+ = load req
+ in SessionBackend load'
diff --git a/src/Foundation/Yesod/StaticContent.hs b/src/Foundation/Yesod/StaticContent.hs
new file mode 100644
index 000000000..a60ace7ff
--- /dev/null
+++ b/src/Foundation/Yesod/StaticContent.hs
@@ -0,0 +1,49 @@
+module Foundation.Yesod.StaticContent
+ ( addStaticContent
+ ) where
+
+import Import.NoFoundation hiding (addStaticContent)
+
+import Foundation.Type
+
+import qualified Database.Memcached.Binary.IO as Memcached
+
+import qualified Data.ByteString.Lazy as Lazy
+import qualified Data.ByteString.Base64.URL as Base64 (encodeUnpadded)
+import Data.ByteArray (convert)
+import Crypto.Hash (SHAKE256)
+import Crypto.Hash.Conduit (sinkHash)
+import Data.Bits (Bits(zeroBits))
+
+import qualified Data.Conduit.Combinators as C
+
+
+addStaticContent :: Text
+ -> Text
+ -> Lazy.ByteString
+ -> HandlerFor UniWorX (Maybe (Either Text (Route UniWorX, [(Text, Text)])))
+addStaticContent ext _mime content = do
+ UniWorX{appWidgetMemcached, appSettings'} <- getYesod
+ for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings') $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConf = MemcachedConf { memcachedExpiry }, widgetMemcachedBaseUrl }) -> do
+ let expiry = maybe 0 ceiling memcachedExpiry
+ touch = liftIO $ Memcached.touch expiry (encodeUtf8 $ pack fileName) mConn
+ add = liftIO $ Memcached.add zeroBits expiry (encodeUtf8 $ pack fileName) content mConn
+ absoluteLink = unpack widgetMemcachedBaseUrl fileName
+ catchIf Memcached.isKeyNotFound touch . const $
+ handleIf Memcached.isKeyExists (const $ return ()) add
+ return . Left $ pack absoluteLink
+ where
+ -- Generate a unique filename based on the content itself, this is used
+ -- for deduplication so a collision resistant hash function is required
+ --
+ -- SHA-3 (SHAKE256) seemed to be a future-proof choice
+ --
+ -- Length of hash is 144 bits ~~instead of MD5's 128, so as to avoid
+ -- padding after base64-conversion~~ for backwards compatability
+ fileName = (<.> unpack ext)
+ . unpack
+ . decodeUtf8
+ . Base64.encodeUnpadded
+ . (convert :: Digest (SHAKE256 144) -> ByteString)
+ . runConduitPure
+ $ C.sourceLazy content .| sinkHash
diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs
index 67b387cd3..18be649b1 100644
--- a/src/Handler/Admin.hs
+++ b/src/Handler/Admin.hs
@@ -4,8 +4,6 @@ module Handler.Admin
import Import
-import Handler.Utils
-
import Handler.Admin.Test as Handler.Admin
import Handler.Admin.ErrorMessage as Handler.Admin
import Handler.Admin.StudyFeatures as Handler.Admin
diff --git a/src/Handler/Admin/StudyFeatures.hs b/src/Handler/Admin/StudyFeatures.hs
index 0dfd105b8..f4f40c7fb 100644
--- a/src/Handler/Admin/StudyFeatures.hs
+++ b/src/Handler/Admin/StudyFeatures.hs
@@ -47,7 +47,7 @@ embedRenderMessage ''UniWorX ''ButtonAdminStudyTermsParents id
instance Button UniWorX ButtonAdminStudyTermsParents where
btnClasses BtnParentCandidatesInfer = [BCIsButton, BCPrimary]
btnClasses BtnParentCandidatesDeleteAll = [BCIsButton, BCDanger]
-
+
data ButtonAdminStudyTermsStandalone
= BtnStandaloneCandidatesDeleteRedundant
| BtnStandaloneCandidatesDeleteAll
@@ -62,7 +62,7 @@ instance Button UniWorX ButtonAdminStudyTermsStandalone where
btnClasses BtnStandaloneCandidatesDeleteRedundant = [BCIsButton, BCPrimary]
btnClasses BtnStandaloneCandidatesDeleteAll = [BCIsButton, BCDanger]
-
+
{-# ANN postAdminFeaturesR ("HLint: ignore Redundant void" :: String) #-}
getAdminFeaturesR, postAdminFeaturesR :: Handler Html
getAdminFeaturesR = postAdminFeaturesR
@@ -147,7 +147,7 @@ postAdminFeaturesR = do
deleteWhere ([] :: [Filter StudyTermStandaloneCandidate])
addMessageI Success MsgAllStandaloneIncidencesDeleted
redirect AdminFeaturesR
-
+
newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson SessionNewStudyTerms
badStudyTermKeys <- lookupSessionJson SessionConflictingStudyTerms
@@ -208,7 +208,7 @@ postAdminFeaturesR = do
infRedundantStandalone <- Candidates.removeRedundantStandalone
unless (null infRedundantStandalone) . addMessageI Info . MsgRedundantStandaloneCandidatesRemoved $ length infRedundantStandalone
return updated
-
+
let newKeys = catMaybes $ Map.elems updated
unless (null newKeys) $ do
setSessionJson SessionNewStudyTerms newKeys
@@ -247,19 +247,19 @@ postAdminFeaturesR = do
=> Lens' a (Maybe Text)
-> Getter (DBRow r) (Maybe Text)
-> Getter (DBRow r) i
- -> DBRow r
+ -> DBRow r
-> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
textInputCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
(\row _mkUnique -> bimap (fmap $ set lensRes . assertM (not . Text.null)) fvWidget
<$> mopt (textField & cfStrip) "" (Just $ row ^. lensDefault)
)
-
+
checkboxCell :: Ord i
=> Lens' a Bool
-> Getter (DBRow r) Bool
-> Getter (DBRow r) i
- -> DBRow r
- -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
+ -> DBRow r
+ -> DBCell (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult i a (DBRow r)))
checkboxCell lensRes lensDefault lensIndex = formCell id (return . view lensIndex)
( \row _mkUnique -> bimap (fmap $ set lensRes) fvWidget
<$> mpopt checkBoxField "" (Just $ row ^. lensDefault)
@@ -306,7 +306,7 @@ postAdminFeaturesR = do
( \row _mkUnique -> bimap (fmap $ set lensRes) fvWidget
<$> mopt degreeField "" (Just $ row ^. lensDefault)
)
-
+
fieldTypeCell :: Ord i
=> Lens' a (Maybe StudyFieldType)
-> Getter (DBRow r) (Maybe StudyFieldType)
@@ -359,7 +359,7 @@ postAdminFeaturesR = do
fieldSchools <- fmap (setOf $ folded . _Value) . E.select . E.from $ \school -> do
E.where_ . E.exists . E.from $ \schoolTerms ->
E.where_ $ schoolTerms E.^. SchoolTermsSchool E.==. school E.^. SchoolId
- E.&&. schoolTerms E.^. SchoolTermsTerms E.==. E.val fId
+ E.&&. schoolTerms E.^. SchoolTermsTerms E.==. E.val fId
E.where_ $ school E.^. SchoolShorthand `E.in_` E.valList (toListOf (folded . _entityKey . _SchoolId) schools)
return $ school E.^. SchoolId
fieldParents <- fmap (setOf folded) . E.select . E.from $ \terms -> do
diff --git a/src/Handler/Admin/Test/Download.hs b/src/Handler/Admin/Test/Download.hs
index a6efc04ef..dc02ae8e0 100644
--- a/src/Handler/Admin/Test/Download.hs
+++ b/src/Handler/Admin/Test/Download.hs
@@ -45,10 +45,10 @@ testDownloadForm = identifyForm FIDTestDownload . renderWForm FormStandard $ do
maxSizeRes <- wreq intField (fslI MsgTestDownloadMaxSize) . Just $ 2 * 2^30
modeRes <- wpopt (selectField optionsFinite) (fslI MsgTestDownloadMode) $ Just TestDownloadDirect
-
+
return $ TestDownloadOptions
- <$> pure randomSeed
- <*> maxSizeRes
+ randomSeed
+ <$> maxSizeRes
<*> pure (2^20)
<*> modeRes
@@ -86,7 +86,7 @@ testDownload = do
sourceDBFiles = E.selectSource . E.from $ \fileContent -> do
E.orderBy [E.asc $ E.random_ @Int64]
return fileContent
-
+
takeLimit n | n <= 0 = return ()
takeLimit n = do
c <- await
diff --git a/src/Handler/Admin/Tokens.hs b/src/Handler/Admin/Tokens.hs
index 4a9427598..826f42f79 100644
--- a/src/Handler/Admin/Tokens.hs
+++ b/src/Handler/Admin/Tokens.hs
@@ -30,7 +30,7 @@ bearerTokenForm :: WForm Handler (FormResult BearerTokenForm)
bearerTokenForm = do
muid <- maybeAuthId
mr <- getMessageRender
-
+
btfAuthorityGroups <- aFormToWForm $ HashSet.fromList . map Left <$> massInputListA pathPieceField (const "") MsgBearerTokenAuthorityGroupMissing (\p -> Just . SomeRoute $ AdminTokensR :#: p) ("token-groups" :: Text) (fslI MsgBearerTokenAuthorityGroups & setTooltip MsgBearerTokenAuthorityGroupsTip) False Nothing
btfAuthorityUsers <- fmap (fmap . ofoldMap $ HashSet.singleton . Right) <$> wopt (checkMap (foldMapM $ fmap Set.singleton . left MsgBearerTokenAuthorityUnknownUser) (Set.map Right) $ multiUserField False Nothing) (fslpI MsgBearerTokenAuthorityUsers (mr MsgLdapIdentificationOrEmail) & setTooltip MsgBearerTokenAuthorityUsersTip) (Just $ Set.singleton <$> muid)
let btfAuthority' :: FormResult (HashSet (Either UserGroupName UserId))
@@ -58,7 +58,7 @@ bearerTokenForm = do
miLayout' :: MassInputLayout ListLength (Route UniWorX, Value) (Route UniWorX, Value)
miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/token-restrictions/layout")
-
+
btfRestrict' <- fmap HashMap.fromList <$> btfRestrictForm
btfAddAuth' <- fmap (assertM $ not . Set.null . dnfTerms) <$> wopt pathPieceField (fslI MsgBearerTokenAdditionalAuth & setTooltip MsgBearerTokenAdditionalAuthTip) Nothing
@@ -87,8 +87,8 @@ postAdminTokensR = do
& HashSet.map (left toJSON)
fmap Just . encodeBearer . set _bearerRestrictions btfRestrict =<< bearerToken btfAuthority' btfRoutes btfAddAuth btfExpiresAt btfStartsAt
-
- siteLayoutMsg' MsgMenuAdminTokens $ do
+
+ siteLayoutMsg MsgMenuAdminTokens $ do
setTitleI MsgMenuAdminTokens
let bearerForm = wrapForm bearerView def
diff --git a/src/Handler/Allocation/Accept.hs b/src/Handler/Allocation/Accept.hs
index 59ea952d2..d6b1c47d3 100644
--- a/src/Handler/Allocation/Accept.hs
+++ b/src/Handler/Allocation/Accept.hs
@@ -33,7 +33,7 @@ newtype SessionDataAllocationResults = SessionDataAllocationResults
deriving (Monoid, Semigroup) via Dual (Map (TermId, SchoolId, AllocationShorthand) (UTCTime, AllocationFingerprint, Set (UserId, CourseId), Seq MatchingLogRun))
makeWrapped ''SessionDataAllocationResults
-
+
data AllocationAcceptButton
= BtnAllocationAccept
@@ -59,7 +59,7 @@ allocationAcceptForm aId = runMaybeT $ do
let applications = E.subSelectCount . E.from $ \courseApplication ->
E.where_ $ courseApplication E.^. CourseApplicationAllocation E.==. E.val (Just aId)
E.&&. courseApplication E.^. CourseApplicationUser E.==. allocationUser E.^. AllocationUserUser
- return . (allocationUser E.^. AllocationUserUser, ) $ E.case_
+ return . (allocationUser E.^. AllocationUserUser, ) $ E.case_
[ E.when_ (E.castNum (allocationUser E.^. AllocationUserTotalCourses) E.>. applications)
E.then_ (applications :: E.SqlExpr (E.Value Int))
]
@@ -124,7 +124,7 @@ allocationAcceptForm aId = runMaybeT $ do
= invDualHeat (optimumAllocated capN) capN
degenerateHeat capN
= capN <= optimumAllocated capN
-
+
return (prevAllocMatches, $(widgetFile "allocation/accept"))
getAAcceptR, postAAcceptR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html
@@ -135,7 +135,7 @@ postAAcceptR tid ssh ash = do
acceptForm <- maybe (redirect $ AllocationR tid ssh ash AComputeR) return =<< allocationAcceptForm aId
- formRes@((acceptRes, _), _) <- liftHandler $ runFormPost acceptForm
+ formRes@((acceptRes, _), _) <- liftHandler $ runFormPost acceptForm
didStore <- formResultMaybe acceptRes $ \(now, allocFp, allocMatchings, allocLog) -> do
modifySessionJson SessionAllocationResults . fmap (assertM $ not . views _Wrapped onull) . over (mapped . _Wrapped :: Setter' (Maybe SessionDataAllocationResults) _) $
diff --git a/src/Handler/Allocation/Application.hs b/src/Handler/Allocation/Application.hs
index 73d898959..7f0a6154e 100644
--- a/src/Handler/Allocation/Application.hs
+++ b/src/Handler/Allocation/Application.hs
@@ -58,24 +58,24 @@ data ApplicationFormMode = ApplicationFormMode
, afmApplicantEdit :: Bool -- ^ Allow editing text, files, priority (if shown)
, afmLecturer :: Bool -- ^ Allow editing rating
}
-
+
data ApplicationFormException = ApplicationFormNoApplication -- ^ Could not fill forced fields of application form with data from application
deriving (Eq, Ord, Read, Show, Generic, Typeable)
instance Exception ApplicationFormException
-applicationForm :: (Maybe AllocationId)
+applicationForm :: Maybe AllocationId
-> CourseId
-> UserId
-> ApplicationFormMode -- ^ Which parts of the shared form to display
-> Html -> MForm Handler (FormResult ApplicationForm, ApplicationFormView)
applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf = do
-
+
(mApp, coursesNum, Course{..}, maxPrio) <- liftHandler . runDB $ do
mApplication <- listToMaybe <$> selectList [CourseApplicationAllocation ==. maId, CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid] [LimitTo 1]
coursesNum <- fromIntegral . fromMaybe 1 <$> for maId (\aId -> count [AllocationCourseAllocation ==. aId])
course <- getJust cid
- (fromMaybe 0 -> maxPrio) <- fmap ((>>= E.unValue) . listToMaybe) . E.select . E.from $ \courseApplication -> do
+ (fromMaybe 0 -> maxPrio) <- fmap (E.unValue <=< listToMaybe) . E.select . E.from $ \courseApplication -> do
E.where_ $ courseApplication E.^. CourseApplicationUser E.==. E.val uid
E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.val maId
E.&&. E.not_ (E.isNothing $ courseApplication E.^. CourseApplicationAllocationPriority)
@@ -91,25 +91,25 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
mkPrioOption :: Natural -> Option Natural
mkPrioOption i = Option
- { optionDisplay = mr . MsgAllocationCoursePriority $ coursesNum' - i
+ { optionDisplay = mr . MsgAllocationCoursePriority $ coursesNum' - i
, optionInternalValue = i
, optionExternalValue = tshow i
}
-
+
prioOptions :: OptionList Natural
prioOptions = OptionList
{ olOptions = sortOn (Down . optionInternalValue) . map mkPrioOption $ [0 .. pred coursesNum']
, olReadExternal = readMay
}
prioField = selectField' (Just $ SomeMessage MsgAllocationCourseNoApplication) $ return prioOptions
-
+
(prioRes, prioView) <- case (isAlloc, afmApplicant, afmApplicantEdit, mApp) of
(True , True , True , Nothing)
- -> over _2 Just <$> mopt prioField (fslI MsgApplicationPriority) (Just $ oldPrio)
+ -> over _2 Just <$> mopt prioField (fslI MsgApplicationPriority) (Just oldPrio)
(True , True , True , Just _ )
-> over (_1 . _FormSuccess) Just . over _2 Just <$> mreq prioField (fslI MsgApplicationPriority) oldPrio
(True , True , False, _ )
- -> over _2 Just <$> mforcedOpt prioField (fslI MsgApplicationPriority) oldPrio
+ -> over _2 Just <$> mforcedOpt prioField (fslI MsgApplicationPriority) oldPrio
(True , False, _ , Just _ )
| is _Just oldPrio
-> pure (FormSuccess oldPrio, Nothing)
@@ -144,7 +144,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
let appFilesInfo = (,) <$> hasFiles <*> appCID
filesLinkView <- if
- | fromMaybe False hasFiles || (isn't _NoUpload courseApplicationsFiles && not afmApplicantEdit)
+ | Just True == hasFiles || (isn't _NoUpload courseApplicationsFiles && not afmApplicantEdit)
-> let filesLinkField = Field{..}
where
fieldParse _ _ = return $ Right Nothing
@@ -165,7 +165,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
-> return Nothing
filesWarningView <- if
- | fromMaybe False hasFiles && isn't _NoUpload courseApplicationsFiles && afmApplicantEdit
+ | Just True == hasFiles && isn't _NoUpload courseApplicationsFiles && afmApplicantEdit
-> fmap (Just . snd) . formMessage =<< messageIconI Info IconFileUpload MsgCourseApplicationFilesNeedReupload
| otherwise
-> return Nothing
@@ -174,16 +174,16 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
let mkFs = bool MsgCourseApplicationFile MsgCourseApplicationArchive
in if
| not afmApplicantEdit || is _NoUpload courseApplicationsFiles
- -> return $ (FormSuccess Nothing, Nothing)
+ -> return (FormSuccess Nothing, Nothing)
| otherwise
-> fmap (over _2 $ Just . ($ [])) . aFormToForm $ fileUploadForm False (fslI . mkFs) courseApplicationsFiles
(vetoRes, vetoView) <- if
| afmLecturer
- -> over _2 Just <$> mpopt checkBoxField (fslI MsgApplicationVeto & setTooltip MsgApplicationVetoTip) (Just . fromMaybe False $ courseApplicationRatingVeto . entityVal <$> mApp)
+ -> over _2 Just <$> mpopt checkBoxField (fslI MsgApplicationVeto & setTooltip MsgApplicationVetoTip) (Just $ Just True == fmap (courseApplicationRatingVeto . entityVal) mApp)
| otherwise
- -> return (FormSuccess . fromMaybe False $ courseApplicationRatingVeto . entityVal <$> mApp, Nothing)
-
+ -> return (FormSuccess $ Just True == fmap (courseApplicationRatingVeto . entityVal) mApp, Nothing)
+
(pointsRes, pointsView) <- if
| afmLecturer
-> over _2 Just <$> mopt examGradeField (fslI MsgApplicationRatingPoints & setTooltip MsgApplicationRatingPointsTip) (fmap Just $ mApp >>= courseApplicationRatingPoints . entityVal)
@@ -195,7 +195,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
-> over _2 Just . over (_1 . _FormSuccess) (assertM $ not . Text.null) <$> mopt textField' (fslI MsgApplicationRatingComment & setTooltip (bool MsgApplicationRatingCommentInvisibleTip MsgApplicationRatingCommentVisibleTip courseApplicationsRatingsVisible)) (fmap Just $ mApp >>= courseApplicationRatingComment . entityVal)
| otherwise
-> return (FormSuccess $ courseApplicationRatingComment . entityVal =<< mApp, Nothing)
-
+
let
buttons = catMaybes
[ guardOn (not afmApplicantEdit && is _Just mApp && afmLecturer) BtnAllocationApplicationRate
@@ -225,7 +225,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
<*> actionRes
, ApplicationFormView
{ afvPriority = prioView
- , afvForm = catMaybes $
+ , afvForm = catMaybes $
[ Just fieldView'
, textView
, filesLinkView
@@ -240,7 +240,7 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
}
)
-
+
editApplicationR :: Maybe AllocationId
@@ -285,7 +285,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
, courseApplicationRatingTime = guardOn rated now
}
- runConduit $ transPipe liftHandler (traverse_ id afFiles) .| C.mapM_ (insert_ . review _FileReference . (, CourseApplicationFileResidual appId))
+ runConduit $ transPipe liftHandler (sequence_ afFiles) .| C.mapM_ (insert_ . review _FileReference . (, CourseApplicationFileResidual appId))
audit $ TransactionCourseApplicationEdit cid uid appId
addMessageI Success $ MsgCourseApplicationCreated courseShorthand
| is _BtnAllocationApplicationEdit afAction || is _BtnAllocationApplicationRate afAction
@@ -354,7 +354,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
redirect postAction
return (appView, appEnc)
-
+
postAApplyR :: TermId -> SchoolId -> AllocationShorthand -> CryptoUUIDCourse -> Handler Void
postAApplyR tid ssh ash cID = do
diff --git a/src/Handler/Allocation/Compute.hs b/src/Handler/Allocation/Compute.hs
index 9c8b300e6..d18b68b31 100644
--- a/src/Handler/Allocation/Compute.hs
+++ b/src/Handler/Allocation/Compute.hs
@@ -62,7 +62,7 @@ missingPriorities aId = wFormToAForm $ do
missingPriosFieldView theId name attrs res isReq
= $(i18nWidgetFile "allocation-confirm-missing-prios")
where checkBoxFieldView = labeledCheckBoxView (i18n MsgAllocationUsersMissingPrioritiesOk) theId name attrs res isReq
-
+
if
| null usersWithoutPrio
-> return $ pure Set.empty
diff --git a/src/Handler/Allocation/List.hs b/src/Handler/Allocation/List.hs
index cc19d1968..c2bc4faea 100644
--- a/src/Handler/Allocation/List.hs
+++ b/src/Handler/Allocation/List.hs
@@ -58,7 +58,7 @@ resultApplied = _dbrOutput . _3
allocationTermLink :: TermId -> SomeRoute UniWorX
allocationTermLink tid = SomeRoute (AllocationListR, [(dbFilterKey allocationListIdent "term", toPathPiece tid)])
-
+
allocationSchoolLink :: SchoolId -> SomeRoute UniWorX
allocationSchoolLink ssh = SomeRoute (AllocationListR, [(dbFilterKey allocationListIdent "school", toPathPiece ssh)])
diff --git a/src/Handler/Allocation/Prios.hs b/src/Handler/Allocation/Prios.hs
index 20b3f5127..9d5621c1e 100644
--- a/src/Handler/Allocation/Prios.hs
+++ b/src/Handler/Allocation/Prios.hs
@@ -26,7 +26,7 @@ instance Finite AllocationPrioritiesMode
nullaryPathPiece ''AllocationPrioritiesMode $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''AllocationPrioritiesMode id
-
+
getAPriosR, postAPriosR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html
getAPriosR = postAPriosR
@@ -37,7 +37,7 @@ postAPriosR tid ssh ash = do
numericPrios <- E.selectCountRows . E.from $ \allocationUser -> do
E.where_ $ allocationUser E.^. AllocationUserAllocation E.==. E.val aId
E.where_ . E.maybe E.false sqlAllocationPriorityNumeric $ allocationUser E.^. AllocationUserPriority
-
+
ordinalPrios <- E.selectCountRows . E.from $ \allocationUser -> do
E.where_ $ allocationUser E.^. AllocationUserAllocation E.==. E.val aId
E.where_ . E.maybe E.false (E.not_ . sqlAllocationPriorityNumeric) $ allocationUser E.^. AllocationUserPriority
@@ -59,7 +59,7 @@ postAPriosR tid ssh ash = do
let sourcePrios = case mode of
AllocationPrioritiesNumeric -> transPipe liftHandler fInfo .| fileSourceCsvPositional Csv.NoHeader
AllocationPrioritiesOrdinal -> transPipe liftHandler fInfo .| fileSourceCsvPositional Csv.NoHeader .| C.map Csv.fromOnly .| ordinalPriorities
-
+
(matrSunk, matrMissing) <- runDB $ do
Entity aId _ <- getBy404 $ TermSchoolAllocationShort tid ssh ash
updateWhere
@@ -77,7 +77,7 @@ postAPriosR tid ssh ash = do
E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (E.val aId)
return (matrSunk, matrMissing)
- when (matrSunk > 0) $
+ when (matrSunk > 0) $
addMessageI Success $ MsgAllocationPrioritiesSunk matrSunk
when (matrMissing > 0) $
addMessageI Error $ MsgAllocationPrioritiesMissing matrMissing
diff --git a/src/Handler/Allocation/Register.hs b/src/Handler/Allocation/Register.hs
index c502ab48a..9629335c7 100644
--- a/src/Handler/Allocation/Register.hs
+++ b/src/Handler/Allocation/Register.hs
@@ -46,7 +46,7 @@ postARegisterR tid ssh ash = do
formResult registerRes $ \AllocationRegisterForm{..} -> runDB $ do
aId <- getKeyBy404 $ TermSchoolAllocationShort tid ssh ash
isRegistered <- existsBy $ UniqueAllocationUser aId uid
- void $ upsert AllocationUser
+ void $ upsert AllocationUser
{ allocationUserAllocation = aId
, allocationUserUser = uid
, allocationUserTotalCourses = arfTotalCourses
@@ -57,5 +57,5 @@ postARegisterR tid ssh ash = do
if
| isRegistered -> addMessageI Success MsgAllocationRegistrationEdited
| otherwise -> addMessageI Success MsgAllocationRegistered
-
+
redirect $ AllocationR tid ssh ash AShowR :#: ("allocation-participation" :: Text)
diff --git a/src/Handler/Allocation/Show.hs b/src/Handler/Allocation/Show.hs
index 08cd70d32..1df2e5506 100644
--- a/src/Handler/Allocation/Show.hs
+++ b/src/Handler/Allocation/Show.hs
@@ -7,7 +7,7 @@ import Import
import Utils.Course
import Handler.Utils
-
+
import Handler.Allocation.Register
import Handler.Allocation.Application
diff --git a/src/Handler/Allocation/Users.hs b/src/Handler/Allocation/Users.hs
index 08260f683..e150f1d1b 100644
--- a/src/Handler/Allocation/Users.hs
+++ b/src/Handler/Allocation/Users.hs
@@ -63,11 +63,11 @@ type UserTableData = DBRow ( Entity User
, Int -- ^ Applied
, Int -- ^ Assigned
, Int -- ^ Vetoed
- )
+ )
resultUser :: Lens' UserTableData (Entity User)
resultUser = _dbrOutput . _1
-
+
resultAllocationUser :: Lens' UserTableData (Entity AllocationUser)
resultAllocationUser = _dbrOutput . _2
@@ -83,7 +83,7 @@ data AllocationUserTableCsv = AllocationUserTableCsv
, csvAUserName :: Text
, csvAUserMatriculation :: Maybe Text
, csvAUserRequested
- , csvAUserApplied
+ , csvAUserApplied
, csvAUserVetos
, csvAUserAssigned :: Natural
, csvAUserPriority :: Maybe AllocationPriority
@@ -94,10 +94,10 @@ allocationUserTableCsvOptions :: Csv.Options
allocationUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 3}
instance Csv.ToNamedRecord AllocationUserTableCsv where
- toNamedRecord = Csv.genericToNamedRecord allocationUserTableCsvOptions
+ toNamedRecord = Csv.genericToNamedRecord allocationUserTableCsvOptions
instance Csv.DefaultOrdered AllocationUserTableCsv where
- headerOrder = Csv.genericHeaderOrder allocationUserTableCsvOptions
+ headerOrder = Csv.genericHeaderOrder allocationUserTableCsvOptions
instance CsvColumnsExplained AllocationUserTableCsv where
csvColumnsExplanations = genericCsvColumnsExplanations allocationUserTableCsvOptions $ mconcat
diff --git a/src/Handler/Course/Application/Files.hs b/src/Handler/Course/Application/Files.hs
index c608aa94e..05b229560 100644
--- a/src/Handler/Course/Application/Files.hs
+++ b/src/Handler/Course/Application/Files.hs
@@ -42,7 +42,7 @@ getCAppsFilesR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent
getCAppsFilesR tid ssh csh = do
runDB . existsBy404 $ TermSchoolCourseShort tid ssh csh
MsgRenderer mr <- getMsgRenderer
-
+
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgCourseAllApplicationsArchiveName tid ssh csh
let
@@ -61,12 +61,12 @@ getCAppsFilesR tid ssh csh = do
hasReadAccessTo $ CApplicationR tid ssh csh cID CAFilesR
let
applicationAllocs = setOf (folded . _1) apps'
-
+
allocations = applicationAllocs ^.. folded . _Just . _entityVal . $(multifocusG 3) _allocationTerm _allocationSchool _allocationShorthand
allEqualOn :: Eq x => Getter _ x -> Bool
allEqualOn l = maybe True (\x -> allOf (folded . l) (== x) allocations) (allocations ^? _head . l)
-
+
mkAllocationDir mbAlloc
| not $ allEqualOn _1
, Just Allocation{..} <- mbAlloc
@@ -92,7 +92,7 @@ getCAppsFilesR tid ssh csh = do
fileEntitySource = E.selectSource . E.from $ \courseApplicationFile -> do
E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. E.val appId
return courseApplicationFile
-
+
yield $ _FileReference # ( FileReference
{ fileReferenceModified = courseApplicationTime
, fileReferenceTitle = mkAppDir ""
diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs
index 6a98c7e48..b2b7200b4 100644
--- a/src/Handler/Course/Application/List.hs
+++ b/src/Handler/Course/Application/List.hs
@@ -47,7 +47,7 @@ type CourseApplicationsTableData = DBRow ( Entity CourseApplication
, Maybe (Entity StudyDegree)
, Bool -- isParticipant
)
-
+
courseApplicationsIdent :: Text
courseApplicationsIdent = "applications"
@@ -120,7 +120,7 @@ instance Csv.FromField CourseApplicationsTableVeto where
(CI.map Text.strip -> t :: CI Text) <- Csv.parseField f
return . CourseApplicationsTableVeto $ elem t
[ "veto", "v", "yes", "y", "ja", "j", "wahr", "w", "true", "t", "1" ]
-
+
data CourseApplicationsTableCsv = CourseApplicationsTableCsv
{ csvCAAllocation :: Maybe AllocationShorthand
, csvCAApplication :: Maybe CryptoFileNameCourseApplication
@@ -223,7 +223,7 @@ instance Exception CourseApplicationsTableCsvException
embedRenderMessage ''UniWorX ''CourseApplicationsTableCsvException id
-
+
data ButtonAcceptApplications = BtnAcceptApplications
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonAcceptApplications
@@ -277,7 +277,7 @@ postCApplicationsR tid ssh csh = do
applicationLink appId = liftHandler $ do
cID <- encrypt appId
return . SomeRoute $ CApplicationR tid ssh csh cID CAEditR
-
+
dbtSQLQuery :: CourseApplicationsTableExpr -> E.SqlQuery _
dbtSQLQuery = runReaderT $ do
courseApplication <- view queryCourseApplication
@@ -415,13 +415,13 @@ postCApplicationsR tid ssh csh = do
-> return () -- no addition
DBCsvDiffExisting{..} -> do
let appId = dbCsvOld ^. resultCourseApplication . _entityKey
-
+
newFeatures <- lift $ lookupStudyFeatures dbCsvNew
when (newFeatures /= dbCsvOld ^? resultStudyFeatures . _entityKey) $
yield $ CourseApplicationsTableCsvSetFieldData appId newFeatures
let mVeto = dbCsvNew ^? _csvCAVeto . _Just . _CourseApplicationsTableVeto
- whenIsJust mVeto $ \veto ->
+ whenIsJust mVeto $ \veto ->
when (veto /= dbCsvOld ^. resultCourseApplication . _entityVal . _courseApplicationRatingVeto) $
yield $ CourseApplicationsTableCsvSetVetoData appId veto
@@ -638,7 +638,7 @@ postCApplicationsR tid ssh csh = do
let title = prependCourseTitle tid ssh csh MsgCourseApplicationsListTitle
registrationOpen = maybe True (now <)
-
+
((acceptRes, acceptWgt'), acceptEnc) <- runFormPost . identifyForm BtnAcceptApplications . renderAForm FormStandard $
(,) <$> apopt (selectField optionsFinite) (fslI MsgAcceptApplicationsMode & setTooltip MsgAcceptApplicationsModeTip) (Just AcceptApplicationsInvite)
<*> apopt (selectField optionsFinite) (fslI MsgAcceptApplicationsSecondary & setTooltip MsgAcceptApplicationsSecondaryTip) (Just AcceptApplicationsSecondaryTime)
@@ -679,7 +679,7 @@ postCApplicationsR tid ssh csh = do
AcceptApplicationsSecondaryRandom
-> comparing $ view ratingL
sortedApplications <- unstableSortBy cmp applications
-
+
let applicants = sortedApplications
& nubOn (view $ _1 . _entityKey)
& maybe id take openCapacity
@@ -687,7 +687,7 @@ postCApplicationsR tid ssh csh = do
AcceptApplicationsDirect -> folded . _1 . _entityKey . to Right
AcceptApplicationsInvite -> folded . _1 . _entityVal . _userEmail . to Left
)
-
+
mapM_ addMessage' <=< execWriterT $ registerUsers cid applicants
redirect $ CourseR tid ssh csh CUsersR
diff --git a/src/Handler/Course/Communication.hs b/src/Handler/Course/Communication.hs
index dd833eccd..005aca3ae 100644
--- a/src/Handler/Course/Communication.hs
+++ b/src/Handler/Course/Communication.hs
@@ -94,7 +94,7 @@ postCCommR tid ssh csh = do
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. E.val cid
E.&&. courseParticipant E.^. CourseParticipantUser E.==. user E.^. UserId
E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
- return user
+ return user
)
] ++ tuts ++ exams ++ sheets
, crRecipientAuth = Just $ \uid -> do
diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs
index 6dde05c66..09e032bbb 100644
--- a/src/Handler/Course/Edit.hs
+++ b/src/Handler/Course/Edit.hs
@@ -92,7 +92,7 @@ courseToForm cEnt@(Entity cid Course{..}) lecs lecInvites alloc = CourseForm
where selectAppFiles = E.selectSource . E.from $ \courseAppInstructionFile -> do
E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. E.val cid
return courseAppInstructionFile
-
+
allocationCourseToForm :: Entity Course -> Entity AllocationCourse -> AllocationCourseForm
allocationCourseToForm (Entity _ Course{..}) (Entity _ AllocationCourse{..}) = AllocationCourseForm
@@ -139,7 +139,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
, not $ Set.null existing
-> FormFailure [mr MsgCourseLecturerAlreadyAdded]
| otherwise
- -> FormSuccess . Map.fromList . zip [maybe 0 succ . fmap fst $ Map.lookupMax oldDat ..] $ Set.toList newDat
+ -> FormSuccess . Map.fromList . zip [maybe 0 (succ . fst) $ Map.lookupMax oldDat ..] $ Set.toList newDat
addView' = $(widgetFile "course/lecturerMassInput/add")
return (addRes'', addView')
@@ -199,10 +199,11 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
(Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing,Nothing)
_allIOtherCases -> do
mbLastTerm <- liftHandler $ runDB $ selectFirst [TermActive ==. True] [Desc TermName]
- return ( Just (Just now)
- , (Just . toMidnight . termStart . entityVal) <$> mbLastTerm
- , (Just . beforeMidnight . termEnd . entityVal) <$> mbLastTerm
- , (Just . beforeMidnight . termEnd . entityVal) <$> mbLastTerm )
+ return ( Just $ Just now
+ , Just . toMidnight . termStart . entityVal <$> mbLastTerm
+ , Just . beforeMidnight . termEnd . entityVal <$> mbLastTerm
+ , Just . beforeMidnight . termEnd . entityVal <$> mbLastTerm
+ )
let
allocationForm :: AForm Handler (Maybe AllocationCourseForm)
@@ -214,7 +215,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
E.exists . E.from $ \allocationCourse ->
E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. E.val cid
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. allocation E.^. AllocationId
-
+
E.where_ $ term E.^. TermActive
E.||. alreadyParticipates
E.||. allocation E.^. AllocationSchool `E.in_` E.valList adminSchools
@@ -243,8 +244,8 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
let
userAdmin = not $ null adminSchools
- mayChange = fromMaybe True $ (|| userAdmin) <$> currentAllocationAvailable
-
+ mayChange = Just False /= fmap (|| userAdmin) currentAllocationAvailable
+
allocationForm' =
let ainp :: Field Handler a -> FieldSettings UniWorX -> Maybe a -> AForm Handler a
ainp
@@ -265,8 +266,8 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
multipleTermsMsg <- messageI Warning MsgCourseSemesterMultipleTip
(result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
- <$> pure (cfCourseId =<< template)
- <*> areq (textField & cfStrip & cfCI) (fslI MsgCourseName) (cfName <$> template)
+ (cfCourseId =<< template)
+ <$> areq (textField & cfStrip & cfCI) (fslI MsgCourseName) (cfName <$> template)
<*> areq (textField & cfStrip & cfCI) (fslpI MsgCourseShorthand "ProMo, LinAlg1, AlgoDat, Ana2, EiP, …"
-- & addAttr "disabled" "disabled"
& setTooltip MsgCourseShorthandUnique) (cfShort <$> template)
@@ -333,7 +334,7 @@ validateCourse = do
guardValidation MsgCourseRegistrationEndMustBeAfterStart
$ NTop cfRegFrom <= NTop cfRegTo
guardValidation MsgCourseDeregistrationEndMustBeAfterStart
- $ fromMaybe True $ (<=) <$> cfRegFrom <*> cfDeRegUntil
+ $ Just False /= ((<=) <$> cfRegFrom <*> cfDeRegUntil)
unless userAdmin $
guardValidation MsgCourseUserMustBeLecturer
$ anyOf (traverse . _Right . _1) (== uid) cfLecturers
@@ -538,7 +539,7 @@ courseEditHandler miButtonAction mbCourseForm = do
insert_ $ CourseEdit aid now cid
let mkFilter CourseAppInstructionFileResidual{..} = [ CourseAppInstructionFileCourse ==. courseAppInstructionFileResidualCourse ]
- in void . replaceFileReferences mkFilter (CourseAppInstructionFileResidual cid) . traverse_ id $ cfAppInstructionFiles res
+ in void . replaceFileReferences mkFilter (CourseAppInstructionFileResidual cid) . sequence_ $ cfAppInstructionFiles res
upsertAllocationCourse cid $ cfAllocation res
@@ -556,7 +557,7 @@ courseEditHandler miButtonAction mbCourseForm = do
upsertAllocationCourse :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe AllocationCourseForm -> ReaderT SqlBackend m ()
upsertAllocationCourse cid cfAllocation = do
now <- liftIO getCurrentTime
- Course{..} <- getJust cid
+ Course{} <- getJust cid
prevAllocationCourse <- getBy $ UniqueAllocationCourse cid
prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse
userAdmin <- fromMaybe False <$> for prevAllocation (\Allocation{..} -> hasWriteAccessTo $ SchoolR allocationSchool SchoolEditR)
diff --git a/src/Handler/Course/Events/Delete.hs b/src/Handler/Course/Events/Delete.hs
index 609fa93a5..3dd5d06fb 100644
--- a/src/Handler/Course/Events/Delete.hs
+++ b/src/Handler/Course/Events/Delete.hs
@@ -8,13 +8,13 @@ import Handler.Utils.Occurrences
import Handler.Utils.Delete
import qualified Data.Set as Set
-
+
getCEvDeleteR, postCEvDeleteR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseEvent -> Handler Html
getCEvDeleteR = postCEvDeleteR
postCEvDeleteR tid ssh csh cID = do
nId <- decrypt cID
-
+
let
drRecords :: Set (Key CourseEvent)
drRecords = Set.singleton nId
@@ -31,23 +31,23 @@ postCEvDeleteR tid ssh csh cID = do
:
^{occurrencesWidget courseEventTime}
|]
-
+
drRecordConfirmString :: Entity CourseEvent -> DB Text
drRecordConfirmString _ = return ""
-
+
drCaption, drSuccessMessage :: SomeMessage UniWorX
drCaption = SomeMessage MsgCourseEventDeleteQuestion
drSuccessMessage = SomeMessage MsgCourseEventDeleted
-
+
drAbort, drSuccess :: SomeRoute UniWorX
drAbort = SomeRoute $ CourseR tid ssh csh CShowR :#: [st|event-#{toPathPiece cID}|]
drSuccess = SomeRoute $ CourseR tid ssh csh CShowR
-
+
drFormMessage :: [Entity CourseEvent] -> DB (Maybe Message)
drFormMessage _ = return Nothing
-
+
drDelete :: forall a. CourseEventId -> JobDB a -> JobDB a
drDelete _ = id
-
+
deleteR DeleteRoute{..}
diff --git a/src/Handler/Course/Events/Edit.hs b/src/Handler/Course/Events/Edit.hs
index 5ac391d5d..0dcfaa30a 100644
--- a/src/Handler/Course/Events/Edit.hs
+++ b/src/Handler/Course/Events/Edit.hs
@@ -4,7 +4,7 @@ module Handler.Course.Events.Edit
import Import
import Handler.Utils
-
+
import Handler.Course.Events.Form
diff --git a/src/Handler/Course/Events/Form.hs b/src/Handler/Course/Events/Form.hs
index 3cb291f89..ecc01b8e9 100644
--- a/src/Handler/Course/Events/Form.hs
+++ b/src/Handler/Course/Events/Form.hs
@@ -31,7 +31,7 @@ courseEventForm template = identifyForm FIDCourseEvent . renderWForm FormStandar
)
let courseEventTypes = optionsPairs [ (courseEventType, courseEventType) | Entity _ CourseEvent{..} <- existingEvents ]
courseEventRooms = optionsPairs [ (courseEventRoom, courseEventRoom) | Entity _ CourseEvent{..} <- existingEvents ]
-
+
cefType' <- wreq (textField & cfStrip & cfCI & addDatalist courseEventTypes) (fslI MsgCourseEventType & addPlaceholder (mr MsgCourseEventTypePlaceholder)) (cefType <$> template)
cefRoom' <- wreq (textField & cfStrip & addDatalist courseEventRooms) (fslI MsgCourseEventRoom) (cefRoom <$> template)
cefTime' <- aFormToWForm $ occurrencesAForm ("time" :: Text) (cefTime <$> template)
diff --git a/src/Handler/Course/Events/New.hs b/src/Handler/Course/Events/New.hs
index b01f17af5..b389de9de 100644
--- a/src/Handler/Course/Events/New.hs
+++ b/src/Handler/Course/Events/New.hs
@@ -4,7 +4,7 @@ module Handler.Course.Events.New
import Import
import Handler.Utils
-
+
import Handler.Course.Events.Form
getCEventsNewR, postCEventsNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
diff --git a/src/Handler/Course/News/Delete.hs b/src/Handler/Course/News/Delete.hs
index 2311f9335..8fda2c3a0 100644
--- a/src/Handler/Course/News/Delete.hs
+++ b/src/Handler/Course/News/Delete.hs
@@ -12,7 +12,7 @@ getCNDeleteR, postCNDeleteR :: TermId -> SchoolId -> CourseShorthand -> CryptoUU
getCNDeleteR = postCNDeleteR
postCNDeleteR tid ssh csh cID = do
nId <- decrypt cID
-
+
let
drRecords :: Set (Key CourseNews)
drRecords = Set.singleton nId
@@ -26,22 +26,22 @@ postCNDeleteR tid ssh csh cID = do
[ toWidget <$> courseNewsTitle
, toWidget <$> courseNewsSummary
]
-
+
drRecordConfirmString :: Entity CourseNews -> DB Text
drRecordConfirmString _ = return ""
-
+
drCaption, drSuccessMessage :: SomeMessage UniWorX
drCaption = SomeMessage MsgCourseNewsDeleteQuestion
drSuccessMessage = SomeMessage MsgCourseNewsDeleted
-
+
drAbort, drSuccess :: SomeRoute UniWorX
drAbort = SomeRoute $ CourseR tid ssh csh CShowR :#: [st|news-#{toPathPiece cID}|]
drSuccess = SomeRoute $ CourseR tid ssh csh CShowR
drFormMessage :: [Entity CourseNews] -> DB (Maybe Message)
drFormMessage _ = return Nothing
-
+
drDelete :: forall a. CourseNewsId -> JobDB a -> JobDB a
drDelete _ = id
-
+
deleteR DeleteRoute{..}
diff --git a/src/Handler/Course/News/Download.hs b/src/Handler/Course/News/Download.hs
index b898c7f7f..59cfaabe8 100644
--- a/src/Handler/Course/News/Download.hs
+++ b/src/Handler/Course/News/Download.hs
@@ -25,7 +25,7 @@ getCNArchiveR tid ssh csh cID = do
serveSomeFiles archiveName getFilesQuery
-
+
getCNFileR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> FilePath -> Handler TypedContent
getCNFileR _ _ _ cID title = do
nId <- decrypt cID
diff --git a/src/Handler/Course/News/Edit.hs b/src/Handler/Course/News/Edit.hs
index d982e890e..cf4f4377a 100644
--- a/src/Handler/Course/News/Edit.hs
+++ b/src/Handler/Course/News/Edit.hs
@@ -33,8 +33,8 @@ postCNEditR tid ssh csh cID = do
, courseNewsSummary = cnfSummary
, courseNewsLastEdit = now
}
- let mkFilter CourseNewsFileResidual{..} = [ CourseNewsFileNews ==. nId ]
- in void . replaceFileReferences mkFilter (CourseNewsFileResidual nId) $ traverse_ id cnfFiles
+ let mkFilter CourseNewsFileResidual{} = [ CourseNewsFileNews ==. nId ]
+ in void . replaceFileReferences mkFilter (CourseNewsFileResidual nId) $ sequence_ cnfFiles
addMessageI Success MsgCourseNewsEdited
redirect $ CourseR tid ssh csh CShowR :#: [st|news-#{toPathPiece cID}|]
diff --git a/src/Handler/Course/News/Form.hs b/src/Handler/Course/News/Form.hs
index 0d52e3001..5d5aeb599 100644
--- a/src/Handler/Course/News/Form.hs
+++ b/src/Handler/Course/News/Form.hs
@@ -16,7 +16,7 @@ data CourseNewsForm = CourseNewsForm
, cnfContent :: Html
, cnfParticipantsOnly :: Bool
, cnfVisibleFrom :: Maybe UTCTime
- , cnfFiles :: Maybe FileUploads
+ , cnfFiles :: Maybe FileUploads
}
courseNewsForm :: Maybe CourseNewsForm -> Form CourseNewsForm
diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs
index 61a4316f9..dab5b62e2 100644
--- a/src/Handler/Course/ParticipantInvite.hs
+++ b/src/Handler/Course/ParticipantInvite.hs
@@ -92,11 +92,11 @@ participantInvitationConfig = InvitationConfig{..}
itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
invitationRestriction _ _ = return Authorized
- invitationForm (Entity _ Course{..}) _ uid = hoistAForm lift . wFormToAForm $ do
+ invitationForm _ _ uid = hoistAForm lift . wFormToAForm $ do
now <- liftIO getCurrentTime
studyFeatures <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid)
(fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) Nothing
- return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures <*> pure Nothing <*> pure CourseParticipantActive
+ return . fmap (, ()) $ JunctionParticipant now <$> studyFeatures <*> pure Nothing <*> pure CourseParticipantActive
invitationInsertHook _ _ (_, InvTokenDataParticipant{..}) CourseParticipant{..} _ act = do
deleteBy $ UniqueParticipant courseParticipantUser courseParticipantCourse -- there are no foreign key references to @{CourseParticipant}; therefor we can delete and recreate to simulate upsert
res <- act -- insertUnique
@@ -138,7 +138,7 @@ postCAddUserR tid ssh csh = do
formResultModal usersToEnlist (CourseR tid ssh csh CUsersR) $
hoist runDBJobs . registerUsers' cid
-
+
let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading
@@ -169,7 +169,7 @@ addParticipantsResultMessages :: (MonadHandler m, HandlerSite m ~ UniWorX)
=> AddParticipantsResult
-> ReaderT (YesodPersistBackend UniWorX) m [Message]
addParticipantsResultMessages AddParticipantsResult{..} = execWriterT $ do
- (aurAlreadyRegistered', aurNoUniquePrimaryField') <-
+ (aurAlreadyRegistered', aurNoUniquePrimaryField') <-
(,) <$> fmap sort (lift . mapM (fmap userEmail . getJust) $ Set.toList aurAlreadyRegistered)
<*> fmap sort (lift . mapM (fmap userEmail . getJust) $ Set.toList aurNoUniquePrimaryField)
diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs
index f23971e43..e0cd7f593 100644
--- a/src/Handler/Course/Register.hs
+++ b/src/Handler/Course/Register.hs
@@ -69,7 +69,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
isRegistered = btn `elem` [BtnCourseRetractApplication, BtnCourseDeregister]
return . (, btn) . wFormToAForm $ do
MsgRenderer mr <- getMsgRenderer
-
+
secretRes <- if
| Just secret <- courseRegisterSecret
, not isRegistered
@@ -118,7 +118,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
let appFilesInfo = (,) <$> hasFiles <*> appCID
filesMsg = bool MsgCourseRegistrationFiles MsgCourseApplicationFiles courseApplicationsRequired
- when (isn't _NoUpload courseApplicationsFiles || fromMaybe False hasFiles) $
+ when (isn't _NoUpload courseApplicationsFiles || Just True == hasFiles) $
let filesLinkField = Field{..}
where
fieldParse _ _ = return $ Right Nothing
@@ -136,7 +136,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
|]
in void $ wforced filesLinkField (fslI filesMsg) Nothing
- when (fromMaybe False hasFiles && isn't _NoUpload courseApplicationsFiles) $
+ when (Just True == hasFiles && isn't _NoUpload courseApplicationsFiles) $
wformMessage <=< messageIconI Info IconFileUpload $ bool MsgCourseRegistrationFilesNeedReupload MsgCourseApplicationFilesNeedReupload courseApplicationsRequired
appFilesRes <- let mkFs | courseApplicationsRequired = bool MsgCourseApplicationFile MsgCourseApplicationArchive
@@ -171,7 +171,7 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
<*> appTextRes
<*> appFilesRes
-
+
-- | Workaround for klicking register button without being logged in.
-- After log in, the user sees a "get request not supported" error.
getCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
@@ -212,8 +212,8 @@ postCRegisterR tid ssh csh = do
return $ Just prevId
- whenIsJust appRes $
- audit . TransactionCourseApplicationEdit cid uid
+ whenIsJust appRes $
+ audit . TransactionCourseApplicationEdit cid uid
whenIsJust ((,) <$> appRes <*> crfApplicationFiles) $ \(appId, fSource) -> do
runConduit $ transPipe liftHandler fSource .| C.mapM_ (insert_ . review _FileReference . (, CourseApplicationFileResidual appId))
return appRes
@@ -288,7 +288,7 @@ deregisterParticipant :: UserId -> CourseId -> DB ()
deregisterParticipant uid cid = do
deleteApplications uid cid
part <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid
- forM_ part $ \(Entity partId CourseParticipant{..}) -> do
+ forM_ part $ \(Entity partId CourseParticipant{}) -> do
update partId [CourseParticipantState =. CourseParticipantInactive False]
audit $ TransactionCourseParticipantDeleted cid uid
@@ -300,7 +300,7 @@ deregisterParticipant uid cid = do
forM_ examRegistrations $ \(Entity erId ExamRegistration{..}) -> do
delete erId
audit $ TransactionExamDeregister examRegistrationExam uid
-
+
E.delete . E.from $ \tutorialParticipant -> do
let tutorialCourse = E.subSelectForeign tutorialParticipant TutorialParticipantTutorial (E.^. TutorialCourse)
diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs
index 2f19c4502..619c79818 100644
--- a/src/Handler/Course/Show.hs
+++ b/src/Handler/Course/Show.hs
@@ -109,12 +109,11 @@ getCShowR tid ssh csh = do
return (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen)
let mDereg' = maybe id min (allocationOverrideDeregister =<< mAllocation) <$> courseDeregisterUntil course
- mDereg <- traverse (formatTime SelFormatDateTime) mDereg'
+ mDereg <- traverse (formatTime SelFormatDateTime) mDereg'
cID <- encrypt cid :: Handler CryptoUUIDCourse
- mAllocation' <- for mAllocation $ \alloc@Allocation{..} -> (,)
- <$> pure alloc
- <*> toTextUrl (AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: cID)
+ mAllocation' <- for mAllocation $ \alloc@Allocation{..} -> (alloc, )
+ <$> toTextUrl (AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: cID)
regForm <- if
| is _Just mbAid -> do
(courseRegisterForm', regButton) <- courseRegisterForm (Entity cid course)
@@ -127,9 +126,9 @@ getCShowR tid ssh csh = do
| otherwise
-> return . modal $(widgetFile "course/login-to-register") . Left . SomeRoute $ AuthR LoginR
registrationOpen <- hasWriteAccessTo $ CourseR tid ssh csh CRegisterR
-
+
MsgRenderer mr <- getMsgRenderer
-
+
let
tutorialDBTable = DBTable{..}
where
diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs
index a23a8128e..e7ad89d12 100644
--- a/src/Handler/Course/User.hs
+++ b/src/Handler/Course/User.hs
@@ -60,7 +60,7 @@ postCUserR tid ssh csh uCId = do
registered <- exists [ CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive ]
return (course, Entity uid user, registered)
-
+
sections <- mapM (runMaybeT . ($ user) . ($ course))
[ courseUserProfileSection
, courseUserNoteSection
@@ -115,7 +115,7 @@ courseUserProfileSection (Entity cid Course{..}) (Entity uid User{ userShowSex =
, formSubmit = FormAutoSubmit
, formAnchor = Just registrationFieldFrag
}
- for_ mRegistration $ \(Entity pId CourseParticipant{..}) ->
+ for_ mRegistration $ \(Entity pId CourseParticipant{}) ->
formResult regFieldRes $ \courseParticipantField' -> do
lift . runDB $ do
update pId [ CourseParticipantField =. courseParticipantField' ]
@@ -202,11 +202,11 @@ courseUserProfileSection (Entity cid Course{..}) (Entity uid User{ userShowSex =
return $(widgetFile "course/user/profile")
-
+
courseUserNoteSection :: Entity Course -> Entity User -> MaybeT Handler Widget
courseUserNoteSection (Entity cid Course{..}) (Entity uid _) = do
guardM . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CUsersR
-
+
currentRoute <- MaybeT getCurrentRoute
(thisUniqueNote, noteText, noteEdits) <- lift . runDB $ do
@@ -306,7 +306,7 @@ courseUserExamsSection (Entity cid Course{..}) (Entity uid _) = do
guardM . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CExamNewR
uCID <- encrypt uid
-
+
let
examDBTable = DBTable{..}
where
diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs
index e9a17d8da..f12e7993d 100644
--- a/src/Handler/Course/Users.hs
+++ b/src/Handler/Course/Users.hs
@@ -139,7 +139,7 @@ _userSheets = _dbrOutput . _8
colUserComment :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c)
colUserComment tid ssh csh =
- sortable (Just "note") (i18nCell MsgCourseUserNote) $ views (_dbrOutput . $(multifocusG 2) (_1 . _entityKey) _3) $ \(uid, mbNoteKey) ->
+ sortable (Just "note") (i18nCell MsgCourseUserNote) $ views (_dbrOutput . $(multifocusG 2) (_1 . _entityKey) _3) $ \(uid, mbNoteKey) ->
maybeEmpty mbNoteKey $ const $
anchorCellM (courseLink <$> encrypt uid) (hasComment True)
where
@@ -191,15 +191,15 @@ colUserSubmissionGroup = sortable (Just "submission-group") (i18nCell MsgSubmiss
colUserSheets :: forall m c. IsDBTable m c => [SheetName] -> Cornice Sortable ('Cap 'Base) UserTableData (DBCell m c)
colUserSheets shns = cap (Sortable Nothing caption) $ foldMap userSheetCol shns
where
- caption = i18nCell MsgCourseUserSheets
+ caption = i18nCell MsgCourseUserSheets
& cellAttrs <>~ [ ("uw-hide-column-header", "sheets")
, ("uw-hide-column-default-hidden", "")
]
-
+
userSheetCol :: SheetName -> Colonnade Sortable UserTableData (DBCell m c)
userSheetCol shn = sortable (Just . SortingKey $ "sheet-" <> shn) (i18nCell shn) . views (_userSheets . at shn) $ \case
Just (preview _grading -> Just Points{..}, Just points) -> i18nCell $ MsgAchievedOf points maxPoints
- Just (preview _grading -> Just grading', Just points) -> i18nCell . bool MsgNotPassed MsgPassed . fromMaybe False $ gradingPassed grading' points
+ Just (preview _grading -> Just grading', Just points) -> i18nCell . bool MsgNotPassed MsgPassed $ Just True == gradingPassed grading' points
_other -> mempty
@@ -210,7 +210,7 @@ data UserTableCsvStudyFeature = UserTableCsvStudyFeature
, csvUserType :: StudyFieldType
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
makeLenses_ ''UserTableCsvStudyFeature
-
+
data UserTableCsv = UserTableCsv
{ csvUserName :: Text
, csvUserSex :: Maybe Sex
@@ -404,33 +404,33 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
, single $ sortUserEmail queryUser
, single $ sortUserMatriclenr queryUser
, sortUserSex (to queryUser . to (E.^. UserSex))
- , single $ ("degree" , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName))
- , single $ ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
- , single $ ("field" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsName))
- , single $ ("field-short" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
- , single $ ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
- , single $ ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration))
- , single $ ("note" , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
+ , single ("degree" , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName))
+ , single ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
+ , single ("field" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsName))
+ , single ("field-short" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
+ , single ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
+ , single ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration))
+ , single ("note" , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
E.subSelectMaybe . E.from $ \edit -> do
E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
return . E.max_ $ edit E.^. CourseUserNoteEditTime
)
- , single $ ("tutorials" , SortColumn $ queryUser >>> \user ->
+ , single ("tutorials" , SortColumn $ queryUser >>> \user ->
E.subSelectMaybe . E.from $ \(tutorial `E.InnerJoin` participant) -> do
E.on $ tutorial E.^. TutorialId E.==. participant E.^. TutorialParticipantTutorial
E.&&. tutorial E.^. TutorialCourse E.==. E.val cid
E.where_ $ participant E.^. TutorialParticipantUser E.==. user E.^. UserId
return . E.min_ $ tutorial E.^. TutorialName
)
- , single $ ("exams" , SortColumn $ queryUser >>> \user ->
+ , single ("exams" , SortColumn $ queryUser >>> \user ->
E.subSelectMaybe . E.from $ \(exam `E.InnerJoin` examRegistration) -> do
E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
E.&&. exam E.^. ExamCourse E.==. E.val cid
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
return . E.min_ $ exam E.^. ExamName
)
- , single $ ("submission-group", SortColumn $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
- , single $ ("state", SortColumn $ queryParticipant >>> (E.^. CourseParticipantState))
+ , single ("submission-group", SortColumn $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
+ , single ("state", SortColumn $ queryParticipant >>> (E.^. CourseParticipantState))
, mconcat
[ single ( SortingKey $ "sheet-" <> sheetName
, SortColumn $ \(queryUser -> user) -> E.subSelectMaybe . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
@@ -438,8 +438,8 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
E.where_ $ submission E.^. SubmissionSheet E.==. E.val shId
return $ submission E.^. SubmissionRatingPoints
-
- )
+
+ )
| Entity shId Sheet{..} <- sheets
]
]
@@ -450,28 +450,28 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
, single $ fltrUserMatriclenr queryUser
, single $ fltrUserNameEmail queryUser
, fltrUserSex (to queryUser . to (E.^. UserSex))
- , single $ ("field-name" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName))
- , single $ ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
- , single $ ("field-key" , FilterColumn $ E.mkExactFilter $ queryFeaturesField >>> (E.?. StudyTermsKey))
- , single $ ("field" , FilterColumn $ E.anyFilter
+ , single ("field-name" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName))
+ , single ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
+ , single ("field-key" , FilterColumn $ E.mkExactFilter $ queryFeaturesField >>> (E.?. StudyTermsKey))
+ , single ("field" , FilterColumn $ E.anyFilter
[ E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsName)
, E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsShorthand)
, E.mkExactFilterWith readMay $ queryFeaturesField >>> (E.?. StudyTermsKey)
] )
- , single $ ("degree" , FilterColumn $ E.anyFilter
+ , single ("degree" , FilterColumn $ E.anyFilter
[ E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeName)
, E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeShorthand)
, E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey)
] )
- , single $ ("semesternr" , FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
- , single $ ("tutorial" , FilterColumn $ E.mkExistsFilter $ \row criterion ->
+ , single ("semesternr" , FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
+ , single ("tutorial" , FilterColumn $ E.mkExistsFilter $ \row criterion ->
E.from $ \(tutorial `E.InnerJoin` tutorialParticipant) -> do
E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
E.&&. E.hasInfix (tutorial E.^. TutorialName) (E.val criterion :: E.SqlExpr (E.Value (CI Text)))
E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser row E.^. UserId
)
- , single $ ("exam" , FilterColumn $ E.mkExistsFilter $ \row criterion ->
+ , single ("exam" , FilterColumn $ E.mkExistsFilter $ \row criterion ->
E.from $ \(exam `E.InnerJoin` examRegistration) -> do
E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
E.where_ $ exam E.^. ExamCourse E.==. E.val cid
@@ -480,15 +480,15 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
)
-- , ("course-registration", error "TODO") -- TODO
-- , ("course-user-note", error "TODO") -- TODO
- , single $ ("submission-group", FilterColumn $ E.mkContainsFilter $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
- , single $ ("active", FilterColumn $ E.mkExactFilter $ queryParticipant >>> (E.==. E.val CourseParticipantActive) . (E.^. CourseParticipantState))
- , single $ ("has-personalised-sheet-files", FilterColumn $ \t (Last criterion) -> flip (maybe E.true) criterion $ \shn
- -> E.exists . E.from $ \(psFile `E.InnerJoin` sheet) -> do
- E.on $ psFile E.^. PersonalisedSheetFileSheet E.==. sheet E.^. SheetId
- E.where_ $ psFile E.^. PersonalisedSheetFileUser E.==. queryParticipant t E.^. CourseParticipantUser
- E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
- E.&&. sheet E.^. SheetName E.==. E.val shn
- )
+ , single ("submission-group", FilterColumn $ E.mkContainsFilter $ querySubmissionGroup >>> (E.?. SubmissionGroupName))
+ , single ("active", FilterColumn $ E.mkExactFilter $ queryParticipant >>> (E.==. E.val CourseParticipantActive) . (E.^. CourseParticipantState))
+ , single ("has-personalised-sheet-files", FilterColumn $ \t (Last criterion) -> flip (maybe E.true) criterion $ \shn
+ -> E.exists . E.from $ \(psFile `E.InnerJoin` sheet) -> do
+ E.on $ psFile E.^. PersonalisedSheetFileSheet E.==. sheet E.^. SheetId
+ E.where_ $ psFile E.^. PersonalisedSheetFileUser E.==. queryParticipant t E.^. CourseParticipantUser
+ E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
+ E.&&. sheet E.^. SheetName E.==. E.val shn
+ )
]
where single = uncurry Map.singleton
dbtFilterUI mPrev = mconcat $
@@ -525,7 +525,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
{ dbtCsvExportForm = UserCsvExportData
<$> apopt checkBoxField (fslI MsgUserSimplifiedFeaturesOfStudyCsv & setTooltip MsgUserSimplifiedFeaturesOfStudyCsvTip) (Just $ csvUserSimplifiedFeaturesOfStudy def)
<*> apopt checkBoxField (fslI MsgCourseUserCsvIncludeSheets & setTooltip MsgCourseUserCsvIncludeSheetsTip) (Just $ csvUserIncludeSheets def)
- , dbtCsvDoEncode = \UserCsvExportData{..} -> C.mapM $ \(E.Value uid, row) -> flip runReaderT row $
+ , dbtCsvDoEncode = \UserCsvExportData{..} -> C.mapM $ \(E.Value uid, row) -> flip runReaderT row $
UserTableCsv
<$> view (hasUser . _userDisplayName)
<*> view (hasUser . _userSex)
@@ -652,7 +652,7 @@ postCUsersR tid ssh csh = do
hasExams = not $ null exams
examOccActs :: Map ExamId (AForm Handler (ExamId, Maybe ExamOccurrenceId))
examOccActs = examOccurrencesPerExam
- & (map (bimap entityKey hoistMaybe))
+ & map (bimap entityKey hoistMaybe)
& Map.fromListWith (<>)
& imap (\k v -> case v of
[] -> pure (k, Nothing)
@@ -726,7 +726,7 @@ postCUsersR tid ssh csh = do
addMessageI Success $ MsgCourseUsersDeregistered nrDel
redirect $ CourseR tid ssh csh CUsersR
(CourseUserRegisterTutorialData{..}, selectedUsers) -> do
- runDB . forM_ selectedUsers $
+ runDB . forM_ selectedUsers $
void . insertUnique . TutorialParticipant registerTutorial
addMessageI Success . MsgCourseUsersTutorialRegistered . fromIntegral $ Set.size selectedUsers
redirect $ CourseR tid ssh csh CUsersR
@@ -767,7 +767,7 @@ postCUsersR tid ssh csh = do
]
[ CourseParticipantState =. CourseParticipantActive
, CourseParticipantRegistration =. now
- , CourseParticipantAllocated =. Nothing
+ , CourseParticipantAllocated =. Nothing
]
guard $ didUpdate > 0
lift $ deleteWhere [ AllocationDeregisterCourse ==. Just cid, AllocationDeregisterUser ==. uid ]
diff --git a/src/Handler/CryptoIDDispatch.hs b/src/Handler/CryptoIDDispatch.hs
index 66c152c9f..e0326d9c9 100644
--- a/src/Handler/CryptoIDDispatch.hs
+++ b/src/Handler/CryptoIDDispatch.hs
@@ -5,6 +5,8 @@ module Handler.CryptoIDDispatch
import Import
+import Handler.Utils
+
import qualified Data.Text as Text
import Yesod.Core.Types (HandlerContents(..))
@@ -45,7 +47,7 @@ instance CryptoRoute UUID UserId where
(_ :: UserId) <- decrypt cID
return $ AdminUserR cID
-class Dispatch ciphertext (x :: [*]) where
+class Dispatch ciphertext (x :: [Type]) where
dispatchID :: p x -> ciphertext -> Handler (Maybe (Route UniWorX))
instance Dispatch ciphertext '[] where
@@ -62,7 +64,7 @@ instance (CryptoRoute ciphertext plaintext, Dispatch ciphertext ps) => Dispatch
handleCryptoID :: CryptoIDError -> Handler (Maybe a)
handleCryptoID _ = return Nothing
dispatchTail = dispatchID (Proxy :: Proxy ps) ciphertext
-
+
getCryptoUUIDDispatchR :: UUID -> Handler ()
getCryptoUUIDDispatchR uuid = dispatchID p uuid >>= maybe notFound (redirectAccessWith movedPermanently301)
@@ -75,5 +77,5 @@ getCryptoUUIDDispatchR uuid = dispatchID p uuid >>= maybe notFound (redirectAcce
getCryptoFileNameDispatchR :: CI FilePath -> Handler ()
getCryptoFileNameDispatchR path = dispatchID p path >>= maybe notFound (redirectAccessWith movedPermanently301)
where
- p :: Proxy '[ SubmissionId ]
+ p :: Proxy '[ SubmissionId ]
p = Proxy
diff --git a/src/Handler/Exam/AddUser.hs b/src/Handler/Exam/AddUser.hs
index aeef1facc..912e52054 100644
--- a/src/Handler/Exam/AddUser.hs
+++ b/src/Handler/Exam/AddUser.hs
@@ -8,15 +8,15 @@ import Handler.Exam.RegistrationInvite
import Handler.Utils
import Handler.Utils.Exam
import Handler.Utils.Invitations
-
+
import qualified Data.Set as Set
import Data.Semigroup (Option(..))
-
+
import Control.Monad.Error.Class (MonadError(..))
import Jobs.Queue
-
+
import Generics.Deriving.Monoid
@@ -43,7 +43,7 @@ postEAddUserR tid ssh csh examn = do
((usersToEnlist,formWgt),formEncoding) <- runFormPost . renderWForm FormStandard $ do
now <- liftIO getCurrentTime
occurrences <- liftHandler . runDB $ selectList [ExamOccurrenceExam ==. eid] []
-
+
let
localNow = utcToLocalTime now
tomorrowEndOfDay = case localTimeToUTC (LocalTime (addDays 2 $ localDay localNow) midnight) of
@@ -65,7 +65,7 @@ postEAddUserR tid ssh csh examn = do
= max tomorrowEndOfDay earliestDate'
| otherwise
= tomorrowEndOfDay
-
+
deadline <- wreq utcTimeField (fslI MsgExamRegistrationInviteDeadline) (Just defDeadline)
enlist <- wpopt checkBoxField (fslI MsgExamRegistrationEnlistDirectly & setTooltip MsgExamRegistrationEnlistDirectlyTip) (Just False)
registerCourse <- wpopt checkBoxField (fslI MsgExamRegistrationRegisterCourse & setTooltip MsgExamRegistrationRegisterCourseTip) (Just False)
@@ -132,7 +132,7 @@ postEAddUserR tid ssh csh examn = do
lift $ lift examRegister
throwError $ mempty { aurSuccess = pure userEmail }
- unless registerCourse $
+ unless registerCourse $
throwError $ mempty { aurNoCourseRegistration = pure userEmail }
guardAuthResult =<< lift (lift $ evalAccessDB (CourseR tid ssh csh CAddUserR) True)
diff --git a/src/Handler/Exam/AutoOccurrence.hs b/src/Handler/Exam/AutoOccurrence.hs
index 1f38a7910..7f135b552 100644
--- a/src/Handler/Exam/AutoOccurrence.hs
+++ b/src/Handler/Exam/AutoOccurrence.hs
@@ -52,7 +52,7 @@ examAutoOccurrenceCalculateForm :: ExamAutoOccurrenceCalculateForm -> Form ExamA
examAutoOccurrenceCalculateForm ExamAutoOccurrenceCalculateForm{ eaofConfig }
= identifyForm FIDExamAutoOccurrenceCalculate . renderAForm FormStandard $ ExamAutoOccurrenceCalculateForm <$> eaocForm
where
- eaocForm =
+ eaocForm =
(set _eaocMinimizeRooms <$> apopt checkBoxField (fslI MsgExamAutoOccurrenceMinimizeRooms & setTooltip MsgExamAutoOccurrenceMinimizeRoomsTip) (Just $ eaofConfig ^. _eaocMinimizeRooms))
<*> pure def
@@ -62,7 +62,7 @@ examAutoOccurrenceNudgeForm occId protoForm html = do
(btnRes, wgt) <- identifyForm (FIDExamAutoOccurrenceNudge $ ciphertext cID) (buttonForm' [BtnExamAutoOccurrenceNudgeUp, BtnExamAutoOccurrenceNudgeDown]) html
oldDataRes <- globalPostParamField PostExamAutoOccurrencePrevious secretJsonField
oldDataId <- newIdent
-
+
let protoForm' = fromMaybe def $ oldDataRes <|> protoForm
genForm btn = protoForm' & _eaofConfig . _eaocNudge %~ Map.insertWith (+) occId n
where n = case btn of
@@ -83,12 +83,12 @@ examAutoOccurrenceAcceptForm confirmData = identifyForm FIDExamAutoOccurrenceCon
examAutoOccurrenceCalculateWidget :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Widget
examAutoOccurrenceCalculateWidget tid ssh csh examn = do
(formView, formEncoding) <- liftHandler . generateFormPost $ examAutoOccurrenceCalculateForm def
-
+
wrapForm' BtnExamAutoOccurrenceCalculate $(i18nWidgetFile "exam-auto-occurrence-calculate") def
{ formAction = Just . SomeRoute $ CExamR tid ssh csh examn EAutoOccurrenceR
, formEncoding
}
-
+
postEAutoOccurrenceR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
postEAutoOccurrenceR tid ssh csh examn = do
@@ -96,8 +96,8 @@ postEAutoOccurrenceR tid ssh csh examn = do
exam@(Entity eId _) <- fetchExam tid ssh csh examn
occurrences <- selectList [ ExamOccurrenceExam ==. eId ] [ Asc ExamOccurrenceName ]
return (exam, occurrences)
-
-
+
+
((calculateRes, _), _) <- runFormPost $ examAutoOccurrenceCalculateForm def
nudgeRes <- sequence . flip Map.fromSet (setOf (folded . _entityKey) occurrences) $ \occId ->
diff --git a/src/Handler/Exam/Correct.hs b/src/Handler/Exam/Correct.hs
index 21baa4b8c..2b915a76a 100644
--- a/src/Handler/Exam/Correct.hs
+++ b/src/Handler/Exam/Correct.hs
@@ -36,15 +36,15 @@ getECorrectR tid ssh csh examn = do
return (exam, entityVal <$> examParts)
mayEditResults <- hasWriteAccessTo $ CExamR tid ssh csh examn EUsersR
-
+
let
heading = prependCourseTitle tid ssh csh $ (mr . MsgExamCorrectHeading . CI.original) examName
-
+
ptsInput :: ExamPartNumber -> Widget
ptsInput n = do
name <- newIdent
fieldView (pointsField :: Field Handler Points) ("exam-correct__" <> toPathPiece n) name [("uw-exam-correct--part-input", toPathPiece n)] (Left "") False
-
+
examGrades :: [ExamGrade]
examGrades = universeF
@@ -65,7 +65,7 @@ postECorrectR tid ssh csh examn = do
mayEditResults <- hasWriteAccessTo $ CExamR tid ssh csh examn EUsersR
response <- runDB . exceptT (<$ transactionUndo) return $ do
- Entity eId Exam{..} <- lift $ fetchExam tid ssh csh examn
+ Entity eId Exam{} <- lift $ fetchExam tid ssh csh examn
euid <- traverse decrypt ciqUser
guardMExceptT (maybe True ((>= minNeedleLength) . length) $ euid ^? _Left) $
@@ -131,7 +131,7 @@ postECorrectR tid ssh csh examn = do
in CorrectInterfaceResponseFailure
<$> (Just <$> userToResponse match)
<*> (getMessageRender <*> pure msg)
-
+
newExamPartResult <- lift $ upsert ExamPartResult
{ examPartResultExamPart = examPartId
, examPartResultUser = uid
@@ -173,7 +173,7 @@ postECorrectR tid ssh csh examn = do
return $ newResult ^? _entityVal . _examResultResult
| otherwise -> return $ mOldResult ^? _Just . _entityVal . _examResultResult
| otherwise -> return Nothing
-
+
user <- userToResponse match
return CorrectInterfaceResponseSuccess
{ cirsUser = user
diff --git a/src/Handler/Exam/CorrectorInvite.hs b/src/Handler/Exam/CorrectorInvite.hs
index c55da69f2..871fb8d12 100644
--- a/src/Handler/Exam/CorrectorInvite.hs
+++ b/src/Handler/Exam/CorrectorInvite.hs
@@ -18,7 +18,7 @@ import Data.Aeson hiding (Result(..))
import qualified Data.HashSet as HashSet
-
+
instance IsInvitableJunction ExamCorrector where
type InvitationFor ExamCorrector = Exam
data InvitableJunction ExamCorrector = JunctionExamCorrector
diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs
index d5781165c..1bfa7f79a 100644
--- a/src/Handler/Exam/Form.hs
+++ b/src/Handler/Exam/Form.hs
@@ -96,7 +96,7 @@ examForm template html = do
<*> apopt checkBoxField (fslI MsgExamPublicStatistics & setTooltip MsgExamPublicStatisticsTip) (efPublicStatistics <$> template <|> Just True)
<*> optionalActionA (examGradingRuleForm $ efGradingRule =<< template) (fslI MsgExamAutomaticGrading & setTooltip MsgExamAutomaticGradingTip) (is _Just . efGradingRule <$> template)
<*> optionalActionA (examBonusRuleForm $ efBonusRule =<< template) (fslI MsgExamBonus) (is _Just . efBonusRule <$> template)
- <*> (examOccurrenceRuleForm $ efOccurrenceRule <$> template)
+ <*> examOccurrenceRuleForm (efOccurrenceRule <$> template)
<* aformSection MsgExamFormCorrection
<*> examCorrectorsForm (efCorrectors <$> template)
<* aformSection MsgExamFormParts
@@ -117,7 +117,7 @@ examCorrectorsForm mPrev = wFormToAForm $ do
(addRes, addView) <- mpreq (multiUserInvitationField . MUILookupAnyUser $ Just corrUserSuggestions) (fslI MsgExamCorrectorEmail & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
let
addRes'
- | otherwise
+
= addRes <&> \newDat oldDat -> if
| existing <- newDat `Set.intersection` Set.fromList oldDat
, not $ Set.null existing
@@ -201,7 +201,7 @@ examPartsForm prev = wFormToAForm $ do
fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamParts) False $ Set.toList <$> prev
where
examPartForm' nudge mPrev csrf = do
- (epfIdRes, epfIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ epfId =<< mPrev)
+ (epfIdRes, epfIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ epfId =<< mPrev)
(epfNumberRes, epfNumberView) <- mpreq (isoField (from _ExamPartNumber) $ textField & cfStrip & cfCI) (fslI MsgExamPartNumber & addName (nudge "number") & addPlaceholder "1, 6a, 3.1.4, ...") (epfNumber <$> mPrev)
(epfNameRes, epfNameView) <- mopt (textField & cfStrip & cfCI) (fslI MsgExamPartName & addName (nudge "name")) (epfName <$> mPrev)
(epfMaxPointsRes, epfMaxPointsView) <- mopt pointsField (fslI MsgExamPartMaxPoints & addName (nudge "max-points")) (epfMaxPoints <$> mPrev)
@@ -221,7 +221,7 @@ examPartsForm prev = wFormToAForm $ do
(res, formWidget) <- examPartForm' nudge Nothing csrf
let
addRes = res <&> \newDat (Set.fromList -> oldDat) -> if
- | any (\old -> fromMaybe False $ (==) <$> epfName newDat <*> epfName old) oldDat
+ | any (\old -> Just True == ((==) <$> epfName newDat <*> epfName old)) oldDat
-> FormFailure [mr MsgExamPartAlreadyExists]
| otherwise -> FormSuccess $ pure newDat
return (addRes, $(widgetFile "widgets/massinput/examParts/add"))
@@ -336,10 +336,10 @@ validateExam = do
guardValidation MsgExamRegisterToMustBeAfterRegisterFrom $ NTop efRegisterTo >= NTop efRegisterFrom
guardValidation MsgExamDeregisterUntilMustBeAfterRegisterFrom $ NTop efDeregisterUntil >= NTop efRegisterFrom
- guardValidation MsgExamStartMustBeAfterPublishOccurrenceAssignments . fromMaybe True $ (>=) <$> efStart <*> efPublishOccurrenceAssignments
+ guardValidation MsgExamStartMustBeAfterPublishOccurrenceAssignments $ Just False /= ((>=) <$> efStart <*> efPublishOccurrenceAssignments)
guardValidation MsgExamEndMustBeAfterStart $ NTop efEnd >= NTop efStart
- guardValidation MsgExamFinishedMustBeAfterEnd . fromMaybe True $ (>=) <$> efFinished <*> efEnd
- guardValidation MsgExamFinishedMustBeAfterStart . fromMaybe True $ (>=) <$> efFinished <*> efStart
+ guardValidation MsgExamFinishedMustBeAfterEnd $ Just False /= ((>=) <$> efFinished <*> efEnd)
+ guardValidation MsgExamFinishedMustBeAfterStart $ Just False /= ((>=) <$> efFinished <*> efStart)
forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do
guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName) $ NTop eofEnd >= NTop (Just eofStart)
diff --git a/src/Handler/Exam/List.hs b/src/Handler/Exam/List.hs
index 6b4dae091..e0c96add7 100644
--- a/src/Handler/Exam/List.hs
+++ b/src/Handler/Exam/List.hs
@@ -6,7 +6,7 @@ module Handler.Exam.List
import Import
import Handler.Utils
-
+
import qualified Data.Map as Map
import qualified Database.Esqueleto as E
@@ -75,16 +75,15 @@ mkExamTable (Entity cid Course{..}) = do
examDBTableValidator = def
& defaultSorting [SortAscBy "time"]
& forceFilter "may-read" (Any True)
-
+
dbTable examDBTableValidator examDBTable
getCExamListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCExamListR tid ssh csh = do
- (Entity _ Course{..}, examTable) <- runDB $ do
+ examTable <- runDB $ do
c <- getBy404 $ TermSchoolCourseShort tid ssh csh
- (_, examTable) <- mkExamTable c
- return (c, examTable)
+ view _2 <$> mkExamTable c
siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamsHeading) $ do
setTitleI $ prependCourseTitle tid ssh csh MsgExamsHeading
diff --git a/src/Handler/Exam/New.hs b/src/Handler/Exam/New.hs
index 5c9e2d2c3..ebc1fcde8 100644
--- a/src/Handler/Exam/New.hs
+++ b/src/Handler/Exam/New.hs
@@ -12,7 +12,7 @@ import Handler.Utils
import Handler.Utils.Invitations
import Jobs.Queue
-
+
import qualified Data.Conduit.Combinators as C
@@ -29,7 +29,7 @@ postCExamNewR tid ssh csh = do
formResult newExamResult $ \ExamForm{..} -> do
insertRes <- runDBJobs $ do
now <- liftIO getCurrentTime
-
+
insertRes <- insertUnique Exam
{ examName = efName
, examCourse = cid
@@ -90,7 +90,7 @@ postCExamNewR tid ssh csh = do
when didRecord $
audit $ TransactionExamResultEdit examid courseParticipantUser
runConduit $ selectSource [ CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantInactive True ] [] .| C.mapM_ recordNoShow
-
+
return insertRes
case insertRes of
Nothing -> addMessageI Error $ MsgExamNameTaken efName
diff --git a/src/Handler/Exam/Register.hs b/src/Handler/Exam/Register.hs
index 744c76625..0ed4c1385 100644
--- a/src/Handler/Exam/Register.hs
+++ b/src/Handler/Exam/Register.hs
@@ -21,7 +21,7 @@ data ButtonExamRegister = BtnExamRegisterOccurrence
instance Universe ButtonExamRegister
instance Finite ButtonExamRegister
nullaryPathPiece ''ButtonExamRegister $ camelToPathPiece' 2
-
+
instance Button UniWorX ButtonExamRegister where
btnClasses BtnExamRegisterOccurrence = [BCIsButton, BCPrimary]
btnClasses BtnExamSwitchOccurrence = [BCIsButton, BCPrimary]
@@ -36,9 +36,9 @@ instance Button UniWorX ButtonExamRegister where
postERegisterR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
postERegisterR tid ssh csh examn = do
- Entity uid User{..} <- requireAuth
+ uid <- requireAuthId
- Entity eId Exam{..} <- runDB $ fetchExam tid ssh csh examn
+ Entity eId Exam{} <- runDB $ fetchExam tid ssh csh examn
((btnResult, _), _) <- runFormPost $ buttonForm' [BtnExamRegister, BtnExamDeregister]
@@ -63,14 +63,14 @@ postERegisterR tid ssh csh examn = do
postERegisterOccR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> ExamOccurrenceName -> Handler Html
postERegisterOccR tid ssh csh examn occn = do
- Entity uid User{..} <- requireAuth
- (Entity eId Exam{..}, Entity occId ExamOccurrence{..}) <- runDB $ do
- eexam@(Entity eId _) <- fetchExam tid ssh csh examn
- occ <- getBy404 $ UniqueExamOccurrence eId occn
- return (eexam, occ)
+ uid <- requireAuthId
+ (eId, occId) <- runDB $ do
+ Entity eId _ <- fetchExam tid ssh csh examn
+ occ <- getKeyBy404 $ UniqueExamOccurrence eId occn
+ return (eId, occ)
((btnResult, _), _) <- runFormPost buttonForm
-
+
formResult btnResult $ \case
BtnExamDeregister -> do
runDB $ do
@@ -89,4 +89,4 @@ postERegisterOccR tid ssh csh examn occn = do
_other -> error "Unexpected due to definition of buttonForm'"
redirect $ CExamR tid ssh csh examn EShowR
-
+
diff --git a/src/Handler/Exam/RegistrationInvite.hs b/src/Handler/Exam/RegistrationInvite.hs
index 0087c26c0..05703e42a 100644
--- a/src/Handler/Exam/RegistrationInvite.hs
+++ b/src/Handler/Exam/RegistrationInvite.hs
@@ -16,13 +16,13 @@ import Handler.Utils.Invitations
import qualified Data.Set as Set
import Text.Hamlet (ihamlet)
-
+
import Data.Aeson hiding (Result(..))
import Jobs.Queue
import qualified Data.HashSet as HashSet
-
+
instance IsInvitableJunction ExamRegistration where
type InvitationFor ExamRegistration = Exam
@@ -98,7 +98,7 @@ examRegistrationInvitationConfig = InvitationConfig{..}
(False, True ) -> do
fieldRes <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid) (fslI MsgCourseStudyFeature) Nothing
return $ (JunctionExamRegistration invDBExamRegistrationOccurrence now, ) . Just <$> fieldRes
- (True , _ ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing)
+ (True , _ ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing)
invitationInsertHook _ (Entity eid Exam{..}) _ ExamRegistration{..} mField act = do
whenIsJust mField $ \cpField -> do
void $ upsert
@@ -110,7 +110,7 @@ examRegistrationInvitationConfig = InvitationConfig{..}
]
queueDBJob . JobQueueNotification $ NotificationCourseRegistered examRegistrationUser examCourse
audit $ TransactionCourseParticipantEdit examCourse examRegistrationUser
-
+
let doAudit = audit $ TransactionExamRegister eid examRegistrationUser
act <* doAudit
invitationSuccessMsg (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInvitationAccepted examName
diff --git a/src/Handler/Exam/Show.hs b/src/Handler/Exam/Show.hs
index c86985c46..e8b306d85 100644
--- a/src/Handler/Exam/Show.hs
+++ b/src/Handler/Exam/Show.hs
@@ -96,9 +96,9 @@ getEShowR tid ssh csh examn = do
sumRegisteredCount = sumOf (folded . _3) occurrences
- noBonus = fromMaybe False $ do
+ noBonus = (Just True ==) $ do
guardM $ bonusOnlyPassed <$> examBonusRule
- return . fromMaybe True $ result ^? _Just . _entityVal . _examResultResult . _examResult . to (either id $ view passingGrade) . _Wrapped . to not
+ return $ Just False /= result ^? _Just . _entityVal . _examResultResult . _examResult . to (either id $ view passingGrade) . _Wrapped . to not
sumPoints = fmap getSum . mconcat $ catMaybes
[ Just $ foldMap (fmap Sum . examPartResultResult . entityVal) results
@@ -187,5 +187,5 @@ getEShowR tid ssh csh examn = do
examBonusW bonusRule = $(widgetFile "widgets/bonusRule")
occurrenceMapping :: ExamOccurrenceName -> Maybe Widget
- occurrenceMapping occName = examOccurrenceMappingDescriptionWidget <$> fmap examOccurrenceMappingRule examExamOccurrenceMapping <*> (fmap examOccurrenceMappingMapping examExamOccurrenceMapping >>= Map.lookup occName)
+ occurrenceMapping occName = examOccurrenceMappingDescriptionWidget <$> fmap examOccurrenceMappingRule examExamOccurrenceMapping <*> (examExamOccurrenceMapping >>= Map.lookup occName . examOccurrenceMappingMapping)
$(widgetFile "exam-show")
diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs
index dc0d891f1..f93cbc4e9 100644
--- a/src/Handler/Exam/Users.hs
+++ b/src/Handler/Exam/Users.hs
@@ -88,7 +88,7 @@ queryExamOccurrence = $(sqlLOJproj 6 2)
queryCourseParticipant :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity CourseParticipant))
queryCourseParticipant = $(sqlLOJproj 2 1) . $(sqlLOJproj 6 3)
-
+
queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures))
queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 6 3)
@@ -184,7 +184,7 @@ csvExamPartHeader = prism' toHeader fromHeader
review _ExamPartNumber . CI.mk <$> stripPrefix partPrefix tHdr
partPrefix = "part-"
-
+
data ExamUserTableCsv = ExamUserTableCsv
{ csvEUserSurname :: Maybe Text
@@ -499,7 +499,7 @@ postEUsersR tid ssh csh examn = do
[ (epId, (examPart, mbRes))
| (Entity epId examPart, mbRes) <- rawResults
]
-
+
dbtColonnade = mconcat $ catMaybes
[ pure $ dbSelect (_2 . applying _2) _1 $ return . view (resultExamRegistration . _entityKey)
, pure $ colUserNameLink (CourseR tid ssh csh . CUserR)
@@ -508,7 +508,7 @@ postEUsersR tid ssh csh examn = do
, pure $ colDegreeShort resultStudyDegree
, pure $ colFeaturesSemester resultStudyFeatures
, pure $ sortable (Just "occurrence") (i18nCell MsgExamOccurrence) $ maybe mempty (anchorCell' (\n -> CExamR tid ssh csh examn EShowR :#: [st|exam-occurrence__#{n}|]) id . examOccurrenceName . entityVal) . view _userTableOccurrence
- , guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) ->
+ , guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) ->
let SheetGradeSummary{achievedPasses} = examBonusAchieved uid bonus
SheetGradeSummary{numSheetsPasses} = examBonusPossible uid bonus
in propCell (getSum achievedPasses) (getSum numSheetsPasses)
@@ -517,7 +517,7 @@ postEUsersR tid ssh csh examn = do
SheetGradeSummary{sumSheetsPoints} = examBonusPossible uid bonus
in propCell (getSum achievedPoints) (getSum sumSheetsPoints)
, guardOn doBonus $ sortable (Just "bonus") (i18nCell MsgExamBonusAchieved) . automaticCell $ resultExamBonus . _entityVal . _examBonusBonus . to Right <> resultAutomaticExamBonus' . to Left
- , pure $ mconcat
+ , pure $ mconcat
[ sortable (Just $ fromText [st|part-#{toPathPiece examPartNumber}|]) (i18nCell $ MsgExamPartNumbered examPartNumber) $ maybe mempty i18nCell . preview (resultExamPartResult epId . _Just . _entityVal . _examPartResultResult)
| Entity epId ExamPart{..} <- sortOn (examPartNumber . entityVal) examParts
]
@@ -598,7 +598,7 @@ postEUsersR tid ssh csh examn = do
tell =<< optionsF [ ExamUserDeregister, ExamUserAssignOccurrence ]
when (is _Just examGradingRule) $
tell =<< optionsF [ ExamUserAcceptComputedResult, ExamUserResetToComputedResult ]
- when (not $ null examParts) $
+ unless (null examParts) $
tell =<< optionsF [ ExamUserSetPartResult ]
when doBonus $
tell =<< optionsF [ ExamUserSetBonus ]
@@ -652,7 +652,7 @@ postEUsersR tid ssh csh examn = do
(isPart, uid) <- lift $ guessUser' dbCsvNew
if
| isPart -> do
- yieldM $ ExamUserCsvRegisterData <$> pure uid <*> lookupOccurrence dbCsvNew
+ yieldM $ ExamUserCsvRegisterData uid <$> lookupOccurrence dbCsvNew
newFeatures <- lift $ lookupStudyFeatures dbCsvNew
Entity cpId CourseParticipant{ courseParticipantField = oldFeatures } <- lift . getJustBy $ UniqueParticipant uid examCourse
when (newFeatures /= oldFeatures) $
@@ -663,10 +663,10 @@ postEUsersR tid ssh csh examn = do
iforMOf_ (ifolded <. _Just) (csvEUserExamPartResults dbCsvNew) $ \epNumber epRes ->
when (epNumber `elem` examPartNumbers) $
yield $ ExamUserCsvSetPartResultData uid epNumber (Just epRes)
-
+
when (doBonus && is _Just (join $ csvEUserBonus dbCsvNew)) $
yield . ExamUserCsvSetBonusData False uid . join $ csvEUserBonus dbCsvNew
-
+
whenIsJust (csvEUserExamResult dbCsvNew) $ \res -> do
yield . ExamUserCsvSetResultData False uid $ csvEUserExamResult dbCsvNew
guardResultKind res
@@ -694,7 +694,7 @@ postEUsersR tid ssh csh examn = do
let newResults :: Maybe (Map ExamPartNumber ExamResultPoints)
newResults = sequence (csvEUserExamPartResults dbCsvNew)
- <|> sequence (toMapOf (resultExamParts .> ito (over _1 $ examPartNumber) <. to (fmap $ examPartResultResult . entityVal)) dbCsvOld)
+ <|> sequence (toMapOf (resultExamParts .> ito (over _1 examPartNumber) <. to (fmap $ examPartResultResult . entityVal)) dbCsvOld)
newBonus, oldBonus :: Maybe Points
newBonus = join (csvEUserBonus dbCsvNew)
@@ -703,7 +703,7 @@ postEUsersR tid ssh csh examn = do
newResult, oldResult :: Maybe ExamResultPassedGrade
newResult = fmap (fmap $ bool Right (Left . view passingGrade) $ is _ExamGradingGrades examGradingMode) . examGrade examVal (newBonus <|> oldBonus) =<< newResults
oldResult = dbCsvOld ^? (resultExamResult . _entityVal . _examResultResult <> resultAutomaticExamResult')
-
+
when doBonus $
case newBonus of
_ | newBonus == oldBonus
@@ -716,7 +716,7 @@ postEUsersR tid ssh csh examn = do
-> yield $ ExamUserCsvSetBonusData False uid newBonus
Just _
-> yield $ ExamUserCsvSetBonusData True uid newBonus
-
+
case newResult of
_ | csvEUserExamResult dbCsvNew == oldResult
-> return ()
@@ -965,12 +965,12 @@ postEUsersR tid ssh csh examn = do
| is (_ExamAttended . _Left) res -> ExamGradingPass
| otherwise -> ExamGradingGrades
| otherwise = return ()
-
+
registeredUserName :: Map (E.Value ExamRegistrationId) ExamUserTableData -> ExamRegistrationId -> Widget
registeredUserName existing (E.Value -> registration) = nameWidget userDisplayName userSurname
where
Entity _ User{..} = view resultUser $ existing ! registration
-
+
guessUser' :: ExamUserTableCsv -> DB (Bool, UserId)
guessUser' ExamUserTableCsv{..} = do
let criteria = PredDNF $ Set.singleton $ impureNonNull $ Set.fromList $ (PLVariable <$>) $ catMaybes $
@@ -1090,7 +1090,7 @@ postEUsersR tid ssh csh examn = do
audit $ TransactionExamBonusEdit eId uid
| otherwise
-> return ()
-
+
insert_ ExamResult
{ examResultExam = eId
, examResultUser = uid
diff --git a/src/Handler/ExamOffice/Course.hs b/src/Handler/ExamOffice/Course.hs
index 2db5ecf76..6ed103c3d 100644
--- a/src/Handler/ExamOffice/Course.hs
+++ b/src/Handler/ExamOffice/Course.hs
@@ -28,7 +28,7 @@ getCExamOfficeR = postCExamOfficeR
postCExamOfficeR tid ssh csh = do
uid <- requireAuthId
isModal <- hasCustomHeader HeaderIsModal
-
+
(cid, optOuts, hasForced) <- runDB $ do
cid <- getKeyBy404 (TermSchoolCourseShort tid ssh csh)
optOuts <- selectList [ CourseUserExamOfficeOptOutCourse ==. cid, CourseUserExamOfficeOptOutUser ==. uid ] []
@@ -65,7 +65,7 @@ postCExamOfficeR tid ssh csh = do
setTitleI MsgMenuCourseExamOffice
let explanation = $(i18nWidgetFile "course-exam-office-explanation")
-
+
[whamlet|
$newline never