Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX

routes

@@ -88,14 +88,14 @@
   /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
   /ex/current                 SheetCurrentR    GET             !course-registered !materials !corrector
   /ex/unassigned              SheetOldUnassigned    GET
   /ex/#SheetName SheetR:
-    /show                       SShowR         GET             !timeANDcourse-registered !timeANDmaterials !corrector
+    /show                       SShowR         GET             !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor
     /edit                       SEditR         GET POST
     /delete                     SDelR          GET POST
     /subs                       SSubsR         GET POST        -- for lecturer only
@@ -110,9 +110,10 @@
       /invite                   SInviteR       GET POST        !ownerANDtime
       !/#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
+    !/#SheetFileType/*FilePath  SFileR         GET             !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor
   /file                          MaterialListR GET             !course-registered !materials !corrector !tutor
   /file/new                      MaterialNewR  GET POST
   /file/#MaterialName MaterialR:

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"
+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
@@ -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

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

@@ -296,19 +296,20 @@ instance Button UniWorX ButtonGeneratePseudonym where
 -- Show single sheet
 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
@@ -320,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,_) -> dateTimeCell modified
         ]
   let psValidator = def & defaultSorting [SortAscBy "type", SortAscBy "path"]
   (Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable
@@ -345,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
         )
@@ -763,7 +770,7 @@ getSCorrR tid ssh csh shn = do
     FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
     FormSuccess (autoDistribute, sheetCorrectors) -> runDBJobs $ do
       update shid [ SheetAutoDistribute =. autoDistribute ]
-      
+
       let (invites, adds) = partitionEithers $ Set.toList sheetCorrectors
 
       deleteWhere [ SheetCorrectorSheet ==. shid ]
@@ -845,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

@@ -54,9 +54,9 @@ sqlCell :: (IsDBTable (YesodDB UniWorX) a) => YesodDB UniWorX Widget -> DBCell (
 sqlCell act = mempty & cellContents .~ lift act
 
 -- | Highlight table cells with warning: Is not yet implemented in frontend.
-markCell :: (IsDBTable m a) => (t -> Bool) -> (t -> DBCell m a) -> (t -> DBCell m a)
+markCell :: (IsDBTable m a) => MessageStatus -> (t -> Bool) -> (t -> DBCell m a) -> (t -> DBCell m a)
-markCell condition normal x
+markCell status condition normal x
-   | condition x = normal x & cellAttrs <>~ [("class","urgency__warning")] ---TODO: handle existing classe akin to Form.addAttr/addClass
+   | condition x = normal x & over cellAttrs (insertAttr "class" $ statusToUrgencyClass status)
    | otherwise   = normal x
 
 ifCell :: (IsDBTable m a) => (t -> Bool) -> (t -> DBCell m a) -> (t -> DBCell m a) -> (t -> DBCell m a)
@@ -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)
@@ -102,12 +108,14 @@ dateCell t = cell $ formatTime SelFormatDate t >>= toWidget
 dateTimeCell :: IsDBTable m a => UTCTime -> DBCell m a
 dateTimeCell t = cell $ formatTime SelFormatDateTime t >>= toWidget
 
+-- | Show a date, and highlight date earlier than given watershed with an icon
 dateTimeCellVisible :: IsDBTable m a => UTCTime -> UTCTime -> DBCell m a
-dateTimeCellVisible watershed t = cell $ do
+dateTimeCellVisible watershed t
-    let tfw = formatTimeW SelFormatDateTime t
+    | watershed < t = cell $(widgetFile "widgets/date-time/yet-invisible") & addUrgencyClass
-        icn :: Widget
+    | otherwise     = cell timeStampWgt
-        icn = bool mempty (toWidget $ isVisible False) $ watershed < t
+  where
-    [whamlet|^{tfw}&nbsp;^{icn}|]
+    timeStampWgt    = formatTimeW SelFormatDateTime t
+    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

@@ -338,6 +338,25 @@ lastMaybe' :: [a] -> Maybe a
 lastMaybe' l = fmap snd $ l ^? _Snoc
 
 
+-- | 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,23 +83,16 @@ fslpI lbl placeholder
                   , fsAttrs    = [("placeholder", placeholder)]
                   }
 
+
+-- NOTE: see Utils.insertAttrs for inserting/merging generic [[(Text,Text)] attributes
+
 addAttr :: Text -> Text -> FieldSettings site -> FieldSettings site
-addAttr attr valu fs = fs { fsAttrs = newAttrs $ fsAttrs fs }
+addAttr attr valu fs = fs { fsAttrs = insertAttr attr valu $ fsAttrs fs }
-  where
-    newAttrs :: [(Text,Text)] -> [(Text,Text)]
-    newAttrs [] = [(attr, valu)]
-    newAttrs (p@(a,v) : t)
-      | attr==a   = (a, T.append valu $ cons ' ' v) : t
-      | otherwise = p : newAttrs t
 
 addAttrs :: Text -> [Text] -> FieldSettings site -> FieldSettings site
-addAttrs attr valus fs = fs { fsAttrs = newAttrs $ fsAttrs fs }
+addAttrs attr valus fs = fs { fsAttrs = insertAttr attr valu $ fsAttrs fs }
   where
-    newAttrs :: [(Text, Text)] -> [(Text, Text)]
+    valu = T.intercalate " " valus
-    newAttrs [] = [(attr, T.intercalate " " valus)]
-    newAttrs (p@(a,v) : t)
-      | attr==a   = ( a, T.intercalate " " $ v : valus ) : t
-      | otherwise = p : newAttrs t
 
 addPlaceholder :: Text -> FieldSettings site -> FieldSettings site
 addPlaceholder placeholder fs = fs { fsAttrs = (placeholderAttr, placeholder) : filter ((/= placeholderAttr) . fst) (fsAttrs fs) }
@@ -352,7 +346,7 @@ autosubmitButton = combinedButtonFieldF_ (Proxy @ButtonSubmit) $ "" & addAutosub
 -- | just Html for a Submit-Button
 submitButtonView :: forall site . Button site ButtonSubmit => WidgetT site IO ()
 submitButtonView = buttonView BtnSubmit
-  
+
 buttonView :: forall site button. Button site button => button -> WidgetT site IO ()
 buttonView btn = do
   let bField :: Field (HandlerT site IO) button

src/Utils/Message.hs

@@ -2,6 +2,7 @@ module Utils.Message
   ( MessageStatus(..)
   , UnknownMessageStatus(..)
   , addMessage, addMessageI, addMessageIHamlet, addMessageFile, addMessageWidget
+  , statusToUrgencyClass
   , Message(..)
   , messageI, messageIHamlet, messageFile, messageWidget
   ) where
@@ -67,6 +68,8 @@ instance FromJSON Message where
     messageContent <- preEscapedText . sanitizeBalance <$> o .: "content"
     return Message{..}
 
+statusToUrgencyClass :: MessageStatus -> Text
+statusToUrgencyClass status = "urgency__" <> toPathPiece status
 
 addMessage :: MonadHandler m => MessageStatus -> Html -> m ()
 addMessage mc  = ClassyPrelude.Yesod.addMessage  (toPathPiece mc)

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}

templates/widgets/date-time/yet-invisible.hamlet

@@ -0,0 +1 @@
+^{timeStampWgt} #{isVisible False}