diff --git a/routes b/routes index 747207cc0..228583752 100644 --- a/routes +++ b/routes @@ -88,7 +88,7 @@ /users/#CryptoUUIDUser CUserR GET POST !lecturerANDparticipant /correctors CHiWisR GET /communication CCommR GET POST - /notes CNotesR GET POST !corrector + /notes CNotesR GET POST !corrector -- THIS route is used to check for overall course corrector access! /subs CCorrectionsR GET POST /ex SheetListR GET !course-registered !materials !corrector /ex/new SheetNewR GET POST @@ -109,6 +109,7 @@ /correction CorrectionR GET POST !corrector !ownerANDreadANDrated !/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector /correctors SCorrR GET POST + /iscorrector SIsCorrR GET !corrector -- Route is used to check for corrector access to this sheet /pseudonym SPseudonymR GET POST !course-registeredANDcorrector-submissions /corrector-invite/ SCorrInviteR GET POST !/#SheetFileType/*FilePath SFileR GET !timeANDcourse-registered !timeANDmaterials !corrector diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 003fdfcdc..b73e6a1bb 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -40,7 +40,7 @@ import Jobs.Queue import Data.Aeson hiding (Result(..)) import Text.Hamlet (ihamlet) - + -- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method. type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School) @@ -1298,8 +1298,9 @@ getCNotesR, postCNotesR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -- NOTE: The route getNotesR is abused for correctorORlecturer access rights! -- PROBLEM: Correctors usually don't know Participants by name (anonymous), maybe notes are not shared? -- If they are shared, adjust MsgCourseUserNoteTooltip -getCNotesR = error "CNotesR: Not implemented" -postCNotesR = error "CNotesR: Not implemented" +getCNotesR = postCNotesR +postCNotesR _ _ _ = do + defaultLayout $ [whamlet|You have corrector access to this course.|] getCCommR, postCCommR :: TermId -> SchoolId -> CourseShorthand -> Handler Html @@ -1355,7 +1356,7 @@ postCCommR tid ssh csh = do evalAccessDB (CourseR tid ssh csh $ CUserR cID) False } - + getCLecInviteR, postCLecInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCLecInviteR = postCLecInviteR postCLecInviteR = invitationR lecturerInvitationConfig diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index b641b8ec3..b12b3b9af 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -170,13 +170,13 @@ getMShowR tid ssh csh mnm = do let matLink :: FilePath -> Route UniWorX matLink = CourseR tid ssh csh . MaterialR mnm . MFileR - seeAllModificationTimestamps <- hasWriteAccessTo $ CourseR tid ssh csh MaterialNewR -- ordinary users should not see modification dates older than visibility + seeAllModificationTimestamps <- hasReadAccessTo $ CourseR tid ssh csh CNotesR -- ordinary users should not see modification dates older than visibility ( Entity _mid material@Material{materialType, materialDescription} , (Any hasFiles,fileTable)) <- runDB $ do matEnt <- fetchMaterial tid ssh csh mnm - let materialModDateCell :: (IsDBTable m c) => (t -> E.Value UTCTime) -> Colonnade Sortable t (DBCell m c) - materialModDateCell = if seeAllModificationTimestamps + let materialModDateCol :: (IsDBTable m c) => (t -> E.Value UTCTime) -> Colonnade Sortable t (DBCell m c) + materialModDateCol = if seeAllModificationTimestamps then colFileModification else colFileModificationWhen $ \t -> NTop (Just t) > NTop (materialVisibleFrom $ entityVal matEnt) let psValidator = def & defaultSortingByFileTitle @@ -190,7 +190,7 @@ getMShowR tid ssh csh mnm = do , dbtColonnade = widgetColonnade $ mconcat [ dbRowIndicator -- important: contains writer to indicate that the tables is not empty , colFilePathSimple (view $ _dbrOutput . _1) matLink - , materialModDateCell (view $ _dbrOutput . _2) + , materialModDateCol (view $ _dbrOutput . _2) ] , dbtProj = \dbr -> guardAuthorizedFor (matLink $ dbr ^. _dbrOutput . _1 . _Value) dbr , dbtStyle = def diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 6187c4580..749cd9a09 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -298,18 +298,18 @@ getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html getSShowR tid ssh csh shn = do now <- liftIO getCurrentTime Entity sid sheet <- runDB $ fetchSheet tid ssh csh shn - -- without Colonnade --- fileNameTypes <- runDB $ E.select $ E.from $ --- \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do --- -- Restrict to consistent rows that correspond to each other --- E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile) --- E.on (sheetFile E.^. SheetFileSheet E.==. sheet E.^. SheetId) --- -- filter to requested file --- E.where_ (sheet E.^. SheetId E.==. E.val sid ) --- -- return desired columns --- return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType) --- let fileLinks = map (\(E.Value fName, E.Value modified, E.Value fType) -> (CSheetR tid ssh csh (SheetFileR shn fType fName),modified)) fileNameTypes - -- with Colonnade + seeAllModificationTimestamps <- hasReadAccessTo $ CSheetR tid ssh csh shn SIsCorrR -- ordinary users should not see modification dates older than visibility + + let sftVisible :: IsDBTable m a => SheetFileType -> DBCell m a + sftVisible sft | Just dts <- sheetFileTypeDates sheet sft + = dateTimeCellVisible now dts + | otherwise = isVisibleCell False + + sftModification :: IsDBTable m a => SheetFileType -> UTCTime -> DBCell m a + sftModification sft mtime + | seeAllModificationTimestamps = dateTimeCell mtime + | NTop (Just mtime) > NTop (sheetFileTypeDates sheet sft) = dateTimeCell mtime + | otherwise = mempty let fileData (sheetFile `E.InnerJoin` file) = do -- Restrict to consistent rows that correspond to each other @@ -321,12 +321,15 @@ getSShowR tid ssh csh shn = do return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType) let colonnadeFiles = widgetColonnade $ mconcat [ sortable (Just "type") (i18nCell MsgSheetFileTypeHeader) $ \(_,_, E.Value ftype) -> i18nCell ftype & cellContents %~ (\act -> act <* tell (Any True)) + -- , colFilePath (view _1) (\row -> let fType = view _3 row in let fName = view _1 row in (CSheetR tid ssh csh shn (SFileR (E.unValue fType) (E.unValue fName)))) , sortable (Just "path") (i18nCell MsgFileTitle) $ \(E.Value fName,_,E.Value fType) -> anchorCell (CSheetR tid ssh csh shn (SFileR fType fName)) (str2widget fName) - -- , colFilePath (view _1) (\row -> let fType = view _3 row in let fName = view _1 row in (CSheetR tid ssh csh shn (SFileR (E.unValue fType) (E.unValue fName)))) + , sortable (toNothing "visible") (i18nCell MsgVisibleFrom) + $ \(_, _ , E.Value ftype) -> sftVisible ftype + , sortable (Just "time") (i18nCell MsgFileModified) + $ \(_,E.Value modified, E.Value ftype) -> sftModification ftype modified -- , colFileModification (view _2) - , sortable (Just "time") (i18nCell MsgFileModified) $ \(_,E.Value modified,_) -> dateTimeCellVisible now modified ] let psValidator = def & defaultSorting [SortAscBy "type", SortAscBy "path"] (Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable @@ -346,6 +349,9 @@ getSShowR tid ssh csh shn = do , ( "path" , SortColumn $ \(_sheetFile `E.InnerJoin` file) -> file E.^. FileTitle ) + -- , ( "visible" + -- , SortColumn $ \(sheetFile `E.InnerJoin` _file) -> sheetFileTypeDates sheet $ sheetFile E.^. SheetFileType -- not possible without another join for the sheet + -- ) , ( "time" , SortColumn $ \(_sheetFile `E.InnerJoin` file) -> file E.^. FileModified ) @@ -846,3 +852,10 @@ correctorInvitationConfig = InvitationConfig{..} getSCorrInviteR, postSCorrInviteR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html getSCorrInviteR = postSCorrInviteR postSCorrInviteR = invitationR correctorInvitationConfig + + +getSIsCorrR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html +-- NOTE: The route SIsCorrR is only used to verfify corrector access rights to given sheet! +getSIsCorrR _ _ _ shn = do + defaultLayout $ [whamlet|You have corrector access to #{shn}.|] + diff --git a/src/Handler/Utils/Sheet.hs b/src/Handler/Utils/Sheet.hs index 0dbef5706..9909f0e7d 100644 --- a/src/Handler/Utils/Sheet.hs +++ b/src/Handler/Utils/Sheet.hs @@ -7,6 +7,15 @@ import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Internal.Sql as E +-- | Map sheet file types to their visibily dates of a given sheet, for convenience +sheetFileTypeDates :: Sheet -> SheetFileType -> Maybe UTCTime +sheetFileTypeDates Sheet{..} = \case + SheetExercise -> Just sheetActiveFrom + SheetHint -> sheetHintFrom + SheetSolution -> sheetSolutionFrom + SheetMarking -> Nothing + + fetchSheetAux :: ( BaseBackend backend ~ SqlBackend , E.SqlSelect b a , Typeable a, MonadHandler m, IsPersistBackend backend diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index e5906e993..c135e851b 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -87,6 +87,12 @@ commentCell Nothing = mempty commentCell (Just link) = anchorCell link icon where icon = toWidget $ hasComment True +isVisibleCell :: (IsDBTable m a) => Bool -> DBCell m a +isVisibleCell True = cell . toWidget $ isVisible True +isVisibleCell False = (cell . toWidget $ isVisible False) & addUrgencyClass + where + addUrgencyClass = over cellAttrs $ insertClass $ statusToUrgencyClass Warning + -- | Display an icon that opens a modal upon clicking modalCell :: (IsDBTable m a, ToWidget UniWorX w) => w -> DBCell m a modalCell content = cell $ modal (toWidget $ hasComment True) (Right $ toWidget content) @@ -109,7 +115,7 @@ dateTimeCellVisible watershed t | otherwise = cell timeStampWgt where timeStampWgt = formatTimeW SelFormatDateTime t - addUrgencyClass = over cellAttrs $ insertAttr "class" $ statusToUrgencyClass Warning + addUrgencyClass = over cellAttrs $ insertClass $ statusToUrgencyClass Warning userCell :: IsDBTable m a => Text -> Text -> DBCell m a userCell displayName surname = cell $ nameWidget displayName surname diff --git a/src/Utils.hs b/src/Utils.hs index 7f85d43a7..64e352bd1 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -335,7 +335,26 @@ lastMaybe (_:t) = lastMaybe t lastMaybe' :: [a] -> Maybe a lastMaybe' l = fmap snd $ l ^? _Snoc --- | Merge two lists of attribures, also see `Utils.Form.insertAttrs` + +-- | Merge/Add any attribute-value pair to an existing list of such pairs. +-- If the attribute exists, the new valu will be prepended, separated by a single empty space +-- Also see `Utils.mergeAttrs` +insertAttr :: Text -> Text -> [(Text,Text)] -> [(Text,Text)] +insertAttr attr valu = aux + where + aux :: [(Text,Text)] -> [(Text,Text)] + aux [] = [(attr,valu)] + aux (p@(a,v) : t) + | attr==a = (a, Text.append valu $ Text.cons ' ' v) : t + | otherwise = p : aux t + +-- | Add another class attribute; special function for a frequent case to avoid mistyping "class". +-- Also see `Utils.insertAttrs` +insertClass :: Text -> [(Text,Text)] -> [(Text,Text)] +insertClass = insertAttr "class" + +-- | Append two lists of attributes, merging the class attribute only. +-- Also see `Utils.insertAttr` to merge any attribute mergeAttrs :: [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)] mergeAttrs = mergeAttrs' `on` sort where diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index b0b4413ac..15f824b08 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -33,9 +33,10 @@ import Web.PathPieces import Data.UUID -import Utils.Message -import Utils.PathPiece -import Utils.Route +import Utils +-- import Utils.Message +-- import Utils.PathPiece +-- import Utils.Route import Data.Proxy @@ -82,17 +83,8 @@ fslpI lbl placeholder , fsAttrs = [("placeholder", placeholder)] } --- | Merge/Add an attribute-value Pair to an existing list of such pairs. --- If the attribute exists, the new valu will be prepended, separated by a single empty space --- Also see `Utils.mergeAttrs` -insertAttr :: Text -> Text -> [(Text,Text)] -> [(Text,Text)] -insertAttr attr valu = aux - where - aux :: [(Text,Text)] -> [(Text,Text)] - aux [] = [(attr,valu)] - aux (p@(a,v) : t) - | attr==a = (a, T.append valu $ cons ' ' v) : t - | otherwise = p : aux t + +-- NOTE: see Utils.insertAttrs for inserting/merging generic [[(Text,Text)] attributes addAttr :: Text -> Text -> FieldSettings site -> FieldSettings site addAttr attr valu fs = fs { fsAttrs = insertAttr attr valu $ fsAttrs fs } diff --git a/templates/table/cell/body.hamlet b/templates/table/cell/body.hamlet index 46bf50fd1..0928779b9 100644 --- a/templates/table/cell/body.hamlet +++ b/templates/table/cell/body.hamlet @@ -1,4 +1,4 @@ $newline never - +
^{widget}