diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index f1f562db8..133c5fa4f 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -312,7 +312,7 @@ embedRenderMessage ''UniWorX ''LmsTableAction id -- Not yet needed, since there is no additional data for now: data LmsTableActionData = LmsActNotifyData | LmsActRenewNotifyData - | LmsActRenewPinData + | LmsActRenewPinData -- no longer used deriving (Eq, Ord, Read, Show, Generic, Typeable) isNotifyAct :: LmsTableActionData -> Bool @@ -363,13 +363,14 @@ mkLmsTable :: forall h p cols act act'. , Ord act, PathPiece act, RenderMessage UniWorX act , AsCornice h p LmsTableData (DBCell (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData))) cols ) - => Entity Qualification + => Bool + -> Entity Qualification -> Map act (AForm Handler act') -> (LmsTableExpr -> E.SqlExpr (E.Value Bool)) -> cols -> PSValidator (MForm Handler) (FormResult (First act', DBFormResult UserId Bool LmsTableData)) -> DB (FormResult (act', Set UserId), Widget) -mkLmsTable (Entity qid quali) acts restrict cols psValidator = do +mkLmsTable isAdmin (Entity qid quali) acts restrict cols psValidator = do now <- liftIO getCurrentTime -- currentRoute <- fromMaybe (error "mkLmsAllTable called from 404-handler") <$> liftHandler getCurrentRoute -- we know the route here let @@ -462,7 +463,8 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do <*> (join . preview (resultLmsUser . _entityVal . _lmsUserEnded)) dbtCsvDecode = Nothing dbtExtraReps = [] - dbtParams = DBParamsForm + dbtParams = if not isAdmin then def {dbParamsFormAction = Nothing, dbParamsFormSubmit = FormNoSubmit} else + DBParamsForm { dbParamsFormMethod = POST , dbParamsFormAction = Just $ SomeRoute currentRoute , dbParamsFormAttrs = [] @@ -496,6 +498,7 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do getLmsR, postLmsR :: SchoolId -> QualificationShorthand -> Handler Html getLmsR = postLmsR postLmsR sid qsh = do + isAdmin <- hasReadAccessTo AdminR currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler ((lmsRes, lmsTable), Entity qid quali) <- runDB $ do qent <- getBy404 $ SchoolQualificationShort sid qsh @@ -503,10 +506,10 @@ postLmsR sid qsh = do acts = mconcat [ singletonMap LmsActNotify $ pure LmsActNotifyData , singletonMap LmsActRenewNotify $ pure LmsActRenewNotifyData - , singletonMap LmsActRenewPin $ pure LmsActRenewPinData + -- , singletonMap LmsActRenewPin $ pure LmsActRenewPinData ] colChoices = mconcat - [ dbSelectIf (applying _2) id (return . view (resultUser . _entityKey)) (\r -> isJust $ r ^? resultLmsUser) -- TODO: refactor using function "is" + [ if not isAdmin then mempty else dbSelectIf (applying _2) id (return . view (resultUser . _entityKey)) (\r -> isJust $ r ^? resultLmsUser) -- TODO: refactor using function "is" , colUserNameLinkHdr MsgLmsUser AdminUserR , colUserEmail , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) $ \( view $ resultQualUser . _entityVal . _qualificationUserValidUntil -> d) -> dayCell d @@ -570,10 +573,11 @@ postLmsR sid qsh = do -- i18nLms :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a i18nLms msg = cell [whamlet|LMS #|] <> i18nCell msg psValidator = def & forceFilter "may-access" (Any True) - tbl <- mkLmsTable qent acts (const E.true) colChoices psValidator + tbl <- mkLmsTable isAdmin qent acts (const E.true) colChoices psValidator return (tbl, qent) formResult lmsRes $ \case + _ | not isAdmin -> addMessageI Error MsgUnauthorized -- only admins can use the form on this page (action, selectedUsers) -> do -- | isRenewPinAct action || isNotifyAct action -> do now <- liftIO getCurrentTime numExaminees <- runDBJobs $ do @@ -591,6 +595,7 @@ postLmsR sid qsh = do when (isNotifyAct action) $ addMessageI Success $ MsgLmsNotificationSend numExaminees when (diffSelected /= 0) $ addMessageI Warning $ MsgLmsActionFailed diffSelected redirect currentRoute + let heading = citext2widget $ qualificationName quali siteLayout heading $ do