PageActions done, all tested

messages/uniworx/de.msg

@@ -171,7 +171,7 @@ SheetInvisibleUntil date@Text: Dieses Übungsblatt ist für Teilnehmer momentan
 SheetName: Name
 SheetDescription: Hinweise für Teilnehmer
 SheetGroup: Gruppenabgabe
-SheetVisibleFrom: Verfügbar seit
+SheetVisibleFrom: Sichtbar für Teilnehmer ab
 SheetVisibleFromTip: Ohne Datum nie sichtbar und keine Abgabe möglich; nur für unfertige Blätter leer lassen, deren Bewertung/Fristen sich noch ändern können
 SheetActiveFrom: Beginn Abgabezeitraum
 SheetActiveFromTip: Download der Aufgabenstellung erst ab diesem Datum möglich
@@ -407,6 +407,7 @@ Pseudonyms: Pseudonyme
 FileTitle: Dateiname
 FileModified: Letzte Änderung
 VisibleFrom: Veröffentlicht
+AccessibleSince: Verfügbar seit
 
 
 Corrected: Korrigiert
@@ -753,6 +754,10 @@ MenuCorrections: Korrekturen
 MenuCorrectionsOwn: Meine Korrekturen
 MenuSubmissions: Abgaben
 MenuSheetList: Übungsblätter
+MenuMaterialList: Material
+MenuMaterialNew: Neues Material veröffentlichen
+MenuMaterialEdit: Material bearbeiten
+MenuMaterialDelete: Material löschen
 MenuTutorialList: Tutorien
 MenuTutorialNew: Neues Tutorium anlegen
 MenuSheetNew: Neues Übungsblatt anlegen

src/Foundation.hs

@@ -163,9 +163,13 @@ pattern CSheetR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetR
 pattern CSheetR tid ssh csh shn ptn
   = CourseR tid ssh csh (SheetR shn ptn)
 
+pattern CMaterialR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> MaterialR -> Route UniWorX
+pattern CMaterialR tid ssh csh mnm ptn
+  = CourseR tid ssh csh (MaterialR mnm ptn)
+
 pattern CTutorialR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> TutorialR -> Route UniWorX
-pattern CTutorialR tid ssh csh shn ptn
+pattern CTutorialR tid ssh csh tnm ptn
-  = CourseR tid ssh csh (TutorialR shn ptn)
+  = CourseR tid ssh csh (TutorialR tnm ptn)
 
 pattern CSubmissionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionR -> Route UniWorX
 pattern CSubmissionR tid ssh csh shn cid ptn
@@ -668,7 +672,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
     cTime <- liftIO getCurrentTime
     let visible = NTop materialVisibleFrom <= NTop (Just cTime)
     guard visible
-    reutrn Authorized
+    return Authorized
 
   CourseR tid ssh csh CRegisterR -> do
     now <- liftIO getCurrentTime
@@ -1405,6 +1409,14 @@ instance YesodBreadcrumbs UniWorX where
 --           (CSubmissionR tid ssh csh shn _ SubDownloadR) -- just for Download
   breadcrumb (CSheetR tid ssh csh shn SCorrR) = return ("Korrektoren", Just $ CSheetR tid ssh csh shn SShowR)
   --         (CSheetR tid ssh csh shn SFileR) -- just for Downloads
+
+  breadcrumb (CourseR tid ssh csh MaterialListR) = return ("Material"     , Just $ CourseR tid ssh csh CShowR)
+  breadcrumb (CourseR tid ssh csh MaterialNewR ) = return ("Neu"          , Just $ CourseR tid ssh csh MaterialListR)
+  breadcrumb (CMaterialR tid ssh csh mnm MShowR) = return (CI.original mnm, Just $ CourseR tid ssh csh MaterialListR)
+  breadcrumb (CMaterialR tid ssh csh mnm MEditR) = return ("Bearbeiten"   , Just $ CMaterialR tid ssh csh mnm MShowR)
+  breadcrumb (CMaterialR tid ssh csh mnm MDelR)  = return ("Löschen"      , Just $ CMaterialR tid ssh csh mnm MShowR)
+  --         (CMaterialR tid ssh csh mnm MFileR) -- just for Downloads
+
   -- Others
   breadcrumb (CorrectionsR)       = return ("Korrekturen", Just HomeR)
   breadcrumb (CorrectionsUploadR) = return ("Hochladen", Just CorrectionsR)
