fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' into 'live'

Browse Source 
Kurslisten live schalten

See merge request !64
This commit is contained in:
Steffen Jost 2018-07-31 17:08:07 +02:00
commit e5821fb135
8 changed files with 235 additions and 80 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
ChangeLog.md
View File

@ -1,4 +1,11 @@
* Version 31.07.2018
Viele Verbesserung zur Anzeige von Korrekturen
Kursliste über alle Semester hinweg (Top-Level-Navigation "Kurse"), wird in Zukunft Filter/Suchfunktion erhalten
* Version 10.07.2018
Bugfixes, wählbares Format für Datum
* Version 04.07.2018

6
messages/de.msg
View File

@ -5,6 +5,7 @@ BtnRegister: Anmelden
BtnDeregister: Abmelden
BtnHijack: Sitzung übernehmen
Registered: Angemeldet
RegisterFrom: Anmeldungen von
RegisterTo: Anmeldungen bis
DeRegUntil: Abmeldungen bis
@ -29,6 +30,7 @@ TermPlaceholder: W/S + vierstellige Jahreszahl
LectureStart: Beginn Vorlesungen
Course: Kurs
CourseShort: Kürzel
CourseNoCapacity: In diesem Kurs sind keine Plätze mehr frei.
CourseRegisterOk: Sie wurden angemeldet
CourseDeregisterOk: Sie wurden abgemeldet
@ -40,6 +42,7 @@ CourseNewDupShort tid@TermId courseShortHand@CourseShorthand: Kurs #{display ti
CourseEditDupShort tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester.
FFSheetName: Name
TermCourseListHeading tid@TermId: Kursübersicht #{display tid}
CourseListTitle: Alle Kurse
TermCourseListTitle tid@TermId: Kurse #{display tid}
CourseNewHeading: Neuen Kurs anlegen
CourseEditHeading tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} editieren
@ -190,6 +193,7 @@ NotPassed: Nicht bestanden
RatingTime: Korrigiert
RatingComment: Kommentar
SubmissionUsers: Studenten
Rating: Korrektur
RatingPoints: Punkte
RatingFiles: Korrigierte Dateien
@ -227,4 +231,4 @@ EditedBy name@Text time@Text: Durch #{name} um #{time}
LastEdit: Letzte Änderung
SubmissionFilesIgnored: Es wurden Dateien in der hochgeladenen Abgabe ignoriert:
SubmissionDoesNotExist smid@CryptoFileNameSubmission: Es existiert keine Abgabe mit Nummer #{toPathPiece smid}.
SubmissionDoesNotExist smid@CryptoFileNameSubmission: Es existiert keine Abgabe mit Nummer #{toPathPiece smid}.

7
src/Foundation.hs
View File

@ -668,7 +668,7 @@ instance YesodBreadcrumbs UniWorX where
breadcrumb (TermEditExistR tid) = return ("Editieren" , Just $ TermCourseListR tid)
breadcrumb (TermCourseListR (unTermKey -> tid)) = getMessageRender <&> \mr -> (mr $ ShortTermIdentifier tid, Just TermShowR)
breadcrumb CourseListR = return ("Kurs" , Just HomeR)
breadcrumb CourseListR = return ("Kurse" , Just HomeR)
breadcrumb CourseNewR = return ("Neu" , Just CourseListR)
breadcrumb (CourseR tid csh CShowR) = return (CI.original csh, Just $ TermCourseListR tid)
-- (CourseR tid csh CRegisterR) -- is POST only
@ -744,7 +744,7 @@ defaultLinks = -- Define the menu items of the header.
, NavbarAside $ MenuItem
{ menuItemLabel = "Kurse"
, menuItemIcon = Just "calendar-alt"
, menuItemRoute = TermCurrentR -- should be CourseListActiveR or similar in the future
, menuItemRoute = CourseListR
, menuItemAccessCallback' = return True
}
, NavbarAside $ MenuItem
@ -964,7 +964,8 @@ pageHeading (TermEditExistR tid)
pageHeading (TermCourseListR tid)
= Just . i18nHeading . MsgTermCourseListHeading $ tid
-- CourseListR -- just a redirect to TermCurrentR
pageHeading (CourseListR)
= Just $ i18nHeading $ MsgCourseListTitle
pageHeading CourseNewR
= Just $ i18nHeading MsgCourseNewHeading
pageHeading (CourseR tid csh CShowR)

