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

Merge branch 'master' into changelog

Browse Source
This commit is contained in:
Felix Hamann 2019-06-17 22:57:25 +02:00
commit 1f34c72c23
16 changed files with 546 additions and 106 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
.vscode/tasks.json vendored
View File

@ -58,6 +58,11 @@
"type": "npm",
"script": "start",
"problemMatcher": []
},
{
"type": "npm",
"script": "frontend:lint",
"problemMatcher": []
}
]
}

5
CHANGELOG_DE.md
View File

@ -1,5 +1,10 @@
# Changelog
### Version 07.06.2019
- Abgaben können bestimmte Dateinamen und Endungen erzwingen
- Übungsblätter bieten nun Zip-Archive für alle veröffentlichte Dateien, bzw. Dateigruppen an
### Version 20.05.2019
- Komplett überarbeitete Funktionalität zur automatischen Verteilung von Korrekturen

20
frontend/src/utils/async-table/async-table.js
View File

@ -296,20 +296,18 @@ export class AsyncTable {
return el.getAttribute('href') || el.querySelector('a').getAttribute('href');
}
_changePagesizeHandler = (event) => {
const paginationParamKey = this._asyncTableId + '-pagination';
const pagesizeParamKey = this._asyncTableId + '-pagesize';
const pageParamKey = this._asyncTableId + '-page';
const paginationParamEl = this._pagesizeForm.querySelector('[name="' + paginationParamKey + '"]');
_changePagesizeHandler = () => {
const url = new URL(getLocalStorageParameter('currentTableUrl') || window.location.href);
url.searchParams.set(pagesizeParamKey, event.target.value);
url.searchParams.set(pageParamKey, 0);
const formData = new FormData(this._pagesizeForm);
if (paginationParamEl) {
const encodedValue = encodeURIComponent(paginationParamEl.value);
url.searchParams.set(paginationParamKey, encodedValue);
for (var k of url.searchParams.keys()) {
url.searchParams.delete(k);
}
for (var kv of formData.entries()) {
url.searchParams.append(kv[0], kv[1]);
}
this._updateTableFrom(url.href);
}

14
messages/uniworx/de.msg
View File

@ -394,14 +394,22 @@ UpdatedAssignedCorrectorsAuto num@Int64: #{display num} Abgaben wurden unter den
CouldNotAssignCorrectorsAuto num@Int64: #{display num} Abgaben konnten nicht automatisch zugewiesen werden:
SelfCorrectors num@Int64: #{display num} Abgaben wurden Abgebenden als eigenem Korrektor zugeteilt!
CorrectionSheets: Übersicht Korrekturen nach Blättern
CorrectionCorrectors: Übersicht Korrekturen nach Korrektoren
AssignSubmissionExceptionNoCorrectors: Es sind keine Korrektoren eingestellt
AssignSubmissionExceptionNoCorrectorsByProportion: Es sind keine Korrektoren mit Anteil ungleich Null eingestellt
AssignSubmissionExceptionSubmissionsNotFound n@Int: #{tshow n} Abgaben konnten nicht gefunden werden
NrSubmittorsTotal: Abgebende
NrSubmissionsTotal: Abgaben
NrSubmissionsUnassigned: Ohne Korrektor
NoCorrectorAssigned: Ohne Korrektor
NrCorrectors: Korrektoren
NrSubmissionsNewlyAssigned: Neu zugeteilt
NrSubmissionsNotAssigned: Nicht zugeteilt
NrSubmissionsNotCorrected: Unkorrigiert
CorrectionTime: Korrekturdauer (Min/Avg/Max)
AssignSubmissionsRandomWarning: Die Zuteilungsvorschau kann geringfügig von der tatsächlichen Zuteilung abweichen, da die Zuteilung ein randomisierter Prozess ist. Mehrfaches neues Laden dieser Seite vor Betätigung des Zuteilungsknopfes kann dies sichtbar machen.
CorrectionsUploaded num@Int64: #{display num} Korrekturen wurden gespeichert:
NoCorrectionsUploaded: In der hochgeladenen Datei wurden keine Korrekturen gefunden.
@ -829,7 +837,8 @@ MenuCorrectionsUpload: Korrekturen hochladen
MenuCorrectionsDownload: Offene Abgaben herunterladen
MenuCorrectionsCreate: Abgaben registrieren
MenuCorrectionsGrade: Abgaben online korrigieren
MenuCorrectionsAssign: Abgaben automatisch zuteilen
MenuCorrectionsAssign: Zuteilung Korrekturen
MenuCorrectionsAssignSheet name@Text: Zuteilung Korrekturen von #{name}
MenuAuthPreds: Authorisierungseinstellungen
MenuTutorialDelete: Tutorium löschen
MenuTutorialEdit: Tutorium editieren
@ -971,7 +980,7 @@ TutorialDelete: Löschen
CourseTutorials: Übungen
ParticipantsN n@Int: Teilnehmer
ParticipantsN n@Int: #{tshow n} Teilnehmer
TutorialDeleteQuestion: Wollen Sie das unten aufgeführte Tutorium wirklich löschen?
TutorialDeleted: Tutorium gelöscht
@ -1007,6 +1016,7 @@ HealthLDAPAdmins: Anteil der Administratoren, die im LDAP-Verzeichnis gefunden w
HealthSMTPConnect: SMTP-Server kann erreicht werden
HealthWidgetMemcached: Memcached-Server liefert Widgets korrekt aus
CourseParticipants n@Int: Derzeit #{tshow n} angemeldete Kursteilnehmer
CourseParticipantsInvited n@Int: #{tshow n} #{pluralDE n "Einladung" "Einladungen"} per E-Mail verschickt
CourseParticipantsAlreadyRegistered n@Int: #{tshow n} Teilnehmer #{pluralDE n "ist" "sind"} bereits angemeldet
CourseParticipantsRegisteredWithoutField n@Int: #{tshow n} Teilnehmer #{pluralDE n "wurde ohne assoziiertes Hauptfach" "wurden assoziierte Hauptfächer"} angemeldet, da #{pluralDE n "kein eindeutiges Hauptfach bestimmt werden konnte" "keine eindeutigen Hauptfächer bestimmt werden konnten"}

2
models/sheets
View File

@ -4,7 +4,7 @@ Sheet -- exercise sheet for a given course
description Html Maybe
type SheetType -- Does it count towards overall course grade?
grouping SheetGroup -- May participants submit in groups of certain sizes?
markingText Html Maybe -- Instructions for correctors, included in marking templates
markingText Html Maybe -- Instructons for correctors, included in marking templates
visibleFrom UTCTime Maybe -- Invisible to enrolled participants before
activeFrom UTCTime -- Download of questions and submission is permitted afterwards
activeTo UTCTime -- Submission is only permitted before

116
src/Foundation.hs
View File

@ -1427,7 +1427,7 @@ instance YesodBreadcrumbs UniWorX where
breadcrumb (CourseR tid ssh csh CInviteR) = return ("Einladung", Just $ CourseR tid ssh csh CShowR)
breadcrumb (CourseR tid ssh csh (CUserR _)) = return ("Teilnehmer" , Just $ CourseR tid ssh csh CUsersR)
breadcrumb (CourseR tid ssh csh CCorrectionsR) = return ("Abgaben" , Just $ CourseR tid ssh csh CShowR)
breadcrumb (CourseR tid ssh csh CAssignR) = return ("Zuteilen" , Just $ CourseR tid ssh csh CCorrectionsR)
breadcrumb (CourseR tid ssh csh CAssignR) = return ("Korrektur" , Just $ CourseR tid ssh csh CCorrectionsR)
breadcrumb (CourseR tid ssh csh SheetListR) = return ("Übungen" , Just $ CourseR tid ssh csh CShowR)
breadcrumb (CourseR tid ssh csh SheetNewR ) = return ("Neu", Just $ CourseR tid ssh csh SheetListR)
breadcrumb (CourseR tid ssh csh SheetCurrentR) = return ("Aktuelles Blatt", Just $ CourseR tid ssh csh SheetListR)
@ -1744,7 +1744,7 @@ pageActions InstanceR = [
]
pageActions (HelpR) = [
-- MenuItem
-- { menuItemType = PageActionPrime
-- { menuItemType = PageActionPrime
-- , menuItemLabel = MsgInfoLecturerTitle
-- , menuItemIcon = Nothing
-- , menuItemRoute = SomeRoute InfoLecturerR
@ -1754,7 +1754,7 @@ pageActions (HelpR) = [
]
pageActions (ProfileR) =
[ MenuItem
{ menuItemType = PageActionPrime
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuProfileData
, menuItemIcon = Just "book"
, menuItemRoute = SomeRoute ProfileDataR
@ -1762,7 +1762,7 @@ pageActions (ProfileR) =
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionSecondary
{ menuItemType = PageActionSecondary
, menuItemLabel = MsgMenuAuthPreds
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute AuthPredsR
@ -1772,7 +1772,7 @@ pageActions (ProfileR) =
]
pageActions TermShowR =
[ MenuItem
{ menuItemType = PageActionPrime
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuTermCreate
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute TermEditR
@ -1782,7 +1782,7 @@ pageActions TermShowR =
]
pageActions (TermCourseListR tid) =
[ MenuItem
{ menuItemType = PageActionPrime
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCourseNew
, menuItemIcon = Just "book"
, menuItemRoute = SomeRoute CourseNewR
@ -1790,7 +1790,7 @@ pageActions (TermCourseListR tid) =
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionPrime
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuTermEdit
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ TermEditExistR tid
@ -1810,7 +1810,7 @@ pageActions (TermSchoolCourseListR _tid _ssh) =
]
pageActions (CourseListR) =
[ MenuItem
{ menuItemType = PageActionPrime
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCourseNew
, menuItemIcon = Just "book"
, menuItemRoute = SomeRoute CourseNewR
@ -1820,7 +1820,7 @@ pageActions (CourseListR) =
]
pageActions (CourseNewR) = [
MenuItem
{ menuItemType = PageActionPrime
{ menuItemType = PageActionPrime
, menuItemLabel = MsgInfoLecturerTitle
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute InfoLecturerR
@ -1849,7 +1849,7 @@ pageActions (CourseR tid ssh csh CShowR) =
in runDB $ lecturerAccess `or2M` existsVisible
}
, MenuItem
{ menuItemType = PageActionPrime
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuSheetList
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetListR
@ -1877,7 +1877,7 @@ pageActions (CourseR tid ssh csh CShowR) =
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionSecondary
{ menuItemType = PageActionSecondary
, menuItemLabel = MsgMenuCourseMembers
, menuItemIcon = Just "user-graduate"
, menuItemRoute = SomeRoute $ CourseR tid ssh csh CUsersR
@ -1885,7 +1885,7 @@ pageActions (CourseR tid ssh csh CShowR) =
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionSecondary
{ menuItemType = PageActionSecondary
, menuItemLabel = MsgMenuCourseCommunication
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CourseR tid ssh csh CCommR
@ -1893,7 +1893,7 @@ pageActions (CourseR tid ssh csh CShowR) =
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionSecondary
{ menuItemType = PageActionSecondary
, menuItemLabel = MsgMenuCourseEdit
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CourseR tid ssh csh CEditR
@ -1901,7 +1901,7 @@ pageActions (CourseR tid ssh csh CShowR) =
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionSecondary
{ menuItemType = PageActionSecondary
, menuItemLabel = MsgMenuCourseClone
, menuItemIcon = Just "copy"
, menuItemRoute = SomeRoute (CourseNewR, [("tid", toPathPiece tid), ("ssh", toPathPiece ssh), ("csh", toPathPiece csh)])
@ -1909,9 +1909,9 @@ pageActions (CourseR tid ssh csh CShowR) =
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionSecondary
{ menuItemType = PageActionSecondary
, menuItemLabel = MsgMenuCourseDelete
, menuItemIcon = Just "trash"
, menuItemIcon = Just "trash"
, menuItemRoute = SomeRoute $ CourseR tid ssh csh CDeleteR
, menuItemModal = False
, menuItemAccessCallback' = return True
@ -1919,17 +1919,17 @@ pageActions (CourseR tid ssh csh CShowR) =
]
pageActions (CourseR tid ssh csh CCorrectionsR) =
[ MenuItem
{ menuItemType = PageActionPrime
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCorrectionsAssign
, menuItemIcon = Nothing
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CourseR tid ssh csh CAssignR
, menuItemModal = True
, menuItemModal = False
, menuItemAccessCallback' = return True
}
]
pageActions (CourseR tid ssh csh SheetListR) =
[ MenuItem
{ menuItemType = PageActionPrime
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuSheetCurrent
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetCurrentR
@ -1939,7 +1939,7 @@ pageActions (CourseR tid ssh csh SheetListR) =
return True
}
, MenuItem
{ menuItemType = PageActionPrime
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuSheetOldUnassigned
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetOldUnassignedR
@ -1949,25 +1949,25 @@ pageActions (CourseR tid ssh csh SheetListR) =
return True
}
, MenuItem
{ menuItemType = PageActionPrime
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuSubmissions
, menuItemIcon = Nothing
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CourseR tid ssh csh CCorrectionsR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionPrime
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCorrectionsAssign
, menuItemIcon = Nothing
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CourseR tid ssh csh CAssignR
, menuItemModal = True
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionPrime
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCorrectionsOwn
, menuItemIcon = Nothing
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute (CorrectionsR, [ ("corrections-term" , termToText $ unTermKey tid)
, ("corrections-school", CI.original $ unSchoolKey ssh)
, ("corrections-course", CI.original csh)
@ -1988,7 +1988,7 @@ pageActions (CourseR tid ssh csh SheetListR) =
return ok
}
, MenuItem
{ menuItemType = PageActionPrime
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuSheetNew
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetNewR
@ -2082,7 +2082,7 @@ pageActions (CTutorialR tid ssh csh tutn TUsersR) =
]
pageActions (CSheetR tid ssh csh shn SShowR) =
[ MenuItem
{ menuItemType = PageActionPrime
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuSubmissionNew
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionNewR
@ -2094,7 +2094,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
return True
}
, MenuItem
{ menuItemType = PageActionPrime
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuSubmissionOwn
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionOwnR
@ -2118,49 +2118,49 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
, menuItemAccessCallback' = (== Authorized) <$> evalAccessCorrector tid ssh csh
}
, MenuItem
{ menuItemType = PageActionPrime
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCorrectors
, menuItemIcon = Nothing
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SCorrR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionPrime
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuSubmissions
, menuItemIcon = Nothing
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SSubsR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionPrime
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCorrectionsAssign
, menuItemIcon = Nothing
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SAssignR
, menuItemModal = True
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionPrime
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuSheetEdit
, menuItemIcon = Nothing
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SEditR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionSecondary
{ menuItemType = PageActionSecondary
, menuItemLabel = MsgMenuSheetClone
, menuItemIcon = Just "copy"
, menuItemIcon = Just "copy"
, menuItemRoute = SomeRoute (CourseR tid ssh csh SheetNewR, [("shn", toPathPiece shn)])
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionSecondary
{ menuItemType = PageActionSecondary
, menuItemLabel = MsgMenuSheetDelete
, menuItemIcon = Just "trash"
, menuItemIcon = Just "trash"
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SDelR
, menuItemModal = False
, menuItemAccessCallback' = return True
@ -2168,7 +2168,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
]
pageActions (CSheetR tid ssh csh shn SSubsR) =
[ MenuItem
{ menuItemType = PageActionPrime
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuSubmissionNew
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SubmissionNewR
@ -2176,25 +2176,25 @@ pageActions (CSheetR tid ssh csh shn SSubsR) =
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionPrime
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCorrectors
, menuItemIcon = Nothing
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SCorrR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionPrime
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCorrectionsAssign
, menuItemIcon = Nothing
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SAssignR
, menuItemModal = True
, menuItemModal = False
, menuItemAccessCallback' = return True
}
]
pageActions (CSubmissionR tid ssh csh shn cid SubShowR) =
[ MenuItem
{ menuItemType = PageActionPrime
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCorrection
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid CorrectionR
@ -2202,7 +2202,7 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) =
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionPrime
{ menuItemType = PageActionPrime
, menuItemLabel = MsgCorrectorAssignTitle
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SubAssignR
@ -2210,7 +2210,7 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) =
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionSecondary
{ menuItemType = PageActionSecondary
, menuItemLabel = MsgMenuSubmissionDelete
, menuItemIcon = Just "trash"
, menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SubDelR
@ -2220,7 +2220,7 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) =
]
pageActions (CSubmissionR tid ssh csh shn cid CorrectionR) =
[ MenuItem
{ menuItemType = PageActionSecondary
{ menuItemType = PageActionSecondary
, menuItemLabel = MsgMenuSubmissionDelete
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SubDelR
@ -2230,17 +2230,17 @@ pageActions (CSubmissionR tid ssh csh shn cid CorrectionR) =
]
pageActions (CSheetR tid ssh csh shn SCorrR) =
[ MenuItem
{ menuItemType = PageActionPrime
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuSubmissions
, menuItemIcon = Nothing
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SSubsR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionSecondary
{ menuItemType = PageActionSecondary
, menuItemLabel = MsgMenuSheetEdit
, menuItemIcon = Nothing
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SEditR
, menuItemModal = False
, menuItemAccessCallback' = return True

176
src/Handler/Corrections.hs
View File

@ -5,6 +5,7 @@ import Import
import Jobs
import Handler.Utils
import Handler.Utils.Corrections
import Handler.Utils.Submission
import Handler.Utils.Table.Cells
import Handler.Utils.SheetType
@ -13,11 +14,11 @@ import Handler.Utils.Delete
import Utils.Lens
import Data.List (nub)
import Data.List as List (nub, foldl, foldr)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map, (!))
import qualified Data.Map as Map
import Data.Map.Strict (Map, (!))
import qualified Data.Map.Strict as Map
import qualified Data.Text as Text
import qualified Data.CaseInsensitive as CI
@ -250,7 +251,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
E.orderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
return (user, pseudonym E.?. SheetPseudonymPseudonym)
let
submittorMap = foldr (\(Entity userId user, E.Value pseudo) -> Map.insert userId (user, pseudo)) Map.empty submittors
submittorMap = List.foldr (\(Entity userId user, E.Value pseudo) -> Map.insert userId (user, pseudo)) Map.empty submittors
dbtProj' (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, mbLastEdit, submittorMap)
dbTable psValidator DBTable
{ dbtSQLQuery
@ -1035,25 +1036,27 @@ embedRenderMessage ''UniWorX ''ButtonSubmissionsAssign id
instance Button UniWorX ButtonSubmissionsAssign where
btnClasses BtnSubmissionsAssign = [BCIsButton, BCPrimary]
-- | Gather info about corrector assignment per sheet
-- | DEPRECATED use CorrectorInfo instead. Gather info about corrector assignment per sheet
data SubAssignInfo = SubAssignInfo { saiName :: SheetName, saiSubmissionNr, saiCorrectorNr, saiUnassignedNr :: Int }
getCAssignR, postCAssignR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCAssignR = postCAssignR
postCAssignR tid ssh csh = do
shids <- runDB $ do
(shids,cid) <- runDB $ do
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
selectKeysList [SheetCourse ==. cid] [Asc SheetActiveTo]
assignHandler tid ssh csh shids
shids <- selectKeysList [SheetCourse ==. cid] [Asc SheetActiveTo]
return (shids,cid)
assignHandler tid ssh csh cid shids
getSAssignR, postSAssignR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSAssignR = postSAssignR
postSAssignR tid ssh csh shn = do
shid <- runDB $ fetchSheetId tid ssh csh shn
assignHandler tid ssh csh [shid]
(shid,cid) <- runDB $ fetchSheetIdCourseId tid ssh csh shn
assignHandler tid ssh csh cid [shid]
assignHandler :: TermId -> SchoolId -> CourseShorthand -> [SheetId] -> Handler Html
assignHandler tid ssh csh rawSids = do
-- DEPRECATED assignHandler', delete me soonish
assignHandler' :: TermId -> SchoolId -> CourseShorthand -> CourseId -> [SheetId] -> Handler Html
assignHandler' tid ssh csh _cid rawSids = do
-- gather data
openSubs <- runDB $ (\f -> foldM f Map.empty rawSids) $
\acc sid -> maybeT (return acc) $ do
@ -1079,7 +1082,7 @@ assignHandler tid ssh csh rawSids = do
\acc sid -> flip (Map.insert sid) acc <$> assignSubmissions sid Nothing
-- Too much important information for an alert message. Display proper info page instead
let btnForm = wrapForm btnWdgt def
{ formAction = SomeRoute <$> currentRoute -- TODO: should be a modal route
{ formAction = SomeRoute <$> currentRoute
, formEncoding = btnEnctype
, formSubmit = FormNoSubmit
}
@ -1092,3 +1095,150 @@ assignHandler tid ssh csh rawSids = do
then linkBack -- TODO: convenience link might be unnecessary: either via breadcrumb or closing model. Remove, if modal works fine. Otherwise change to PrimaryAction?
else btnForm
{- TODO: make buttons for each sheet, so that users see which sheet is assigned
data ButtonCorrectionsAssign = BtnCorrectionsAssignAll | BtnCorrectionsAssignSheet SheetName
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Button UniWorX ButtonCorrectionsAssign
-- Are those needed any more?
instance Universe ButtonCorrectionsAssign
instance Finite ButtonCorrectionsAssign
nullaryPathPiece ''ButtonCorrectionsAssign camelToPathPiece
embedRenderMessage ''UniWorX ''ButtonCorrectionsAssign id
instance Button UniWorX ButtonCorrectionsAssign where
btnClasses BtnCorrectionsAssign = [BCIsButton, BCPrimary]
-- use runButtonForm' instead later on
-}
assignHandler :: TermId -> SchoolId -> CourseShorthand -> CourseId -> [SheetId] -> Handler Html
assignHandler tid ssh csh cid assignSids = do
-- evaluate form first, since it affects DB action
(btnWdgt, btnResult) <- runButtonForm FIDAssignSubmissions
-- gather data
(nrParticipants, groupsPossible, infoMap, correctorMap, assignment) <- runDB $ do
-- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
nrParticipants <- count [CourseParticipantCourse ==. cid]
sheetList <- selectList [SheetCourse ==. cid] [Asc SheetName]
let sheets = entities2map sheetList
sheetIds = Map.keys sheets
groupsPossible :: Bool
groupsPossible =
let foldFun (Entity _ Sheet{sheetGrouping=sgr}) acc = acc || sgr /= NoGroups
in List.foldr foldFun False sheetList
-- plan or assign unassigned submissions for given sheets
let buildA :: (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int)) -> SheetId -> DB (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int))
buildA acc sid = maybeT (return acc) $ do
let shn = sheetName $ sheets ! sid
-- is sheet closed?
guardM $ lift $ hasWriteAccessTo $ CSheetR tid ssh csh shn SAssignR -- we must check, whether the submission is already closed and thus assignable
-- has at least one submisison?
[E.Value hasSubmission] <- lift $ E.select $ return $ E.exists $ E.from $ \submission -> do
E.where_ $ submission E.^. SubmissionSheet E.==. E.val sid
E.where_ $ E.isNothing $ submission E.^. SubmissionRatingBy
guard hasSubmission
-- has at least one active corrector?
[E.Value hasCorrector] <- lift $ E.select $ return $ E.exists $ E.from $ \corrector -> do
E.where_ $ corrector E.^. SheetCorrectorSheet E.==. E.val sid
E.where_ $ corrector E.^. SheetCorrectorState E.==. E.val CorrectorNormal
-- E.where_ $ corrector E.^. SheetCorrectorLoad E./=. E.val (Load {byTutorial = Nothing, byProportion = 0})
guard hasCorrector
-- TODO: Refactor guards above! We already have these informations, but forcing the maps inside the DB acces might not be a good idea
-- TODO: Maybe refactor planSubmissions instead to not throw exceptions, but signal "ok" or "not possible" instead!
plan <- lift $ planSubmissions sid Nothing
status <- lift $ case btnResult of
Nothing -> return (Set.empty, Set.empty)
(Just BtnSubmissionsAssign) -> writeSubmissionPlan plan -- TODO: this comes to late!!
return $ Map.insert shn (status, countMapElems plan) acc
assignment <- foldM buildA Map.empty assignSids
correctors <- E.select . E.from $ \(corrector `E.InnerJoin` user) -> do
E.on $ corrector E.^. SheetCorrectorUser E.==. user E.^. UserId
E.where_ $ corrector E.^. SheetCorrectorSheet `E.in_` E.valList sheetIds
return (corrector, user)
let correctorMap :: Map UserId (User, Map SheetName SheetCorrector)
correctorMap = (\f -> foldl f Map.empty correctors) (\acc (Entity _ sheetcorr@SheetCorrector{sheetCorrectorSheet}, Entity uid user) ->
let shn = sheetName $ sheets ! sheetCorrectorSheet
in Map.insertWith (\(usr, ma) (_, mb) -> (usr, Map.union ma mb)) uid (user, Map.singleton shn sheetcorr) acc
)
submissions <- E.select . E.from $ \submission -> do
E.where_ $ submission E.^. SubmissionSheet `E.in_` E.valList sheetIds
let numSubmittors = E.sub_select . E.from $ \subUser -> do
E.where_ $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission
return E.countRows
return (submission, numSubmittors)
-- prepare map
let infoMap :: Map SheetName (Map (Maybe UserId) CorrectionInfo)
infoMap = List.foldl (flip buildS) emptySheets submissions
-- ensure that all sheets are shown, including those without any submissions
emptySheets = foldl (\m sid -> Map.insert (sheetName $ sheets ! sid) emptyCorrs m) Map.empty sheetIds
emptyCorrs = foldl (\m uid -> let cic = Just uid in
Map.insert cic mempty{ciCorrector=cic} m) Map.empty $ Map.keys correctorMap
buildS :: (Entity Submission, E.Value Int64) -> Map SheetName (Map (Maybe UserId) CorrectionInfo) -> Map SheetName (Map (Maybe UserId) CorrectionInfo)
buildS (Entity _sheetId Submission{..}, E.Value nrSbmtrs) m =
let shnm = sheetName $ sheets ! submissionSheet
corTime = diffUTCTime <$> submissionRatingTime <*> submissionRatingAssigned
cinf = Map.singleton submissionRatingBy $ CorrectionInfo
{ ciSubmittors = fromIntegral nrSbmtrs
, ciSubmissions = 1
, ciAssigned = maybe 0 (const 1) submissionRatingBy -- only used in sheetMap
, ciCorrected = maybe 0 (const 1) submissionRatingTime
, ciCorrector = submissionRatingBy
, ciMin = corTime
, ciTot = corTime
, ciMax = corTime
}
in Map.insertWith (Map.unionWith (<>)) shnm cinf m
return (nrParticipants, groupsPossible, infoMap, correctorMap, assignment)
let -- infoMap :: Map SheetName (Map (Maybe UserId) CorrectionInfo) -- repeated here for easier reference
-- create aggregate maps
sheetMap :: Map SheetName CorrectionInfo
sheetMap = Map.map fold infoMap
corrMap :: Map (Maybe UserId) CorrectionInfo
corrMap = Map.unionsWith (<>) $ Map.elems infoMap
sheetNames = Map.keys infoMap
let -- whamlet convenience functions
-- avoid nestes hamelt $maybe with duplicated $nothing
getCorrector :: Maybe UserId -> (Widget,Map SheetName SheetCorrector)
getCorrector (Just uid)
| Just (User{..},loadMap) <- Map.lookup uid correctorMap
= (nameEmailWidget userEmail userDisplayName userSurname, loadMap)
getCorrector _ = ([whamlet|_{MsgNoCorrectorAssigned}|], mempty)
-- avoid nestes hamelt $maybe with duplicated $nothing
getCorrSheetStatus :: Maybe UserId -> SheetName -> Maybe CorrectionInfo
getCorrSheetStatus corr shn
| (Just smap) <- Map.lookup shn infoMap
= Map.lookup corr smap
getCorrSheetStatus _ _ = Nothing
-- avoid nestes hamelt $maybe with duplicated $nothing
getCorrNewAssignment :: Maybe UserId -> SheetName -> Maybe Int
getCorrNewAssignment corr shn
| (Just (_,cass)) <- Map.lookup shn assignment
= Map.lookup corr cass
getCorrNewAssignment _ _ = Nothing
showDiffDays :: Maybe NominalDiffTime -> Text
showDiffDays = foldMap formatDiffDays
showAvgsDays :: Maybe NominalDiffTime -> Integer -> Text
showAvgsDays Nothing _ = mempty
showAvgsDays (Just dt) n = formatDiffDays $ dt / fromIntegral n
heat :: Integer -> Integer -> Double
heat full achieved = roundToDigits 3 $ cutOffPercent 0.4 (fromIntegral full) (fromIntegral achieved)
let headingShort
| 0 < Map.size assignment = MsgMenuCorrectionsAssignSheet $ Text.intercalate ", " $ fmap CI.original $ Map.keys assignment
| otherwise = MsgMenuCorrectionsAssign
headingLong = prependCourseTitle tid ssh csh MsgMenuCorrectionsAssign
siteLayoutMsg headingShort $ do
setTitleI headingLong
$(widgetFile "corrections-overview")

4
src/Handler/Tutorial.hs
View File

@ -136,7 +136,7 @@ postTDeleteR tid ssh csh tutn = do
return E.countRows
return (course, tutorial, participants :: E.SqlExpr (E.Value Int))
, drRenderRecord = \(Entity _ Course{..}, Entity _ Tutorial{..}, E.Value ps) ->
return [whamlet|_{prependCourseTitle courseTerm courseSchool courseShorthand (CI.original tutorialName)} (#{tshow ps} _{MsgParticipantsN ps})|]
return [whamlet|_{prependCourseTitle courseTerm courseSchool courseShorthand (CI.original tutorialName)} (_{MsgParticipantsN ps})|]
, drRecordConfirmString = \(Entity _ Course{..}, Entity _ Tutorial{..}, E.Value ps) ->
return [st|#{termToText (unTermKey courseTerm)}/#{unSchoolKey courseSchool}/#{courseShorthand}/#{tutorialName}+#{tshow ps}|]
, drCaption = SomeMessage MsgTutorialDeleteQuestion
@ -199,7 +199,7 @@ postTCommR tid ssh csh tutn = do
[E.Value isTutorialUser] <- E.select . return . E.exists . E.from $ \tutorialUser ->
E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val uid
E.&&. tutorialUser E.^. TutorialParticipantTutorial E.==. E.val tutid
isAssociatedCorrector <- evalAccessForDB (Just uid) (CourseR tid ssh csh CNotesR) False
isAssociatedTutor <- evalAccessForDB (Just uid) (CourseR tid ssh csh CTutorialListR) False

45
src/Handler/Utils/Corrections.hs Normal file
View File

@ -0,0 +1,45 @@
module Handler.Utils.Corrections where
import Import
-- CorrectionInfo has seeming redundancies, but these are useful for aggregation
-- INVARIANT: isJust ciTot `implies` ciCorrected > 0
data CorrectionInfo = CorrectionInfo
{ ciSubmittors, ciSubmissions, ciAssigned, ciCorrected :: Integer
, ciCorrector :: Maybe UserId
, ciTot, ciMin, ciMax :: Maybe NominalDiffTime
}
instance Semigroup CorrectionInfo where
corrA <> corrB =
assert (isJust (ciTot corrA) `implies` (ciCorrected corrA > 0)) $
assert (isJust (ciTot corrB) `implies` (ciCorrected corrB > 0))
CorrectionInfo
{ ciSubmittors = ciSubmittors `mergeWith` (+)
, ciSubmissions = ciSubmissions `mergeWith` (+)
, ciAssigned = ciAssigned `mergeWith` (+)
, ciCorrected = ciCorrected `mergeWith` (+)
, ciCorrector = ciCorrector `mergeWith` keepEqual
, ciTot = ciTot `mergeWith` ignoreNothing (+)
, ciMin = ciMin `mergeWith` ignoreNothing min
, ciMax = ciMax `mergeWith` ignoreNothing max
}
where
mergeWith :: (CorrectionInfo -> a) -> (a -> a -> c) -> c
mergeWith prj f = on f prj corrA corrB
keepEqual (Just x) (Just y) | x==y = Just x
keepEqual _ _ = Nothing
instance Monoid CorrectionInfo where
mappend = (<>)
mempty = CorrectionInfo { ciSubmittors = 0
, ciSubmissions = 0
, ciAssigned = 0
, ciCorrected = 0
, ciCorrector = Nothing
, ciMin = Nothing
, ciTot = Nothing
, ciMax = Nothing
}

33
src/Handler/Utils/DateTime.hs
View File

@ -2,6 +2,7 @@ module Handler.Utils.DateTime
( utcToLocalTime
, localTimeToUTC, TZ.LocalToUTCResult(..)
, toMidnight, beforeMidnight, toMidday, toMorning
, formatDiffDays
, formatTime, formatTime', formatTimeW
, getTimeLocale, getDateTimeFormat
, validDateTimeFormats, dateTimeFormatOptions
@ -29,6 +30,37 @@ import qualified Data.Set as Set
import Data.Time.Clock.System (systemEpochDay)
--------------------
-- NominalDiffTime
-- | One hour in 'NominalDiffTime'.
nominalHour :: NominalDiffTime
nominalHour = 3600
-- | One minute in 'NominalDiffTime'.
nominalMinute :: NominalDiffTime
nominalMinute= 60
formatDiffDays :: NominalDiffTime -> Text
formatDiffDays t
| t > nominalDay = inDays <> "d"
| t > nominalHour = inHours <> "h"
| t > nominalMinute = inMinutes <> "m"
| otherwise = tshow $ roundToDigits 0 t
where
convertBy :: NominalDiffTime -> Double
convertBy len = realToFrac $ roundToDigits 1 $ t / len
inDays = tshow $ convertBy nominalDay
inHours = tshow $ convertBy nominalHour
inMinutes = tshow $ convertBy nominalMinute
------------
-- UTCTime
utcToLocalTime :: UTCTime -> LocalTime
utcToLocalTime = TZ.utcToLocalTimeTZ appTZ
@ -52,7 +84,6 @@ toMorning :: Day -> UTCTime
toMorning d = localTimeToUTCTZ appTZ $ LocalTime d $ TimeOfDay 6 0 0
class FormatTime t => HasLocalTime t where
toLocalTime :: t -> LocalTime

39
src/Handler/Utils/Submission.hs
View File

@ -1,6 +1,6 @@
module Handler.Utils.Submission
( AssignSubmissionException(..)
, assignSubmissions
, assignSubmissions, writeSubmissionPlan, planSubmissions
, submissionBlacklist, filterSubmission, extractRatings, extractRatingsMsg
, submissionFileSource, submissionFileQuery
, submissionMultiArchive
@ -66,7 +66,32 @@ assignSubmissions :: SheetId -- ^ Sheet to distribute to correctors
-> YesodDB UniWorX ( Set SubmissionId
, Set SubmissionId
) -- ^ Returns assigned and unassigned submissions; unassigned submissions occur only if no tutors have an assigned load
assignSubmissions sid restriction = do
assignSubmissions sid restriction = planSubmissions sid restriction >>= writeSubmissionPlan
-- | Assigns all submissions according to an already given assignment plan
writeSubmissionPlan :: Map SubmissionId (Maybe UserId)
-- ^ map that assigns submissions to correctors
-> YesodDB UniWorX ( Set SubmissionId
, Set SubmissionId
) -- ^ Returns assigned and unassigned submissions; unassigned submissions occur only if no tutors have an assigned load
writeSubmissionPlan newSubmissionData = do
now <- liftIO getCurrentTime
execWriterT . forM_ (Map.toList newSubmissionData) $ \(subId, mCorrector) -> case mCorrector of
Just corrector -> do
lift $ update subId [ SubmissionRatingBy =. Just corrector
, SubmissionRatingAssigned =. Just now
]
tell (Set.singleton subId, mempty)
Nothing ->
tell (mempty, Set.singleton subId)
-- | Compute a map that shows which submissions ought the be assigned to each corrector according to sheet corrector loads, but does not alter database yet!
-- May throw an exception if there are no suitable correctors
planSubmissions :: SheetId -- ^ Sheet to distribute to correctors
-> Maybe (Set SubmissionId) -- ^ Optionally restrict submission to consider
-> YesodDB UniWorX (Map SubmissionId (Maybe UserId))
-- ^ Return map that assigns submissions to Corrector
planSubmissions sid restriction = do
Sheet{..} <- getJust sid
correctorsRaw <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
@ -210,15 +235,7 @@ assignSubmissions sid restriction = do
ix subId . _1 <~ Just <$> liftIO (Rand.uniform bestCorrectors)
now <- liftIO getCurrentTime
execWriterT . forM_ (Map.toList newSubmissionData) $ \(subId, (mCorrector, _, _)) -> case mCorrector of
Just corrector -> do
lift $ update subId [ SubmissionRatingBy =. Just corrector
, SubmissionRatingAssigned =. Just now
]
tell (Set.singleton subId, mempty)
Nothing ->
tell (mempty, Set.singleton subId)
return $ fmap (view _1) newSubmissionData
where
maximumsBy :: (Ord a, Ord b) => (a -> b) -> Set a -> Set a
maximumsBy f xs = flip Set.filter xs $ \x -> maybe True (((==) `on` f) x . maximumBy (comparing f)) $ fromNullable xs

12
src/Model/Types/Sheet.hs
View File

@ -305,3 +305,15 @@ instance Hashable CorrectorState
nullaryPathPiece ''CorrectorState (camelToPathPiece' 1)
derivePersistField "CorrectorState"
showCompactCorrectorLoad :: Load -> CorrectorState -> Text
showCompactCorrectorLoad load CorrectorMissing = "[" <> showCompactCorrectorLoad load CorrectorNormal <> "]"
showCompactCorrectorLoad load CorrectorExcused = "{" <> showCompactCorrectorLoad load CorrectorNormal <> "}"
showCompactCorrectorLoad Load{..} CorrectorNormal = proportionText <> tutorialText
where
proportionText = let propDbl :: Double
propDbl = fromRational byProportion
in tshow $ roundToDigits 2 propDbl
tutorialText = case byTutorial of Nothing -> mempty
Just True -> " (T)"
Just False -> " +T "

41
src/Utils.hs
View File

@ -343,6 +343,17 @@ notUsedT = notUsed
----------
-- Bool --
----------
-- | Logical implication, readable synonym for (<=) which appears the wrong way around
implies :: Bool -> Bool -> Bool
implies True x = x
implies _ _ = True
-------------
-- Numeric --
-------------
@ -368,6 +379,19 @@ roundDiv :: (Integral a, Integral b, RealFrac c) => Int -> a -> b -> c
roundDiv digits numerator denominator
= roundToDigits digits $ fromIntegral numerator / fromIntegral denominator
-- | A value between 0 and 1, measuring how close `achieved` is to `full`; 0 meaning very and 1 meaning not at all
-- `offset` specifies minimum result value, unless the goal is already achieved )i.e. full <= max(0,achieved)
-- Useful for heat maps, with offset giving a visual step between completed and not yet completed
cutOffPercent :: Double -> Double -> Double -> Double
cutOffPercent offset full achieved
| full <= achieved = 0
| full <= 0 = 0
  | otherwise = offset + (1-offset * (1 - percent))
where
percent = achieved / full
------------
-- Monoid --
------------
@ -489,6 +513,11 @@ partMap = Map.fromListWith mappend
invertMap :: (Ord k, Ord v) => Map k v -> Map v (Set k)
invertMap = groupMap . map swap . Map.toList
-- | Counts how often a value appears in a map (not derived from invertMap for efficiency reasons)
countMapElems :: (Ord v) => Map k v -> Map v Int
countMapElems = Map.fromListWith (+) . map (\(_k,v)->(v,1)) . Map.toList
---------------
-- Functions --
@ -523,12 +552,6 @@ flipMaybe :: b -> Maybe a -> Maybe b
flipMaybe x Nothing = Just x
flipMaybe _ (Just _) = Nothing
maybeAdd :: Num a => Maybe a -> Maybe a -> Maybe a -- treats Nothing as neutral/zero, unlike fmap/ap
maybeAdd (Just x) (Just y) = Just (x + y)
maybeAdd Nothing y = y
maybeAdd x Nothing = x
-- | Deep alternative to avoid any occurrence of Nothing at all costs, left-biased
deepAlt :: Maybe (Maybe a) -> Maybe (Maybe a) -> Maybe (Maybe a)
deepAlt Nothing altSnd = altSnd
@ -574,6 +597,12 @@ mcons :: Maybe a -> [a] -> [a]
mcons Nothing xs = xs
mcons (Just x) xs = x:xs
-- | apply binary function to maybes, but ignores Nothing by using id if possible, unlike fmap/ap
ignoreNothing :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a
ignoreNothing _ Nothing y = y
ignoreNothing _ x Nothing = x
ignoreNothing f (Just x) (Just y) = Just $ f x y
newtype NTop a = NTop { nBot :: a } -- treat Nothing as Top for Ord (Maybe a); default implementation treats Nothing as bottom
instance Eq a => Eq (NTop (Maybe a)) where

32
src/Utils/Form.hs
View File

@ -356,10 +356,11 @@ buttonView btn = do
fieldView bField btnId "" mempty (Right btn) False
-- | generate a form that only shows a finite amount of buttons
buttonForm :: (Button site a, Finite a) => Html -> MForm (HandlerT site IO) (FormResult a, WidgetT site IO ())
buttonForm = buttonForm' universeF
-- | like `buttonForm`, but for a given list of buttons, i.e. a subset or for buttons outside the Finite typeclass
buttonForm' :: Button site a => [a] -> Html -> MForm (HandlerT site IO) (FormResult a, WidgetT site IO ())
buttonForm' btns csrf = do
(res, ($ []) -> fViews) <- aFormToForm . disambiguateButtons $ combinedButtonField btns ""
@ -370,6 +371,35 @@ buttonForm' btns csrf = do
^{fvInput bView}
|])
-- | buttons-only form complete with widget-generation and evaluation; return type determines buttons shown.
runButtonForm ::(PathPiece ident, Eq ident, RenderMessage site FormMessage,
Button site ButtonSubmit, Button site a, Finite a)
=> ident -> HandlerT site IO (WidgetT site IO (), Maybe a)
runButtonForm fid = do
currentRoute <- getCurrentRoute
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm fid buttonForm
let btnForm = wrapForm btnWdgt def { formAction = SomeRoute <$> currentRoute
, formEncoding = btnEnctype
, formSubmit = FormNoSubmit
}
res <- formResultMaybe btnResult (return . Just)
return (btnForm, res)
-- | like `runButtonForm` but showing only a given list of buttons, especially for buttons that are not in the Finite typeclass.
runButtonForm' ::(PathPiece ident, Eq ident, RenderMessage site FormMessage,
Button site ButtonSubmit, Button site a)
=> [a] -> ident -> HandlerT site IO (WidgetT site IO (), Maybe a)
runButtonForm' btns fid = do
currentRoute <- getCurrentRoute
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm fid $ buttonForm' btns
let btnForm = wrapForm btnWdgt def { formAction = SomeRoute <$> currentRoute
, formEncoding = btnEnctype
, formSubmit = FormNoSubmit
}
res <- formResultMaybe btnResult (return . Just)
return (btnForm, res)
-------------------
-- Custom Fields --
-------------------

77
templates/corrections-overview.hamlet Normal file
View File

@ -0,0 +1,77 @@
<div>
<h2>_{MsgCorrectionSheets}
_{MsgCourseParticipants nrParticipants}
<table .table .table--striped .table--hover>
<tr .table__row .table__row--head>
<th .table__th>_{MsgSheet}
$if groupsPossible
<th .table__th>_{MsgNrSubmittorsTotal}
<th .table__th >_{MsgNrSubmissionsTotal}
<th .table__th colspan=2>_{MsgNrSubmissionsNotAssigned}
<th .table__th>_{MsgNrSubmissionsNotCorrected}
<th .table__th colspan=3>_{MsgCorrectionTime}
$forall (sheetName, CorrectionInfo{ciSubmittors, ciSubmissions, ciAssigned, ciCorrected, ciMin, ciTot, ciMax}) <- Map.toList sheetMap
<tr .table__row>
<td .table__td>^{simpleLink (toWidget sheetName) (CSheetR tid ssh csh sheetName SSubsR)}
$if groupsPossible
<td .table__td>#{ciSubmittors}
<td .table__td>#{ciSubmissions}
$maybe ((splus,sfailed),_) <- Map.lookup sheetName assignment
$if 0 < Set.size sfailed
<td .table__td>#{ciSubmissions - ciAssigned}
<td .table__td .alert-danger>(-#{show (Set.size splus)}, failed: #{show (Set.size sfailed)})
$elseif 0 < Set.size splus
<td .table__td>#{ciSubmissions - ciAssigned}
<td .table__td .alert-success>(-#{show (Set.size splus)})
$else
<td .table__td colspan=2>#{ciSubmissions - ciAssigned}
$nothing
<td .table__td colspan=2>#{ciSubmissions - ciAssigned}
<td .table__td>#{ciSubmissions - ciCorrected}
<td .table__td>#{showDiffDays ciMin}
<td .table__td>#{showAvgsDays ciTot ciCorrected}
<td .table__td>#{showDiffDays ciMax}
<div>
<h2>_{MsgCorrectionCorrectors}
<table .table .table--striped .table--hover>
<tr .table__row .table__row--head>
<th .table__th>_{MsgCorrector}
<th .table__th>_{MsgNrSubmissionsTotal}
<th .table__th>_{MsgNrSubmissionsNotCorrected}
<th .table__th colspan=3>_{MsgCorrectionTime}
$forall shn <- sheetNames
<th .table__th colspan=5>#{shn}
$# ^{simpleLinkI (SomeMessage MsgMenuCorrectors) (CSheetR tid ssh csh shn SCorrR)}
$forall (CorrectionInfo{ciCorrector, ciSubmissions, ciCorrected, ciMin, ciTot, ciMax}) <- Map.elems corrMap
$with (nameW,loadM) <- getCorrector ciCorrector
<tr .table__row>
<td .table__td>^{nameW}
<td .table__td>#{ciSubmissions}
<td .table__td .heated style="--hotness: #{heat ciSubmissions ciCorrected}">#{ciSubmissions - ciCorrected}
<td .table__td>#{showDiffDays ciMin}
<td .table__td>#{showAvgsDays ciTot ciCorrected}
<td .table__td>#{showDiffDays ciMax}
$forall shn <- sheetNames
$maybe SheetCorrector{sheetCorrectorLoad, sheetCorrectorState} <- Map.lookup shn loadM
<td .table__td>#{showCompactCorrectorLoad sheetCorrectorLoad sheetCorrectorState}
$nothing
<td .table__td>
$maybe CorrectionInfo{ciSubmissions,ciCorrected,ciTot} <- getCorrSheetStatus ciCorrector shn
$maybe nrNew <- getCorrNewAssignment ciCorrector shn
<td .table__td>#{ciSubmissions}
$# <td .table__td>#{ciAssigned} `ciSubmissions` is here always identical to `ciAssigned` and also works for `ciCorrector == Nothing`. ciAssigned only useful in aggregate maps like `sheetMap`
<td .table__td .alert-success>(+#{nrNew})
$nothing
<td .table__td colspan=2>#{ciSubmissions}
<td .table__td .heated style="--hotness: #{heat ciSubmissions ciCorrected}">#{ciSubmissions - ciCorrected}
<td .table__td>#{showAvgsDays ciTot ciCorrected}
$nothing
<td .table__td colspan=4>
$if 0 < length sheetNames
<tr .table__row>
<td colspan=6>
$forall shn <- sheetNames
<td .table__td colspan=5>^{simpleLinkI (SomeMessage MsgMenuCorrectors) (CSheetR tid ssh csh shn SCorrR)}
^{btnWdgt}
<div>
<p>_{MsgAssignSubmissionsRandomWarning}

31
templates/default-layout.lucius
View File

@ -565,6 +565,7 @@ section {
color: var(--color-dark);
box-shadow: 0 0 4px 2px inset currentColor;
padding-left: 20%;
min-height: 100px;
&::before {
content: 'i';
@ -579,6 +580,10 @@ section {
justify-content: center;
}
}
.form-group__input > .notification {
margin: 0;
}
@media (max-width: 768px) {
@ -606,3 +611,29 @@ section {
.notification__content {
color: var(--color-font);
}
/*
"Heated" element.
Set custom property "--hotness" to a value from 0 to 1 to turn
the element's background to a color on a gradient from green to red.
TBD:
- move to a proper place
- think about font-weight...
Example:
<div .heated style="--hotness: 0.2">Lorem ipsum
*/
.heated {
--hotness: 0;
--red: calc(var(--hotness) * 200);
--green: calc(255 - calc(var(--hotness) * 255));
--opacity: calc(calc(var(--red) / 600) + 0.1);
font-weight: var(--weight, 600);
background-color: rgba(var(--red), var(--green), 0, var(--opacity));
}