Sheet: icon mark unpublished files works now

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

src/Handler/Course.hs

@@ -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"
+getCNotesR = postCNotesR
-postCNotesR = error "CNotesR: Not implemented"
+postCNotesR _ _ _ = do
+  defaultLayout $ [whamlet|You have corrector access to this course.|]
 
 
 getCCommR, postCCommR :: TermId -> SchoolId -> CourseShorthand -> Handler Html

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)
+    let materialModDateCol :: (IsDBTable m c) => (t -> E.Value UTCTime) -> Colonnade Sortable t (DBCell m c)
-        materialModDateCell = if seeAllModificationTimestamps
+        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

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
+  seeAllModificationTimestamps <- hasReadAccessTo $ CSheetR tid ssh csh shn SIsCorrR -- ordinary users should not see modification dates older than visibility
---   fileNameTypes <- runDB $ E.select $ E.from $
+
---     \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
+  let sftVisible :: IsDBTable m a => SheetFileType -> DBCell m a
---       -- Restrict to consistent rows that correspond to each other
+      sftVisible sft | Just dts <- sheetFileTypeDates sheet sft
---       E.on (file      E.^. FileId           E.==. sheetFile E.^. SheetFileFile)
+                        = dateTimeCellVisible now dts
---       E.on (sheetFile E.^. SheetFileSheet E.==. sheet     E.^. SheetId)
+                     | otherwise = isVisibleCell False
---       -- filter to requested file
+
---       E.where_ (sheet     E.^. SheetId      E.==. E.val sid )
+      sftModification :: IsDBTable m a => SheetFileType -> UTCTime -> DBCell m a
---       -- return desired columns
+      sftModification sft mtime
---       return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
+        | seeAllModificationTimestamps  =  dateTimeCell mtime
---   let fileLinks = map (\(E.Value fName, E.Value modified, E.Value fType) -> (CSheetR tid ssh csh (SheetFileR shn fType fName),modified)) fileNameTypes
+        | NTop (Just mtime) > NTop (sheetFileTypeDates sheet sft)  =  dateTimeCell mtime
-  -- with Colonnade
+        | 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}.|]
+

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

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

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

src/Utils/Form.hs

@@ -33,9 +33,10 @@ import Web.PathPieces
 
 import Data.UUID
 
-import Utils.Message
+import Utils
-import Utils.PathPiece
+-- import Utils.Message
-import Utils.Route
+-- 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
+-- NOTE: see Utils.insertAttrs for inserting/merging generic [[(Text,Text)] attributes
---   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
 
 addAttr :: Text -> Text -> FieldSettings site -> FieldSettings site
 addAttr attr valu fs = fs { fsAttrs = insertAttr attr valu $ fsAttrs fs }

templates/table/cell/body.hamlet

@@ -1,4 +1,4 @@
 $newline never
-<td *{mergeAttrs attrs [("class", "table__td")]}>
+<td *{insertClass "table__td" attrs}>
   <div .table__td-content>
     ^{widget}