39
src/Handler/Corrections.hs
View File

@ -85,19 +85,18 @@ colTerm = sortable (Just "term") (i18nCell MsgTerm)
colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colCourse = sortable (Just "course") (i18nCell MsgCourse)
$ \DBRow{ dbrOutput=(_, _, course, _, _) } -> cell $
$ \DBRow{ dbrOutput=(_, _, course, _, _) } ->
let tid = course ^. _3
csh = course ^. _2
in [whamlet|<a href=@{CourseR tid csh CShowR}>#{display csh}|]
in anchorCell (CourseR tid csh CShowR) [whamlet|#{display csh}|]
colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colSheet = sortable (Just "sheet") (i18nCell MsgSheet)
$ \DBRow{ dbrOutput=(_, sheet, course, _, _) } -> cell $
let tid = course ^. _3
csh = course ^. _2
shn = sheetName $ entityVal sheet
in [whamlet|<a href=@{CSheetR tid csh shn SShowR}>#{display shn}|]
-- textCell $ sheetName $ entityVal sheet
$ \DBRow{ dbrOutput=(_, sheet, course, _, _) } ->
let tid = course ^. _3
csh = course ^. _2
shn = sheetName $ entityVal sheet
in anchorCell (CSheetR tid csh shn SShowR) [whamlet|#{display shn}|]
colCorrector :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case
@ -106,12 +105,15 @@ colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case
colSubmissionLink :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
$ \DBRow{ dbrOutput=(submission, sheet, course, _, _) } -> cell $ do
$ \DBRow{ dbrOutput=(submission, sheet, course, _, _) } ->
let tid = course ^. _3
csh = course ^. _2
shn = sheetName $ entityVal sheet
cid <- encrypt (entityKey submission :: SubmissionId)
[whamlet|<a href=@{CSubmissionR tid csh shn cid SubShowR}>#{display cid}|]
mkCid = encrypt (entityKey submission :: SubmissionId) -- TODO: executed twice
mkRoute = do
cid <- mkCid
return $ CSubmissionR tid csh shn cid SubShowR
in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|])
colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData CryptoFileNameSubmission Bool)))
colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId
@ -121,6 +123,15 @@ colSubmittors = sortable Nothing (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutp
cell = listCell (Map.toList users) $ \(userId, User{..}) -> anchorCellM (AdminUserR <$> encrypt userId) (toWidget userDisplayName)
in cell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
colRating :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(Entity subId Submission{..}, Entity _ Sheet{..}, course, _, _) } ->
let tid = course ^. _3
csh = course ^. _2
-- shn = sheetName
mkRoute = do
cid <- encrypt subId
return $ CSubmissionR tid csh sheetName cid CorrectionR
in anchorCellM mkRoute $(widgetFile "widgets/rating")
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))
@ -165,6 +176,9 @@ makeCorrectionsTable whereClause colChoices psValidator = do
, ( "corrector"
, SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector) -> corrector E.?. UserDisplayName
)
, ( "rating"
, SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingPoints
)
]
, dbtFilter = [ ( "term"
, FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) tids -> if
@ -317,6 +331,7 @@ postCorrectionsR = do
, colCourse
, colSheet
, colSubmissionLink
, colRating
] -- Continue here
psValidator = def
& restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
@ -337,6 +352,7 @@ postCCorrectionsR tid csh = do
, colCorrector
, colSubmittors
, colSubmissionLink
, colRating
] -- Continue here
psValidator = def
correctionsR whereClause colonnade psValidator $ Map.fromList
@ -355,6 +371,7 @@ postSSubsR tid csh shn = do
, colCorrector
, colSubmittors
, colSubmissionLink
, colRating
]
psValidator = def
correctionsR whereClause colonnade psValidator $ Map.fromList

179
src/Handler/Course.hs
View File

