From 6743e3b4d7099d4813bf940f1ba924dfba82d3f7 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 7 May 2019 10:26:19 +0200 Subject: [PATCH] Fixes #337 --- messages/uniworx/de.msg | 1 + src/Handler/Material.hs | 35 +++++++++++++++++++++++++----- src/Handler/Utils/Table/Cells.hs | 6 ++++- src/Handler/Utils/Table/Columns.hs | 5 +++++ 4 files changed, 41 insertions(+), 6 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index d6657f2f3..945497b01 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -223,6 +223,7 @@ MaterialTypeExample: Beispiel MaterialDescription: Beschreibung MaterialVisibleFrom: Sichtbar für Teilnehmer ab MaterialVisibleFromTip: Ohne Datum nie sichtbar für Teilnehmer; leer lassen ist nur sinnvoll für unfertige Materialien oder zur ausschließlichen Verteilung an Korrektoren +MaterialVisibleFromEditWarning: Das Datum der Veröffentlichung liegt in der Vergangenheit und sollte nicht mehr verändert werden, da dies die Benutzer verwirren könnte. MaterialInvisible: Dieses Material ist für Teilnehmer momentan unsichtbar! MaterialInvisibleUntil date@Text: Dieses Material ist für Teilnehmer momentan unsichtbar bis #{date}! MaterialFiles: Dateien diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 86b1789e6..0f84131ad 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -53,7 +53,13 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do return $ material E.^. MaterialType return $ defaults <> Set.fromList (mapMaybe E.unValue previouslyUsed) - ctime <- ceilingQuarterHour <$> liftIO getCurrentTime + now <- liftIO getCurrentTime + let ctime = ceilingQuarterHour now + let visibleToolTip = case mfVisibleFrom <$> template of + (Just (Just vistime)) | vistime <= now + -> MsgMaterialVisibleFromEditWarning + _ -> MsgMaterialVisibleFromTip + flip (renderAForm FormStandard) html $ MaterialForm <$> areq ciField (fslI MsgMaterialName) (mfName <$> template) <*> aopt (textField & addDatalist typeOptions) @@ -61,8 +67,8 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do (mfType <$> template) <*> aopt htmlField (fslpI MsgMaterialDescription "Html") (mfDescription <$> template) - <*> aopt utcTimeField (fslI MsgMaterialVisibleFrom - & setTooltip MsgMaterialVisibleFromTip) ((mfVisibleFrom <$> template) <|> pure (Just ctime)) + <*> aopt utcTimeField (fslI MsgMaterialVisibleFrom & setTooltip visibleToolTip) + ((mfVisibleFrom <$> template) <|> pure (Just ctime)) <*> aopt (multiFileField oldFileIds) (fslI MsgMaterialFiles) (mfFiles <$> template) @@ -83,7 +89,15 @@ getMaterialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getMaterialListR tid ssh csh = do let matLink :: MaterialName -> Route UniWorX matLink = CourseR tid ssh csh . flip MaterialR MShowR + + materialModDateCell :: IsDBTable m a => Material -> DBCell m a + materialModDateCell Material{materialVisibleFrom, materialLastEdit} + | NTop materialVisibleFrom >= NTop (Just materialLastEdit) + = mempty -- empty cells mean no modification after publication + | otherwise = dateTimeCell materialLastEdit -- modification after publication is highlighted by being shown + now <- liftIO getCurrentTime + seeAllModificationTimestamps <- hasWriteAccessTo $ CourseR tid ssh csh MaterialNewR -- ordinary users should not see modification dates older than visibility table <- runDB $ do cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh let row2material = entityVal . dbrOutput -- no inner join, just Entity Material @@ -109,7 +123,9 @@ getMaterialListR tid ssh csh = do , sortable (Just "visible-from") (i18nCell MsgAccessibleSince) $ foldMap (dateTimeCellVisible now) . materialVisibleFrom . row2material , sortable (Just "last-edit") (i18nCell MsgFileModified) - $ dateTimeCell . materialLastEdit . row2material + $ if seeAllModificationTimestamps + then dateTimeCell . materialLastEdit . row2material + else materialModDateCell . row2material ] , dbtSorting = Map.fromList [ ( "type" , SortColumn (E.^. MaterialType) ) @@ -128,6 +144,8 @@ getMaterialListR tid ssh csh = do $(widgetFile "material-list") + + getMFileR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> FilePath -> Handler TypedContent getMFileR tid ssh csh mnm title = serveOneFile fileQuery where @@ -151,9 +169,16 @@ getMShowR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Ht 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 + ( 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 + then colFileModification + else colFileModificationWhen $ \t -> NTop (Just t) > NTop (materialVisibleFrom $ entityVal matEnt) let psValidator = def & defaultSortingByFileTitle fileTable' <- dbTable psValidator DBTable { dbtSQLQuery = \(matFile `E.InnerJoin` file) -> do @@ -165,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 - , colFileModification (view $ _dbrOutput . _2) + , materialModDateCell (view $ _dbrOutput . _2) ] , dbtProj = \dbr -> guardAuthorizedFor (matLink $ dbr ^. _dbrOutput . _1 . _Value) dbr , dbtStyle = def diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 84580b219..7d559fd64 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -53,11 +53,15 @@ pathPieceCell = cell . toWidget . toPathPiece sqlCell :: (IsDBTable (YesodDB UniWorX) a) => YesodDB UniWorX Widget -> DBCell (YesodDB UniWorX) a sqlCell act = mempty & cellContents .~ lift act -markCell :: (IsDBTable m a) => (a -> Bool) -> (a -> DBCell m a) -> a -> DBCell m a +markCell :: (IsDBTable m a) => (t -> Bool) -> (t -> DBCell m a) -> (t -> DBCell m a) markCell condition normal x | condition x = normal x <> cell (isVisibleWidget False) | otherwise = normal x +ifCell :: (IsDBTable m a) => (t -> Bool) -> (t -> DBCell m a) -> (t -> DBCell m a) -> (t -> DBCell m a) +ifCell decision cTrue cFalse x + | decision x = cTrue x + | otherwise = cFalse x -- Recall: for line numbers, use dbRow diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 1c125344b..390741925 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -69,6 +69,11 @@ colFilePathSimple row2path row2link = sortable (Just "path") (i18nCell MsgFileTi colFileModification :: (IsDBTable m c) => (t -> E.Value UTCTime) -> Colonnade Sortable t (DBCell m c) colFileModification row2time = sortable (Just "time") (i18nCell MsgFileModified) (dateTimeCell . E.unValue . row2time) +colFileModificationWhen :: (IsDBTable m c) => (UTCTime -> Bool) -> (t -> E.Value UTCTime) -> Colonnade Sortable t (DBCell m c) +colFileModificationWhen condition row2time = sortable (Just "time") (i18nCell MsgFileModified) (conDTCell . E.unValue . row2time) + where conDTCell = ifCell condition dateTimeCell $ const mempty + + sortFilePath :: IsString s => (r -> E.SqlExpr (Entity File)) -> (s, SortColumn r) sortFilePath queryPath = ("path", SortColumn $ queryPath >>> (E.^. FileTitle))