Merge branch 'master' into 'live'
Master: Exercise Sheets now as dbTable See merge request !57
This commit is contained in:
Steffen Jost
commit
ee4dbbe508
@ -1 +1 @@
|
||||
keter_uni2work.yml
|
||||
keter_testworx.yml
|
||||
@ -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}
|
||||
EditedBy name@Text time@Text: Durch #{name} um #{time}
|
||||
LastEdit: Letzte Änderung
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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|<a href=@{CourseR tid csh CShowR}>#{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|<a href=@{CSheetR tid csh shn SShowR}>#{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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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"
|
||||
|
||||
@ -81,6 +81,7 @@ getTermShowR = do
|
||||
table <- dbTable def $ DBTable
|
||||
{ dbtSQLQuery = termData
|
||||
, dbtColonnade = colonnadeTerms
|
||||
, dbtProj = return . dbrOutput
|
||||
, dbtSorting = [ ( "start"
|
||||
, SortColumn $ \term -> term E.^. TermStart
|
||||
)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 ()
|
||||
|
||||
1
templates/sheetList.hamlet
Normal file
1
templates/sheetList.hamlet
Normal file
@ -0,0 +1 @@
|
||||
^{table}
|
||||
@ -19,5 +19,15 @@
|
||||
Abgabe bis
|
||||
#{sheetTo}
|
||||
|
||||
$maybe hints <- hintsFrom <* guard hasHints
|
||||
<p>
|
||||
Hinweise ab
|
||||
#{hints}
|
||||
|
||||
$maybe solution <- solutionFrom <* guard hasSolution
|
||||
<p>
|
||||
Lösung ab
|
||||
#{solution}
|
||||
|
||||
<h2>Dateien
|
||||
^{fileTable}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user