diff --git a/config/keter.yml b/config/keter.yml index 2df90a924..3b8c9db84 120000 --- a/config/keter.yml +++ b/config/keter.yml @@ -1 +1 @@ -keter_uni2work.yml \ No newline at end of file +keter_testworx.yml \ No newline at end of file diff --git a/messages/de.msg b/messages/de.msg index 72239ce44..0c7147ecd 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -59,9 +59,22 @@ SheetDelText submissionNo@Int: Dies kann nicht mehr rückgängig gemacht w SheetDelOk tid@TermId courseShortHand@Text sheetName@Text: #{display tid}-#{courseShortHand}: Übungsblatt #{sheetName} gelöscht. SheetExercise: Aufgabenstellung -SheetHint: Hinweise +SheetHint: Hinweis +SheetHintFrom: Hinweis ab SheetSolution: Lösung -SheetMarking: Korrekturhinweise +SheetSolutionFrom: Lösung ab +SheetMarking: Hinweise für Korrektoren +SheetType: Bewertung + +SheetVisibleFrom: Sichtbar ab +SheetActiveFrom: Aktiv ab +SheetActiveTo: Abgabefrist + +SheetErrVisibility: Sichtbarkeit muss vor Beginn der Abgabefrist liegen +SheetErrDeadlineEarly: Ende der Abgabefrist muss nach deren Beginn liegen +SheetErrHintEarly: Hinweise dürfen erst nach Beginn der Abgabefrist herausgegeben werden +SheetErrSolutionEarly: Die Lösung sollte erst nach Ende der Abgabefrist herausgegeben werden + Deadline: Abgabe Done: Eingereicht @@ -206,4 +219,5 @@ InvalidDateTimeFormat: Ungültiges Datums- und Zeitformat, JJJJ-MM-TTTHH:MM[:SS] AmbiguousUTCTime: Der angegebene Zeitpunkt lässt sich nicht eindeutig zu UTC konvertieren LastEdits: Letzte Änderungen -EditedBy name@Text time@Text: Durch #{name} um #{time} \ No newline at end of file +EditedBy name@Text time@Text: Durch #{name} um #{time} +LastEdit: Letzte Änderung diff --git a/src/Foundation.hs b/src/Foundation.hs index 51062691d..b76ad30f2 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -309,11 +309,25 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh Entity _sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn cTime <- liftIO getCurrentTime + let + visible = NTop sheetVisibleFrom <= NTop (Just cTime) + active = sheetActiveFrom <= cTime && cTime <= sheetActiveTo + + guard visible + + case subRoute of + SFileR SheetExercise _ -> guard $ sheetActiveFrom <= cTime + SFileR SheetHint _ -> guard $ maybe False (<= cTime) sheetHintFrom + SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom + SubmissionNewR -> guard active + SubmissionR _ _ -> guard active + _ -> return () + + return Authorized + let started = sheetActiveFrom <= cTime || NTop sheetVisibleFrom <= (NTop $ Just cTime) case subRoute of SFileR SheetExercise _ -> guard started - SFileR SheetHint _ -> guard $ maybe False (<= cTime) sheetHintFrom - SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom SFileR SheetMarking _ -> mzero -- only for correctors and lecturers SubmissionNewR -> guard $ sheetActiveFrom <= cTime && cTime <= sheetActiveTo SubmissionR _ _ -> guard $ sheetActiveFrom <= cTime && cTime <= sheetActiveTo @@ -720,12 +734,52 @@ pageActions :: Route UniWorX -> [MenuTypes] {- Icons: https://fontawesome.com/icons?d=gallery Guideline: use icons without boxes/frames, only non-pro + + Please keep sorted according to routes -} -pageActions (CorrectionsR) = +pageActions (HomeR) = + [ +-- NavbarAside $ MenuItem +-- { menuItemLabel = "Benutzer" +-- , menuItemIcon = Just "users" +-- , menuItemRoute = UsersR +-- , menuItemAccessCallback' = return True +-- } +-- , + NavbarAside $ MenuItem + { menuItemLabel = "AdminDemo" + , menuItemIcon = Just "screwdriver" + , menuItemRoute = AdminTestR + , menuItemAccessCallback' = return True + } + ] +pageActions (ProfileR) = [ PageActionPrime $ MenuItem - { menuItemLabel = "Korrekturen hochladen" - , menuItemIcon = Nothing - , menuItemRoute = CorrectionsUploadR + { menuItemLabel = "Gespeicherte Daten anzeigen" + , menuItemIcon = Just "book" + , menuItemRoute = ProfileDataR + , menuItemAccessCallback' = return True + } + ] +pageActions TermShowR = + [ PageActionPrime $ MenuItem + { menuItemLabel = "Neues Semester anlegen" + , menuItemIcon = Nothing + , menuItemRoute = TermEditR + , menuItemAccessCallback' = return True + } + ] +pageActions (TermCourseListR tid) = + [ PageActionPrime $ MenuItem + { menuItemLabel = "Neuen Kurs anlegen" + , menuItemIcon = Just "book" + , menuItemRoute = CourseNewR + , menuItemAccessCallback' = return True + } + , PageActionPrime $ MenuItem + { menuItemLabel = "Semster editieren" + , menuItemIcon = Nothing + , menuItemRoute = TermEditExistR tid , menuItemAccessCallback' = return True } ] @@ -826,55 +880,25 @@ pageActions (CSubmissionR tid csh shn cid SubShowR) = _ -> return False } ] -pageActions TermShowR = +pageActions (CSheetR tid csh shn SCorrR) = [ PageActionPrime $ MenuItem - { menuItemLabel = "Neues Semester anlegen" - , menuItemIcon = Nothing - , menuItemRoute = TermEditR + { menuItemLabel = "Abgaben" + , menuItemIcon = Nothing + , menuItemRoute = CSheetR tid csh shn SSubsR , menuItemAccessCallback' = return True } ] -pageActions (TermCourseListR tid) = +pageActions (CorrectionsR) = [ PageActionPrime $ MenuItem - { menuItemLabel = "Neuen Kurs anlegen" - , menuItemIcon = Just "book" - , menuItemRoute = CourseNewR - , menuItemAccessCallback' = return True - } - , PageActionPrime $ MenuItem - { menuItemLabel = "Semster editieren" - , menuItemIcon = Nothing - , menuItemRoute = TermEditExistR tid + { menuItemLabel = "Korrekturen hochladen" + , menuItemIcon = Nothing + , menuItemRoute = CorrectionsUploadR , menuItemAccessCallback' = return True } ] -pageActions (ProfileR) = - [ PageActionPrime $ MenuItem - { menuItemLabel = "Gespeicherte Daten anzeigen" - , menuItemIcon = Just "book" - , menuItemRoute = ProfileDataR - , menuItemAccessCallback' = return True - } - ] -pageActions (HomeR) = - [ --- NavbarAside $ MenuItem --- { menuItemLabel = "Benutzer" --- , menuItemIcon = Just "users" --- , menuItemRoute = UsersR --- , menuItemAccessCallback' = return True --- } --- , - NavbarAside $ MenuItem - { menuItemLabel = "AdminDemo" - , menuItemIcon = Just "screwdriver" - , menuItemRoute = AdminTestR - , menuItemAccessCallback' = return True - } - ] - pageActions _ = [] + i18nHeading :: (MonadWidget m, RenderMessage site msg, HandlerSite m ~ site) => msg -> m () i18nHeading msg = liftWidgetT $ toWidget =<< getMessageRender <*> pure msg diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 0fc43773d..40b2eff15 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -117,8 +117,8 @@ colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _) } -> encry type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) -makeCorrectionsTable :: ( IsDBTable m x, DBOutput CorrectionTableData r', ToSortable h, Functor h ) - => _ -> Colonnade h r' (DBCell m x) -> PSValidator m x -> Handler (DBResult m x) +makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h ) + => _ -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> Handler (DBResult m x) makeCorrectionsTable whereClause colChoices psValidator = do let tableData :: CorrectionTableExpr -> E.SqlQuery _ tableData ((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do @@ -135,6 +135,7 @@ makeCorrectionsTable whereClause colChoices psValidator = do dbTable psValidator $ DBTable { dbtSQLQuery = tableData , dbtColonnade = colChoices + , dbtProj = return , dbtSorting = [ ( "term" , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseTerm ) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 6b75a8f89..5d3ee913c 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -68,6 +68,7 @@ getTermCourseListR tid = do Nothing -> MsgCourseMembersCount num Just max -> MsgCourseMembersCountLimited num max ] + , dbtProj = return . dbrOutput , dbtSorting = Map.fromList [ ( "shorthand" , SortColumn $ \course -> course E.^. CourseShorthand diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 3f3c2184f..de28d7927 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -32,16 +32,13 @@ import Text.Shakespeare.Text -- import qualified Data.UUID.Cryptographic as UUID --- Some constants: --- nrSheetDeadlines :: Int64 --- nrSheetDeadlines = 10 +-- CONSTANTS: TODO: make configurable elsewhere offSheetDeadlines :: NominalDiffTime offSheetDeadlines = 15 ---nrExamDeadlines = 10 +offCourseDeadlines :: NominalDiffTime +offCourseDeadlines = 15 +--offExamDeadlines :: NominalDiffTime --offExamDeadlines = 15 --- nrCourseDeadlines :: Int64 --- nrCourseDeadlines = 12 ---offCourseDeadlines = 15 @@ -56,15 +53,14 @@ getHomeR = do homeAnonymous :: Handler Html homeAnonymous = do cTime <- liftIO getCurrentTime - let fTime = addUTCTime (offSheetDeadlines * nominalDay) cTime + let fTime = addUTCTime (offCourseDeadlines * nominalDay) cTime let tableData :: E.SqlExpr (Entity Course) -> E.SqlQuery (E.SqlExpr (Entity Course)) tableData course = do - E.where_ $ (E.not_ $ E.isNothing $ course E.^. CourseRegisterFrom) + E.where_ $ (E.not_ $ E.isNothing $ course E.^. CourseRegisterFrom) -- TODO: do this with isAuthorized in dbtProj E.&&. (course E.^. CourseRegisterFrom E.<=. E.val (Just cTime)) E.&&. ((E.isNothing $ course E.^. CourseRegisterTo) E.||. (course E.^. CourseRegisterTo E.>=. E.val (Just cTime))) --- E.limit nrCourseDeadlines return course colonnade :: Colonnade Sortable (DBRow (Entity Course)) (DBCell (WidgetT UniWorX IO) ()) @@ -82,6 +78,7 @@ homeAnonymous = do courseTable <- dbTable def $ DBTable { dbtSQLQuery = tableData , dbtColonnade = colonnade + , dbtProj = return , dbtSorting = Map.fromList [ ( "term" , SortColumn $ \(course) -> course E.^. CourseTerm @@ -129,7 +126,7 @@ homeUser uid = do E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid E.&&. sheet E.^. SheetActiveTo E.>=. E.val cTime E.&&. sheet E.^. SheetActiveTo E.<=. E.val fTime - -- E.limit nrSheetDeadlines + -- E.limit nrSheetDeadlines -- arbitrary limits are not intuitive return ( course E.^. CourseTerm , course E.^. CourseShorthand @@ -148,11 +145,11 @@ homeUser uid = do colonnade = mconcat [ -- dbRow sortable (Just "course") (textCell MsgCourse) $ \DBRow{ dbrOutput=(E.Value tid, E.Value csh, _, _, _) } -> - cell [whamlet|#{display csh}|] + anchorCell (CourseR tid csh CShowR) (toWidget $ display csh) , sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(E.Value tid, _,_,_,_) } -> textCell $ display tid , sortable (Just "sheet") (textCell MsgSheet) $ \DBRow{ dbrOutput=(E.Value tid, E.Value csh, E.Value shn, _, _) } -> - cell [whamlet|#{display shn}|] + anchorCell (CSheetR tid csh shn SShowR) (toWidget $ display shn) , sortable (Just "deadline") (textCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, E.Value deadline, _) } -> cell $ formatTime SelFormatDateTime deadline >>= toWidget , sortable (Just "done") (textCell MsgDone) $ \(DBRow{ dbrOutput=(E.Value tid, E.Value csh, E.Value shn, _, E.Value mbsid) }) -> @@ -165,6 +162,8 @@ homeUser uid = do sheetTable <- dbTable validator $ DBTable { dbtSQLQuery = tableData , dbtColonnade = colonnade + , dbtProj = \dbRow@DBRow{ dbrOutput = (E.Value tid, E.Value csh, E.Value shn, _, _) } + -> dbRow <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid csh shn SShowR) False) , dbtSorting = Map.fromList [ ( "term" , SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseTerm diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index d85e9694a..534cb49f2 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -1,6 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} @@ -11,7 +12,6 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE MultiWayIf, LambdaCase #-} {-# LANGUAGE TupleSections #-} @@ -78,9 +78,10 @@ data SheetForm = SheetForm , sfActiveTo :: UTCTime , sfSheetF :: Maybe (Source Handler (Either FileId File)) , sfHintFrom :: Maybe UTCTime - , sfHintF :: Maybe FileInfo + , sfHintF :: Maybe (Source Handler (Either FileId File)) , sfSolutionFrom :: Maybe UTCTime - , sfSolutionF :: Maybe FileInfo + , sfSolutionF :: Maybe (Source Handler (Either FileId File)) + , sfMarkingF :: Maybe (Source Handler (Either FileId File)) -- Keine SheetId im Formular! } @@ -94,25 +95,36 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do E.&&. sheetFile E.^. SheetFileType E.==. E.val fType return (file E.^. FileId) | otherwise = return Set.empty - + mr <- getMsgRenderer + ctime <- liftIO $ getCurrentTime (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm <$> areq textField (fsb "Name") (sfName <$> template) <*> aopt htmlField (fsb "Hinweise für Teilnehmer") (sfDescription <$> template) <*> sheetTypeAFormReq (fsb "Bewertung") (sfType <$> template) <*> sheetGroupAFormReq (fsb "Abgabegruppengröße") (sfGrouping <$> template) <*> aopt htmlField (fsb "Hinweise für Korrektoren") (sfMarkingText <$> template) - <*> aopt utcTimeField (fsb "Sichtbar ab") (sfVisibleFrom <$> template) - <*> areq utcTimeField (fsb "Abgabe ab") (sfActiveFrom <$> template) - <*> areq utcTimeField (fsb "Abgabefrist") (sfActiveTo <$> template) + <*> aopt utcTimeField (fslI MsgSheetVisibleFrom + & setTooltip "Ohne Datum ist das Blatt komplett unsichtbar, z.B. weil es noch nicht fertig ist.") + ((sfVisibleFrom <$> template) <|> pure (Just ctime)) + <*> areq utcTimeField (fslI MsgSheetActiveFrom + & setTooltip "Abgabe und Dateien zur Aufgabenstellung sind erst ab diesem Datum zugänglich") + (sfActiveFrom <$> template) + <*> areq utcTimeField (fslI MsgSheetActiveTo) (sfActiveTo <$> template) <*> aopt (multiFileField $ oldFileIds SheetExercise) (fsb "Aufgabenstellung") (sfSheetF <$> template) - <*> aopt utcTimeField (fsb "Hinweis ab") (sfHintFrom <$> template) - <*> fileAFormOpt (fsb "Hinweis") - <*> aopt utcTimeField (fsb "Lösung ab") (sfSolutionFrom <$> template) - <*> fileAFormOpt (fsb "Lösung") + <*> aopt utcTimeField (fslpI MsgSheetHintFrom "Datum, sonst nur für Korrektoren" + & setTooltip "Ohne Datum nie für Teilnehmer sichtbar, Korrektoren können diese Dateien immer herunterladen") + (sfHintFrom <$> template) + <*> aopt (multiFileField $ oldFileIds SheetHint) (fslI MsgSheetHint) (sfHintF <$> template) + <*> aopt utcTimeField (fslpI MsgSheetSolutionFrom "Datum, sonst nur für Korrektoren" + & setTooltip "Ohne Datum nie für Teilnehmer sichtbar, Korrektoren können diese Dateien immer herunterladen") + (sfSolutionFrom <$> template) + <*> aopt (multiFileField $ oldFileIds SheetSolution) (fslI MsgSheetSolution) (sfSolutionF <$> template) + <*> aopt (multiFileField $ oldFileIds SheetMarking) (fslI MsgSheetMarking + & setTooltip "Hinweise zur Korrektur, sichtbar nur für Korrektoren") (sfMarkingF <$> template) <* submitButton return $ case result of FormSuccess sheetResult - | errorMsgs <- validateSheet sheetResult + | errorMsgs <- validateSheet mr sheetResult , not $ null errorMsgs -> (FormFailure errorMsgs, [whamlet| @@ -127,62 +139,69 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do ) _ -> (result, widget) where - validateSheet :: SheetForm -> [Text] - validateSheet (SheetForm{..}) = + validateSheet :: MsgRenderer -> SheetForm -> [Text] + validateSheet (MsgRenderer {..}) (SheetForm{..}) = [ msg | (False, msg) <- - [ ( maybe True (sfActiveFrom >=) sfVisibleFrom - , "Sichtbarkeit muss vor Beginn der Abgabefrist liegen." - ) - , ( sfActiveTo >= sfActiveFrom - , "Ende der Abgabefrist muss nach deren Beginn liegen." - ) - -- TODO: continue validation here!!! + [ ( sfVisibleFrom <= Just sfActiveFrom , render MsgSheetErrVisibility) + , ( sfActiveFrom <= sfActiveTo , render MsgSheetErrDeadlineEarly) + , ( NTop sfHintFrom >= NTop (Just sfActiveFrom) , render MsgSheetErrHintEarly) + , ( NTop sfSolutionFrom >= NTop (Just sfActiveTo) , render MsgSheetErrSolutionEarly) ] ] --- List Sheets --- getSheetListCID :: CourseId -> Handler Html --- getSheetListCID cid = getSheetList =<< --- (Entity cid) <$> (runDB $ get404 cid) - getSheetListR :: TermId -> Text -> Handler Html getSheetListR tid csh = do - -- mbAid <- maybeAuthId - (Entity cid course, sheets) <- runDB $ do - entCourse <- getBy404 $ CourseTermShort tid csh - rawSheets <- selectList [SheetCourse ==. entityKey entCourse] [Desc SheetActiveFrom] - sheets <- forM rawSheets $ \(Entity sid sheet) -> do - let sheetsub = [SubmissionSheet ==. sid] - submissions <- count sheetsub - rated <- count $ (SubmissionRatingTime !=. Nothing):sheetsub - return (sid, sheet, (submissions, rated)) - return (entCourse, sheets) - let csh = courseShorthand course - let tid = courseTerm course - let colBase = mconcat - [ headed "Blatt" $ \(sid,sheet,_) -> simpleLink (toWgt $ sheetName sheet) $ CSheetR tid csh (sheetName sheet) SShowR - , headed "Abgabe ab" $ \(_,Sheet{..},_) -> formatTime SelFormatDateTime sheetActiveFrom >>= toWidget - , headed "Abgabe bis" $ \(_,Sheet{..},_) -> formatTime SelFormatDateTime sheetActiveTo >>= toWidget - , headed "Bewertung" $ toWgt . display . sheetType . snd3 - ] - let colAdmin = mconcat -- only show edit button for allowed course assistants - [ headed "Korrigiert" $ toWgt . snd . trd3 - , headed "Eingereicht" $ toWgt . fst . trd3 - , headed "" $ \s -> simpleLink "Edit" $ CSheetR tid csh (sheetName $ snd3 s) SEditR - , headed "" $ \s -> simpleLink "Delete" $ CSheetR tid csh (sheetName $ snd3 s) SDelR - ] - showAdmin <- case sheets of - ((_,firstSheet,_):_) -> do - setUltDestCurrent - (Authorized ==) <$> isAuthorized (CSheetR tid csh (sheetName firstSheet) SEditR) False - _otherwise -> return False - let colSheets = if showAdmin - then colBase `mappend` colAdmin - else colBase + Entity cid _ <- runDB . getBy404 $ CourseTermShort tid csh + let + sheetData :: E.SqlExpr (E.Entity Sheet) -> E.SqlQuery (E.SqlExpr (Entity Sheet), E.SqlExpr (E.Value (Maybe UTCTime))) + sheetData sheet = do + let sheetEdit = E.sub_select . E.from $ \sheetEdit -> do + E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId + return . E.max_ $ sheetEdit E.^. SheetEditTime + E.where_ $ sheet E.^. SheetCourse E.==. E.val cid + return (sheet, sheetEdit) + sheetCol = widgetColonnade . mconcat $ + [ sortable (Just "name") (i18nCell MsgSheet) + $ \(Entity _ Sheet{..}, _) -> anchorCell (CSheetR tid csh sheetName SShowR) (toWidget sheetName) + , sortable (Just "last-edit") (i18nCell MsgLastEdit) + $ \(_, E.Value mEditTime) -> case mEditTime of + Just editTime -> cell $ formatTime SelFormatDateTime (editTime :: UTCTime) >>= toWidget + Nothing -> mempty + , sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom) + $ \(Entity _ Sheet{..}, _) -> cell $ formatTime SelFormatDateTime sheetActiveFrom >>= toWidget + , sortable (Just "submission-until") (i18nCell MsgSheetActiveTo) + $ \(Entity _ Sheet{..}, _) -> cell $ formatTime SelFormatDateTime sheetActiveTo >>= toWidget + , sortable Nothing (i18nCell MsgSheetType) + $ \(Entity _ Sheet{..}, _) -> textCell $ display sheetType + ] + psValidator = def + & defaultSorting [("submission-since", SortAsc)] + table <- dbTable psValidator $ DBTable + { dbtSQLQuery = sheetData + , dbtColonnade = sheetCol + , dbtProj = \DBRow{ dbrOutput = dbrOutput@(Entity _ Sheet{..}, _) } + -> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid csh sheetName SShowR) False) + , dbtSorting = Map.fromList + [ ( "name" + , SortColumn $ \sheet -> sheet E.^. SheetName + ) + , ( "last-edit" + , SortColumn $ \sheet -> E.sub_select . E.from $ \sheetEdit -> E.distinctOnOrderBy [E.desc $ sheetEdit E.?. SheetEditTime] $ do + return $ sheetEdit E.?. SheetEditTime + ) + , ( "submission-since" + , SortColumn $ \sheet -> sheet E.^. SheetActiveFrom + ) + , ( "submission-until" + , SortColumn $ \sheet -> sheet E.^. SheetActiveTo + ) + ] + , dbtFilter = Map.fromList + [] + , dbtStyle = def + , dbtIdent = "sheets" :: Text + } defaultLayout $ do - setTitle $ toHtml $ csh <> " Übungsblätter" - if null sheets - then [whamlet|Es wurden noch keine Übungsblätter angelegt.|] - else Yesod.encodeWidgetTable tableDefault colSheets sheets + $(widgetFile "sheetList") -- Show single sheet @@ -217,20 +236,18 @@ getSShowR tid csh shn = do [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> stringCell ftype , sortable (Just "path") "Dateiname" $ anchorCell' (\(E.Value fName,_,E.Value fType) -> CSheetR tid csh shn (SFileR fType fName)) (\(E.Value fName,_,_) -> str2widget fName) - , sortable Nothing "Freigabe" $ \(_,_, E.Value ftype) -> - case ftype of - SheetExercise -> textCell $ display $ sheetActiveFrom sheet - SheetHint -> textCell $ display $ sheetHintFrom sheet - SheetSolution -> textCell $ display $ sheetSolutionFrom sheet , sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> cell $ formatTime SelFormatDateTime (modified :: UTCTime) >>= toWidget ] - fileTable <- dbTable def $ DBTable + let psValidator = def + & defaultSorting [("type", SortAsc), ("path", SortAsc)] + fileTable <- dbTable psValidator $ DBTable { dbtSQLQuery = fileData , dbtColonnade = colonnadeFiles + , dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) } + -> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid csh shn $ SFileR fType fName) False) , dbtStyle = def , dbtFilter = Map.empty , dbtIdent = "files" :: Text - -- TODO: Add column for and visibility date , dbtSorting = [ ( "type" , SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> sheetFile E.^. SheetFileType ) @@ -242,10 +259,16 @@ getSShowR tid csh shn = do ) ] } + (hasHints, hasSolution) <- runDB $ do + hasHints <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetHint ] + hasSolution <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetSolution ] + return (hasHints, hasSolution) defaultLayout $ do setTitle $ toHtml $ T.append "Übung " $ sheetName sheet sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet sheetTo <- formatTime SelFormatDateTime $ sheetActiveTo sheet + hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet + solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet $(widgetFile "sheetShow") getSFileR :: TermId -> Text -> Text -> SheetFileType -> FilePath -> Handler TypedContent @@ -289,12 +312,13 @@ getSEditR :: TermId -> Text -> Text -> Handler Html getSEditR tid csh shn = do (sheetEnt, sheetFileIds) <- runDB $ do ent <- fetchSheet tid csh shn - fIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do + allfIds <- E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val (entityKey ent) - E.&&. sheetFile E.^. SheetFileType E.==. E.val SheetExercise - return (file E.^. FileId) - return (ent, fIds) + return (sheetFile E.^. SheetFileType, file E.^. FileId) + let ftIds :: SheetFileType -> Set FileId + ftIds ft = Set.fromList $ mapMaybe (\(E.Value t, E.Value i) -> i <$ guard (ft==t)) allfIds + return (ent, ftIds) let sid = entityKey sheetEnt let oldSheet@(Sheet {..}) = entityVal sheetEnt let template = Just $ SheetForm @@ -306,11 +330,12 @@ getSEditR tid csh shn = do , sfVisibleFrom = sheetVisibleFrom , sfActiveFrom = sheetActiveFrom , sfActiveTo = sheetActiveTo - , sfSheetF = Just . yieldMany . map Left $ Set.toList sheetFileIds + , sfSheetF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetExercise , sfHintFrom = sheetHintFrom - , sfHintF = Nothing -- TODO + , sfHintF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetHint , sfSolutionFrom = sheetSolutionFrom - , sfSolutionF = Nothing -- TODO + , sfSolutionF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetSolution + , sfMarkingF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetMarking } let action newSheet = do replaceRes <- myReplaceUnique sid $ newSheet @@ -350,8 +375,9 @@ handleSheetEdit tid csh msId template dbAction = do Nothing -> False <$ addMessageI "danger" (MsgSheetNameDup tid csh sfName) (Just sid) -> do -- save files in DB: whenIsJust sfSheetF $ insertSheetFile' sid SheetExercise - whenIsJust sfHintF $ insertSheetFile sid SheetHint - whenIsJust sfSolutionF $ insertSheetFile sid SheetSolution + whenIsJust sfHintF $ insertSheetFile' sid SheetHint + whenIsJust sfSolutionF $ insertSheetFile' sid SheetSolution + whenIsJust sfMarkingF $ insertSheetFile' sid SheetMarking insert_ $ SheetEdit aid actTime sid addMessageI "info" $ MsgSheetEditOk tid csh sfName return True diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 1f0d3c5a4..483443b75 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -290,6 +290,7 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do smid2ArchiveTable (smid,cid) = DBTable { dbtSQLQuery = submissionFiles smid , dbtColonnade = colonnadeFiles cid + , dbtProj = return . dbrOutput , dbtStyle = def , dbtIdent = "files" :: Text , dbtSorting = [ ( "path" diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 28cb87731..89547f436 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -81,6 +81,7 @@ getTermShowR = do table <- dbTable def $ DBTable { dbtSQLQuery = termData , dbtColonnade = colonnadeTerms + , dbtProj = return . dbrOutput , dbtSorting = [ ( "start" , SortColumn $ \term -> term E.^. TermStart ) diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 47a27cbaa..ef9d012e1 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -80,6 +80,7 @@ getUsersR = do userList <- dbTable psValidator $ DBTable { dbtSQLQuery = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User)) , dbtColonnade = colonnadeUsers + , dbtProj = return , dbtSorting = Map.fromList [ ( "display-name" , SortColumn $ \user -> user E.^. UserDisplayName diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index b10f50db3..1b6f19ba2 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -15,12 +15,13 @@ , TupleSections , RankNTypes , MultiWayIf + , FunctionalDependencies #-} module Handler.Utils.Table.Pagination ( SortColumn(..), SortDirection(..) , FilterColumn(..), IsFilterColumn - , DBRow(..), DBOutput + , DBRow(..) , DBStyle(..), DBEmptyStyle(..) , DBTable(..), IsDBTable(..), DBCell(..) , PaginationSettings(..), PaginationInput(..), piIsUnset @@ -56,6 +57,7 @@ import qualified Data.CaseInsensitive as CI import Control.Monad.RWS hiding ((<>), Foldable(..), mapM_, forM_) import Control.Monad.Writer hiding ((<>), Foldable(..), mapM_, forM_) import Control.Monad.Reader (ReaderT(..), mapReaderT) +import Control.Monad.Trans.Maybe import Data.Map (Map, (!)) import qualified Data.Map as Map @@ -121,16 +123,6 @@ data DBRow r = DBRow , dbrIndex, dbrCount :: Int64 } deriving (Show, Read, Eq, Ord) -class DBOutput r r' where - dbProj :: r -> r' - -instance DBOutput (DBRow r) (DBRow r) where - dbProj = id -instance DBOutput (DBRow r) r where - dbProj = dbrOutput -instance DBOutput (DBRow r) (Int64, r) where - dbProj = (,) <$> dbrIndex <*> dbrOutput - data DBEmptyStyle = DBESNoHeading | DBESHeading deriving (Enum, Bounded, Ord, Eq, Show, Read) @@ -152,11 +144,12 @@ instance Default DBStyle where data DBTable m x = forall a r r' h i t. ( ToSortable h, Functor h - , E.SqlSelect a r, DBOutput (DBRow r) r' + , E.SqlSelect a r , PathPiece i , E.From E.SqlQuery E.SqlExpr E.SqlBackend t ) => DBTable { dbtSQLQuery :: t -> E.SqlQuery a + , dbtProj :: DBRow r -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) r' , dbtColonnade :: Colonnade h r' (DBCell m x) , dbtSorting :: Map (CI Text) (SortColumn t) , dbtFilter :: Map (CI Text) (FilterColumn t) @@ -328,7 +321,7 @@ instance IsDBTable m a => IsString (DBCell m a) where dbTable :: forall m x. IsDBTable m x => PSValidator m x -> DBTable m x -> Handler (DBResult m x) -dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), dbtColonnade = (lmap dbProj -> dbtColonnade), dbtStyle = DBStyle{..}, .. }) = do +dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), dbtStyle = DBStyle{..}, .. }) = do let sortingOptions = mkOptionList [ Option t' (t, d) t' @@ -380,11 +373,14 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), runDB $ do rows' <- E.select $ (,) <$> pure (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64)) <*> sqlQuery' + let mapMaybeM f = fmap catMaybes . mapM (runMaybeT . f) + + rows <- mapMaybeM dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrOutput)) -> DBRow{..}) $ zip [succ (psPage * psLimit)..] rows' + let rowCount | (E.Value n, _):_ <- rows' = n | otherwise = 0 - rows = map (\(dbrIndex, (E.Value dbrCount, dbrOutput)) -> DBRow{..}) $ zip [succ (psPage * psLimit)..] rows' table' :: WriterT x m Widget table' = do diff --git a/src/Utils.hs b/src/Utils.hs index 7132bd178..1ec44e5ba 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -153,6 +153,11 @@ trd3 (_,_,z) = z ----------- -- Maybe -- ----------- + +toMaybe :: Bool -> a -> Maybe a +toMaybe True = Just +toMaybe False = const Nothing + whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () whenIsJust (Just x) f = f x whenIsJust Nothing _ = return () diff --git a/templates/sheetList.hamlet b/templates/sheetList.hamlet new file mode 100644 index 000000000..697c30b25 --- /dev/null +++ b/templates/sheetList.hamlet @@ -0,0 +1 @@ +^{table} diff --git a/templates/sheetShow.hamlet b/templates/sheetShow.hamlet index d10f3dc0c..71b1cf633 100644 --- a/templates/sheetShow.hamlet +++ b/templates/sheetShow.hamlet @@ -19,5 +19,15 @@ Abgabe bis #{sheetTo} + $maybe hints <- hintsFrom <* guard hasHints +

+ Hinweise ab + #{hints} + + $maybe solution <- solutionFrom <* guard hasSolution +

+ Lösung ab + #{solution} +

Dateien ^{fileTable}