Showing material implemented, missing overview

messages/uniworx/de.msg

@@ -217,7 +217,10 @@ 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
+MaterialInvisible: Dieses Material ist für Teilnehmer momentan unsichtbar!
+MaterialInvisibleUntil date@Text: Dieses Material ist für Teilnehmer momentan unsichtbar bis #{date}!
 MaterialFiles: Dateien
+MaterialHeading materialName@MaterialName: Material #{materialName}
 MaterialNewHeading: Neues Material veröffentlichen
 MaterialNewTitle: Neues Material
 MaterialEditHeading materialName@MaterialName: Material "#{materialName}" editieren
@@ -390,6 +393,7 @@ Pseudonyms: Pseudonyme
 
 FileTitle: Dateiname
 FileModified: Letzte Änderung
+VisibleFrom: Veröffentlicht
 
 
 Corrected: Korrigiert

src/Foundation.hs

@@ -2027,6 +2027,7 @@ pageHeading (CourseR tid ssh csh SheetNewR)
   = Just $ i18nHeading $ MsgSheetNewHeading tid ssh csh
 pageHeading (CSheetR tid ssh csh shn SShowR)
   = Just $ i18nHeading $ MsgSheetTitle tid ssh csh shn
+  -- = Just $ i18nHeading $ prependCourseTitle tid ssh csh $ SomeMessage shn -- TODO: for consistency use prependCourseTitle throughout ERROR: circularity
 pageHeading (CSheetR tid ssh csh shn SEditR)
   = Just $ i18nHeading $ MsgSheetEditHead tid ssh csh shn
 pageHeading (CSheetR tid ssh csh shn SDelR)

src/Handler/Material.hs

@@ -2,6 +2,7 @@ module Handler.Material where
 
 import Import
 
+import Data.Monoid (Any(..))
 import Data.Set (Set)
 import qualified Data.Set as Set
 -- import Data.Map (Map)
@@ -64,17 +65,17 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do
       <*> aopt (multiFileField oldFileIds)
                               (fslI MsgMaterialFiles)        (mfFiles <$> template)
 
-fetchMaterial :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> DB (CourseId, Entity Material)
+fetchMaterial :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> DB (Entity Material)
 fetchMaterial tid ssh csh mnm = do
-  [(E.Value cid, matEnt)] <- E.select . E.from  $ -- uniqueness guaranteed by DB constraints
+  [matEnt] <- E.select . E.from  $ -- uniqueness guaranteed by DB constraints
     \(course `E.InnerJoin` material) -> do
       E.on     $ course   E.^. CourseId   E.==.   material E.^. MaterialCourse
       E.where_ $ course   E.^. CourseTerm      E.==. E.val tid
           E.&&.  course   E.^. CourseSchool    E.==. E.val ssh
           E.&&.  course   E.^. CourseShorthand E.==. E.val csh
           E.&&.  material E.^. MaterialName    E.==. E.val mnm
-      return (course E.^. CourseId, material)
+      return material
-  return (cid, matEnt)
+  return matEnt
 
 
 getMaterialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
@@ -103,10 +104,11 @@ 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
-  _ <- runDB $ do
+  ( (Entity _mid material@Material{materialType, materialDescription})
-    (cid, matEnt) <- fetchMaterial tid ssh csh mnm
+    , (Any hasFiles,fileTable)) <- runDB $ do
+    matEnt <- fetchMaterial tid ssh csh mnm
     let psValidator = def & defaultSortingByFileTitle
-    dbTable psValidator DBTable
+    fileTable' <- dbTable psValidator DBTable
       { dbtSQLQuery = \(matFile `E.InnerJoin` file) -> do
             E.on     $ matFile E.^. MaterialFileFile     E.==. file E.^. FileId
             E.where_ $ matFile E.^. MaterialFileMaterial E.==. E.val (entityKey matEnt)
@@ -131,27 +133,34 @@ getMShowR tid ssh csh mnm = do
             , sortFileModification $(sqlIJproj 2 2)
             ]
       }