@@ -1763,6 +1775,14 @@ pageActions (CourseNewR) = [
   ]
 pageActions (CourseR tid ssh csh CShowR) =
   [ MenuItem
+      { menuItemType  = PageActionPrime
+      , menuItemLabel = MsgMenuMaterialList
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute $ CourseR tid ssh csh MaterialListR
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
+  , MenuItem
       { menuItemType = PageActionPrime
       , menuItemLabel = MsgMenuSheetList
       , menuItemIcon  = Nothing
@@ -1891,6 +1911,34 @@ pageActions (CourseR tid ssh csh SheetListR) =
       , menuItemAccessCallback' = return True
       }
   ]
+pageActions (CourseR tid ssh csh MaterialListR) =
+  [ MenuItem
+      { menuItemType  = PageActionPrime
+      , menuItemLabel = MsgMenuMaterialNew
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute $ CourseR tid ssh csh MaterialNewR
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
+  ]
+pageActions (CMaterialR tid ssh csh mnm MShowR) =
+  [ MenuItem
+      { menuItemType  = PageActionPrime
+      , menuItemLabel = MsgMenuMaterialEdit
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute $ CMaterialR tid ssh csh mnm MEditR
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
+  , MenuItem
+      { menuItemType  = PageActionPrime
+      , menuItemLabel = MsgMenuMaterialDelete
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute $ CMaterialR tid ssh csh mnm MDelR
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
+  ]
 pageActions (CourseR tid ssh csh CTutorialListR) =
   [ MenuItem
       { menuItemType  = PageActionPrime

src/Handler/Material.hs

@@ -83,7 +83,7 @@ getMaterialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getMaterialListR tid ssh csh = do
   let matLink :: MaterialName -> Route UniWorX
       matLink = CourseR tid ssh csh . flip MaterialR MShowR
-  _muid <- maybeAuthId
+  now <- liftIO getCurrentTime
   table <- runDB $ do
     cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
     let row2material = entityVal . dbrOutput -- no inner join, just Entity Material
@@ -104,13 +104,18 @@ getMaterialListR tid ssh csh = do
                 $ foldMap textCell . materialType . row2material
             , sortable (Just "name") (i18nCell MsgMaterialName)
                 $ liftA2 anchorCell matLink toWgt . materialName . row2material
+            , sortable (toNothingS "description") mempty
+                $ foldMap modalCell . materialDescription . row2material
+            , sortable (Just "visble-from") (i18nCell MsgAccessibleSince)
+                $ foldMap (dateTimeCellVisible now) . materialVisibleFrom . row2material
             , sortable (Just "last-edit") (i18nCell MsgFileModified)
                 $ dateTimeCell . materialLastEdit . row2material
             ]
       , dbtSorting   = Map.fromList
-            [ ( "type"      , SortColumn (E.^. MaterialType)     )
+            [ ( "type"         , SortColumn (E.^. MaterialType)        )
-            , ( "name"      , SortColumn (E.^. MaterialName)     )
+            , ( "name"         , SortColumn (E.^. MaterialName)        )
-            , ( "last-edit" , SortColumn (E.^. MaterialLastEdit) )
+            , ( "visible-from" , SortColumn (E.^. MaterialVisibleFrom) )
+            , ( "last-edit"    , SortColumn (E.^. MaterialLastEdit)    )
             ]
       , dbtFilter    = mempty
       , dbtFilterUI  = mempty

src/Handler/Sheet.hs

@@ -154,6 +154,7 @@ getSheetOldUnassigned tid ssh csh = runDB $ do
 getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getSheetListR tid ssh csh = do
   muid <- maybeAuthId
+  now <- liftIO getCurrentTime
   cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
   let
     lastSheetEdit sheet = E.sub_select . E.from $ \sheetEdit -> do
@@ -175,9 +176,9 @@ getSheetListR tid ssh csh = do
       , sortable (Just "name") (i18nCell MsgSheet)
           $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName)
       , sortable (Just "last-edit") (i18nCell MsgLastEdit)
-          $ \DBRow{dbrOutput=(_, E.Value mEditTime, _)} -> maybe mempty dateTimeCell mEditTime
+          $ \DBRow{dbrOutput=(_, E.Value mEditTime, _)} -> foldMap dateTimeCell mEditTime
-      , sortable (Just "visible-from") (i18nCell MsgSheetVisibleFrom)
+      , sortable (Just "visible-from") (i18nCell MsgAccessibleSince)
-          $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> maybe mempty dateTimeCell sheetVisibleFrom
+          $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> foldMap (dateTimeCellVisible now) sheetVisibleFrom
       , sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom)
           $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> dateTimeCell sheetActiveFrom
       , sortable (Just "submission-until") (i18nCell MsgSheetActiveTo)

src/Handler/Utils/Table/Cells.hs

@@ -53,7 +53,13 @@ pathPieceCell = cell . toWidget . toPathPiece
 sqlCell :: (IsDBTable (YesodDB UniWorX) a) => YesodDB UniWorX Widget -> DBCell (YesodDB UniWorX) a
 sqlCell act = mempty & cellContents .~ lift act
 
--- Recfor line numbers, use dbRow
+markCell :: (IsDBTable m a) => (a -> Bool) -> (a -> DBCell m a) -> a -> DBCell m a
+markCell condition normal x
+  | condition x = (normal x) <> (cell $ isVisibleWidget False)
+  | otherwise   = normal x
+
+
+-- Recall: for line numbers, use dbRow
 
 ---------------------
 -- Icon cells
@@ -76,6 +82,9 @@ commentCell Nothing     = mempty
 commentCell (Just link) = anchorCell link icon
   where icon = toWidget $ hasComment True
 
+-- | 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)
 
 -----------------
 -- Datatype cells
@@ -88,6 +97,12 @@ dateCell t = cell $ formatTime SelFormatDate t >>= toWidget
 dateTimeCell :: IsDBTable m a => UTCTime -> DBCell m a
 dateTimeCell t = cell $ formatTime SelFormatDateTime t >>= toWidget
 
+dateTimeCellVisible :: IsDBTable m a => UTCTime -> UTCTime -> DBCell m a
+dateTimeCellVisible watershed t = cell $ do
+    tfw <- formatTime SelFormatDateTime t >>= toWidget
+    icn <- bool mempty (toWidget $ isVisible False) $ watershed < t
+    return $ tfw <> icn
+
 userCell :: IsDBTable m a => Text -> Text -> DBCell m a
 userCell displayName surname = cell $ nameWidget displayName surname