@ -1,7 +1,11 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
@ -18,6 +22,7 @@ import qualified Data.Text as T
import Data.Function ((&))
-- import Yesod.Form.Bootstrap3
import qualified Data.Set as Set
import qualified Data.Map as Map
import Colonnade hiding (fromMaybe,bool)
@ -28,8 +33,117 @@ import qualified Database.Esqueleto as E
import qualified Data.UUID.Cryptographic as UUID
getCourseListR :: Handler TypedContent
getCourseListR = redirect TermCurrentR
type CourseTableData = DBRow (Entity Course, Int64, Bool)
colCourse :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colCourse = sortable (Just "course") (i18nCell MsgCourse)
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _) } ->
anchorCell (CourseR courseTerm courseShorthand CShowR) [whamlet|#{display courseName}|]
colCShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort)
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _) } ->
anchorCell (CourseR courseTerm courseShorthand CShowR) [whamlet|#{display courseShorthand}|]
colTerm :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colTerm = sortable (Just "term") (i18nCell MsgTerm)
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _) } ->
anchorCell (TermCourseListR courseTerm) [whamlet|#{display courseTerm}|]
colRegFrom :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colRegFrom = sortable (Just "register-from") (i18nCell MsgRegisterFrom)
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _) } ->
cell $ traverse (formatTime SelFormatDateTime) courseRegisterFrom >>= maybe mempty toWidget
colRegTo :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colRegTo = sortable (Just "register-to") (i18nCell MsgRegisterTo)
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _) } ->
cell $ traverse (formatTime SelFormatDateTime) courseRegisterTo >>= maybe mempty toWidget
colParticipants :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colParticipants = sortable (Just "participants") (i18nCell MsgCourseMembers)
$ \DBRow{ dbrOutput=(Entity cid Course{..}, currentParticipants, _) } -> textCell $ case courseCapacity of
Nothing -> MsgCourseMembersCount currentParticipants
Just max -> MsgCourseMembersCountLimited currentParticipants max
colRegistered :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colRegistered = sortable (Just "registered") (i18nCell MsgRegistered)
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, registered) } -> tickmarkCell registered
type CourseTableExpr = E.SqlExpr (Entity Course)
course2Participants :: CourseTableExpr -> E.SqlExpr (E.Value Int64)
course2Participants course = E.sub_select . E.from $ \courseParticipant -> do
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
return (E.countRows :: E.SqlExpr (E.Value Int64))
course2Registered :: Maybe UserId -> CourseTableExpr -> E.SqlExpr (E.Value Bool)
course2Registered muid course = E.exists . E.from $ \courseParticipant -> do
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
E.&&. E.just (courseParticipant E.^. CourseParticipantUser) E.==. E.val muid
makeCourseTable :: ( IsDBTable m x, ToSortable h, Functor h )
=> _ -> Colonnade h CourseTableData (DBCell m x) -> PSValidator m x -> Handler (DBResult m x)
makeCourseTable whereClause colChoices psValidator = do
muid <- maybeAuthId
let dbtSQLQuery :: CourseTableExpr -> E.SqlQuery _
dbtSQLQuery course = do
let participants = course2Participants course
let registered = course2Registered muid course
E.where_ $ whereClause (course, participants, registered)
return (course, participants, registered)
dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CourseTableData
dbtProj = traverse $ \(course, E.Value participants, E.Value registered) -> return (course, participants, registered)
dbTable psValidator $ DBTable
{ dbtSQLQuery
, dbtColonnade = colChoices
, dbtProj
, dbtSorting = Map.fromList -- OverloadedLists does not work with the templates here
[ ( "course", SortColumn $ \course -> course E.^. CourseName)
, ( "cshort", SortColumn $ \course -> course E.^. CourseShorthand)
, ( "term" , SortColumn $ \course -> course E.^. CourseTerm)
, ( "register-from", SortColumn $ \course -> course E.^. CourseRegisterFrom)
, ( "register-to", SortColumn $ \course -> course E.^. CourseRegisterTo)
, ( "participants", SortColumn $ course2Participants
)
, ( "registered", SortColumn $ course2Registered muid
)
]
, dbtFilter = Map.fromList -- OverloadedLists does not work with the templates here
[ ( "course", FilterColumn $ \(course :: CourseTableExpr) criterias -> if
| Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
| otherwise -> course E.^. CourseName `E.in_` E.valList (Set.toList criterias)
)
, ( "cshort", FilterColumn $ \(course :: CourseTableExpr) criterias -> if
| Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
| otherwise -> course E.^. CourseShorthand `E.in_` E.valList (Set.toList criterias)
)
, ( "term" , FilterColumn $ \(course :: CourseTableExpr) criterias -> if
| Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
| otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList criterias)
)
]
, dbtStyle = def
, dbtIdent = "courses" :: Text
}
getCourseListR :: Handler Html
getCourseListR = do -- TODO: Suchfunktion für Kurse und Kürzel!!!
muid <- maybeAuthId
let colonnade = widgetColonnade $ mconcat
[ colCourse
, colCShort
, colTerm
, maybe mempty (const colRegistered) muid
]
whereClause = const $ E.val True
validator = def
& defaultSorting [("course", SortAsc), ("term", SortDesc)]
coursesTable <- makeCourseTable whereClause colonnade validator
defaultLayout $ do
setTitleI MsgCourseListTitle
[whamlet|TODO: Such-/Filterfunktion hier einbauen|] -- TODO
$(widgetFile "courses")
getTermCurrentR :: Handler Html
getTermCurrentR = do
@ -37,59 +151,24 @@ getTermCurrentR = do
case fromNullable termIds of
Nothing -> notFound
(Just (maximum -> tid)) -> -- getTermCourseListR tid
redirect $ TermCourseListR tid -- redirect avids problematic breadcrumbs, headings, etc.
redirect $ TermCourseListR tid -- redirect avoids problematic breadcrumbs, headings, etc.
getTermCourseListR :: TermId -> Handler Html
getTermCourseListR tid = do
void . runDB $ get404 tid -- Just ensure the term exists
let
tableData :: E.SqlExpr (Entity Course) -> E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (E.Value Int64))
tableData course = do
E.where_ $ course E.^. CourseTerm E.==. E.val tid
let
participants = E.sub_select . E.from $ \courseParticipant -> do
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
return (E.countRows :: E.SqlExpr (E.Value Int64))
return (course, participants)
psValidator = def
& defaultSorting [("shorthand", SortAsc)]
coursesTable <- dbTable psValidator $ DBTable
{ dbtSQLQuery = tableData
, dbtColonnade = widgetColonnade $ mconcat
[ sortable (Just "shorthand") (textCell MsgCourse) $ anchorCell'
(\(Entity _ Course{..}, _) -> CourseR courseTerm courseShorthand CShowR)
(\(Entity _ Course{..}, _) -> toWidget courseShorthand)
, sortable (Just "register-from") (textCell MsgRegisterFrom) $ \(Entity _ Course{..}, _) -> cell $ traverse (formatTime SelFormatDateTime) courseRegisterFrom >>= maybe mempty toWidget
, sortable (Just "register-to") (textCell MsgRegisterTo) $ \(Entity _ Course{..}, _) -> cell $ traverse (formatTime SelFormatDateTime) courseRegisterTo >>= maybe mempty toWidget
, sortable (Just "members") (textCell MsgCourseMembers) $ \(Entity _ Course{..}, E.Value num) -> textCell $ case courseCapacity of
Nothing -> MsgCourseMembersCount num
Just max -> MsgCourseMembersCountLimited num max
muid <- maybeAuthId
let colonnade = widgetColonnade $ mconcat
[ dbRow
, colCShort
, colRegFrom
, colRegTo
, colParticipants
, maybe mempty (const colRegistered) muid
]
, dbtProj = return . dbrOutput
, dbtSorting = Map.fromList
[ ( "shorthand"
, SortColumn $ \course -> course E.^. CourseShorthand
)
, ( "register-from"
, SortColumn $ \course -> course E.^. CourseRegisterFrom
)
, ( "register-to"
, SortColumn $ \course -> course E.^. CourseRegisterTo
)
, ( "members"
, SortColumn $ \course -> E.sub_select . E.from $ \courseParticipant -> do
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
return (E.countRows :: E.SqlExpr (E.Value Int64))
)
]
, dbtFilter = mempty
, dbtStyle = def
, dbtIdent = "courses" :: Text
}
whereClause = \(course, _, _) -> course E.^. CourseTerm E.==. E.val tid
validator = def
& defaultSorting [("cshort", SortAsc)]
coursesTable <- makeCourseTable whereClause colonnade validator
defaultLayout $ do
setTitleI . MsgTermCourseListTitle $ tid
$(widgetFile "courses")

55
src/Handler/Sheet.hs
View File

@ -156,49 +156,74 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
getSheetListR :: TermId -> CourseShorthand -> Handler Html
getSheetListR tid csh = do
muid <- maybeAuthId
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
sheetData :: E.SqlExpr (Entity Sheet) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity Submission)) `E.InnerJoin` (E.SqlExpr (Maybe (Entity SubmissionUser)))) -> E.SqlQuery (E.SqlExpr (Entity Sheet), E.SqlExpr (E.Value (Maybe UTCTime)),E.SqlExpr (Maybe (Entity Submission)))
sheetData (sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) = do
E.on $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission
E.on $ (E.just $ sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet
E.&&. submissionUser E.?. SubmissionUserUser E.==. E.val muid
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)
return (sheet, sheetEdit, submission)
sheetCol = widgetColonnade . mconcat $
[ sortable (Just "name") (i18nCell MsgSheet)
$ \(Entity _ Sheet{..}, _) -> anchorCell (CSheetR tid csh sheetName SShowR) (toWidget sheetName)
$ \(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
$ \(_, 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
$ \(Entity _ Sheet{..}, _, _) -> cell $ formatTime SelFormatDateTime sheetActiveFrom >>= toWidget
, sortable (Just "submission-until") (i18nCell MsgSheetActiveTo)
$ \(Entity _ Sheet{..}, _) -> cell $ formatTime SelFormatDateTime sheetActiveTo >>= toWidget
$ \(Entity _ Sheet{..}, _, _) -> cell $ formatTime SelFormatDateTime sheetActiveTo >>= toWidget
, sortable Nothing (i18nCell MsgSheetType)
$ \(Entity _ Sheet{..}, _) -> textCell $ display sheetType
$ \(Entity _ Sheet{..}, _, _) -> textCell $ display sheetType
, sortable Nothing (i18nCell MsgSubmission)
$ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of
Nothing -> mempty
(Just (Entity sid Submission{..})) ->
let mkCid = encrypt sid -- TODO: executed twice
mkRoute = do
cid <- mkCid
return $ CSubmissionR tid csh sheetName cid SubShowR
in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|])
, sortable (Just "rating") (i18nCell MsgRating)
$ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of
Nothing -> mempty
(Just (Entity sid Submission{..})) ->
let mkCid = encrypt sid
mkRoute = do
cid <- mkCid
return $ CSubmissionR tid csh sheetName cid CorrectionR
in anchorCellM mkRoute $(widgetFile "widgets/rating")
]
psValidator = def
& defaultSorting [("submission-since", SortAsc)]
table <- dbTable psValidator $ DBTable
{ dbtSQLQuery = sheetData
, dbtColonnade = sheetCol
, dbtProj = \DBRow{ dbrOutput = dbrOutput@(Entity _ Sheet{..}, _) }
, 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
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName
)
, ( "last-edit"
, SortColumn $ \sheet -> E.sub_select . E.from $ \sheetEdit -> E.distinctOnOrderBy [E.desc $ sheetEdit E.?. SheetEditTime] $ do
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> 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
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveFrom
)
, ( "submission-until"
, SortColumn $ \sheet -> sheet E.^. SheetActiveTo
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveTo
)
, ( "rating"
, SortColumn $ \(_ `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) -> submission E.?. SubmissionRatingPoints
)
]
, dbtFilter = Map.fromList

6
src/Handler/Utils/Table/Pagination.hs
View File

@ -34,6 +34,7 @@ module Handler.Utils.Table.Pagination
, widgetColonnade, formColonnade, dbColonnade
, cell, textCell, stringCell, i18nCell
, anchorCell, anchorCell', anchorCellM
, tickmarkCell
, listCell
, formCell, DBFormResult, getDBFormResult
, dbRow, dbSelect
@ -472,6 +473,11 @@ stringCell = textCell
i18nCell = textCell
textCell msg = cell [whamlet|_{msg}|]
tickmarkCell :: (IsDBTable m a) => Bool -> DBCell m a
tickmarkCell True = textCell (tickmark :: Text)
tickmarkCell False = mempty
anchorCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a
anchorCell = anchorCellM . return

16
templates/widgets/rating.hamlet Normal file
View File

@ -0,0 +1,16 @@
$# Display Rating, expects
$# submissionRatingPoints :: Maybe points
$maybe points <- submissionRatingPoints
$case sheetType
$of Bonus{..}
_{MsgAchievedOf points maxPoints}
$of Normal{..}
_{MsgAchievedOf points maxPoints}
$of Pass{..}
$if points >= passingPoints
_{MsgPassed}
$else
_{MsgNotPassed}
$of NotGraded
#{show tickmark}