+    return (matEnt,fileTable')
+
+  now <- liftIO $ getCurrentTime
+  materialLastEdit    <-           formatTime SelFormatDateTime  $ materialLastEdit    material
+  let matVisFro = materialVisibleFrom material
+  materialVisibleFrom <- traverse (formatTime SelFormatDateTime) matVisFro
+  when (NTop matVisFro >= NTop (Just now)) $ addMessageI Warning $
+    maybe MsgMaterialInvisible MsgMaterialInvisibleUntil materialVisibleFrom
+
+  let headingLong  = prependCourseTitle tid ssh csh $ MsgMaterialHeading mnm
+      headingShort = prependCourseTitle tid ssh csh $ SomeMessage mnm
+
+  siteLayoutMsg headingLong $ do
+    setTitleI headingShort
+    $(widgetFile "material-show")
 
-  -- DEAD CODE TO DELETE:
-  -- (cid, Entity mid Material{..}, files) <- runDB $ do
-  --   (cid, matEnt) <- fetchMaterial tid ssh csh mnm
-  --   fileIds <- E.select . E.from $ \(matFile `E.InnerJoin` file) -> do
-  --     E.on     $ matFile  E.^. MaterialFileFile     E.==. file E.^. FileId
-  --     E.where_ $ matFile  E.^. MaterialFileMaterial E.==. E.val (entityKey matEnt)
-  --     return $ file E.^. FileId
-  --   return (cid, matEnt, (Left . E.unValue) <$> fileIds)
-  error "unimplemented" -- TODO
 
 getMEditR, postMEditR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html
 getMEditR = postMEditR
 postMEditR tid ssh csh mnm = do
-  (cid, Entity mid Material{..}, files) <- runDB $ do
+  (Entity mid Material{..}, files) <- runDB $ do
-    (cid, matEnt) <- fetchMaterial tid ssh csh mnm
+    matEnt <- fetchMaterial tid ssh csh mnm
     fileIds <- E.select . E.from $ \(matFile `E.InnerJoin` file) -> do
       E.on     $ matFile  E.^. MaterialFileFile     E.==. file E.^. FileId
       E.where_ $ matFile  E.^. MaterialFileMaterial E.==. E.val (entityKey matEnt)
       return $ file E.^. FileId
-    return (cid, matEnt, (Left . E.unValue) <$> fileIds)
+    return (matEnt, (Left . E.unValue) <$> fileIds)
+  -- let cid = materialCourse
   let template = Just $ MaterialForm
         { mfName         = materialName
         , mfType         = materialType
@@ -159,7 +168,7 @@ postMEditR tid ssh csh mnm = do
         , mfVisibleFrom  = materialVisibleFrom
         , mfFiles        = Just $ yieldMany files
         }
-  editWidget <- handleMaterialEdit tid ssh csh cid template $ uniqueReplace mid
+  editWidget <- handleMaterialEdit tid ssh csh materialCourse template $ uniqueReplace mid
   let headingLong  = prependCourseTitle tid ssh csh $ MsgMaterialEditHeading mnm
       headingShort = prependCourseTitle tid ssh csh $ MsgMaterialEditTitle   mnm
   siteLayoutMsg headingLong $ do
@@ -231,7 +240,7 @@ handleMaterialEdit tid ssh csh cid template dbMaterial = do
 getMDelR, postMDelR :: TermId -> SchoolId -> CourseShorthand ->  MaterialName -> Handler Html
 getMDelR = postMDelR
 postMDelR tid ssh csh mnm = do
-  (_cid, _matEnt) <- runDB $ fetchMaterial tid ssh csh mnm
+  _matEnt <- runDB $ fetchMaterial tid ssh csh mnm
   error "todo" -- CONTINUE HERE
   {-
   deleteR DeleteRoute

src/Handler/Sheet.hs

@@ -364,7 +364,7 @@ getSShowR tid ssh csh shn = do
         , formSubmit = FormNoSubmit
         }
   defaultLayout $ do
-    setTitleI $ MsgSheetTitle tid ssh csh shn
+    setTitleI $ prependCourseTitle tid ssh csh $ SomeMessage shn
     sheetFrom    <-           formatTime SelFormatDateTime  $ sheetActiveFrom   sheet
     sheetTo      <-           formatTime SelFormatDateTime  $ sheetActiveTo     sheet
     hintsFrom    <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom     sheet

src/Utils.hs

@@ -159,12 +159,18 @@ isNew False = mempty
 
 -- DEPRECATED: use hasTickmark instead;
 -- maybe reinstate if needed for @bewertung.txt@ files
-
 -- tickmark :: IsString a => a
 -- tickmark = fromString "✔"
 
+-- | Convert text as it is to Html, may prevent ambiguous types
+-- This function definition is mainly for documentation purposes
 text2Html :: Text -> Html
-text2Html = toHtml -- prevents ambiguous types
+text2Html = toHtml
+
+-- | Convert text as it is to Message, may prevent ambiguous types
+-- This function definition is mainly for documentation purposes
+text2message :: Text -> SomeMessage site
+text2message = SomeMessage
 
 toWgt :: (ToMarkup a, MonadBaseControl IO m, MonadThrow m, MonadIO m)
       => a -> WidgetT site m ()

templates/material-show.hamlet

@@ -0,0 +1,22 @@
+$newline never
+$maybe descr <- materialDescription
+  <section>
+    <h2 #description>_{MsgMaterialDescription}
+    <p>
+      #{descr}
+
+<section>
+  <dl .deflist>
+    $maybe matKind <- materialType
+      <dt .deflist__dt>_{MsgMaterialType}
+      <dd .deflist__dd>#{matKind}
+    $maybe matVisible <- materialVisibleFrom
+      <dt .deflist__dt>_{MsgVisibleFrom}
+      <dd .deflist__dd>#{matVisible}
+    <dt .deflist__dt>_{MsgFileModified}
+    <dd .deflist__dd>#{materialLastEdit}
+
+$if hasFiles
+  <section>
+    <h2>_{MsgMaterialFiles}
+    ^{fileTable}