From e0c9f4987a398e07ee1cfe6ea28844902e7b3ad4 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 3 May 2019 12:55:46 +0200 Subject: [PATCH] Showing material implemented, missing overview --- messages/uniworx/de.msg | 4 +++ src/Foundation.hs | 1 + src/Handler/Material.hs | 51 ++++++++++++++++++++-------------- src/Handler/Sheet.hs | 2 +- src/Utils.hs | 10 +++++-- templates/material-show.hamlet | 22 +++++++++++++++ 6 files changed, 66 insertions(+), 24 deletions(-) create mode 100644 templates/material-show.hamlet diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index ef6ce57ae..e77dd2055 100644 --- a/messages/uniworx/de.msg +++ b/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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 46e176a19..150792300 100644 --- a/src/Foundation.hs +++ b/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) diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index cf5c46aca..e7ce5134c 100644 --- a/src/Handler/Material.hs +++ b/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 (cid, matEnt) + return material + 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 - (cid, matEnt) <- fetchMaterial tid ssh csh mnm + ( (Entity _mid material@Material{materialType, materialDescription}) + , (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 - (cid, matEnt) <- fetchMaterial tid ssh csh mnm + (Entity mid Material{..}, files) <- runDB $ do + 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 diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 0ca8a2698..5d8d7c634 100644 --- a/src/Handler/Sheet.hs +++ b/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 diff --git a/src/Utils.hs b/src/Utils.hs index 2db129c24..57f7d2cc2 100644 --- a/src/Utils.hs +++ b/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 () diff --git a/templates/material-show.hamlet b/templates/material-show.hamlet new file mode 100644 index 000000000..cd8daa63c --- /dev/null +++ b/templates/material-show.hamlet @@ -0,0 +1,22 @@ +$newline never +$maybe descr <- materialDescription +
+

_{MsgMaterialDescription} +

+ #{descr} + +

+
+ $maybe matKind <- materialType +
_{MsgMaterialType} +
#{matKind} + $maybe matVisible <- materialVisibleFrom +
_{MsgVisibleFrom} +
#{matVisible} +
_{MsgFileModified} +
#{materialLastEdit} + +$if hasFiles +
+

_{MsgMaterialFiles} + ^{fileTable}