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

Merge branch 'master' into 184-replace-displayable-by-rendermessage

Browse Source
This commit is contained in:
Sarah Vaupel 2019-06-27 00:58:24 +02:00
commit 39792580d4
23 changed files with 321 additions and 203 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.directory
View File

@ -1,5 +1,5 @@
[Dolphin]
Timestamp=2018,3,14,10,57,55
Timestamp=2019,6,26,19,32,25
Version=4
[Settings]

1
.vscode/tasks.json vendored
View File

@ -14,6 +14,7 @@
"reveal": "always",
"focus": false,
"panel": "dedicated",
"clear": true,
"showReuseMessage": false
}
},

42
messages/uniworx/de.msg
View File

@ -34,6 +34,12 @@ GenericShort: Kürzel
GenericIsNew: Neu
GenericHasConflict: Konflikt
GenericBack: Zurück
GenericChange: Änderung
GenericNumChange: +/-
GenericMin: Min
GenericAvg: Avg
GenericMax: Max
GenericAll: Insgesamt
SummerTerm year@Integer: Sommersemester #{year}
WinterTerm year@Integer: Wintersemester #{year}/#{succ year}
@ -157,7 +163,7 @@ SheetEditOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetNa
SheetNameDup tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{tid}-#{ssh}-#{csh}
SheetDelHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{sheetName} wirklich aus Kurs #{tid}-#{ssh}-#{csh} herauslöschen? Alle assoziierten Abgaben und Korrekturen gehen ebenfalls verloren!
SheetDelOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{tid}-#{ssh}-#{csh}: #{sheetName} gelöscht.
SheetDelHasSubmissions objs@Int: Inkl. #{tshow objs} #{pluralDE objs "Abgabe" "Abgaben"}!
SheetDelHasSubmissions objs@Int: Inkl. #{objs} #{pluralDE objs "Abgabe" "Abgaben"}!
SheetDeleteQuestion: Wollen Sie das unten aufgeführte Übungsblatt und alle zugehörigen Abgaben wirklich löschen?
SheetDeleted: Übungsblatt gelöscht
@ -197,6 +203,7 @@ SheetErrHintEarly: Hinweise dürfen erst nach Beginn des Abgabezeitraums herausg
SheetErrSolutionEarly: Lösungen dürfen erst nach Ende der Abgabezeitraums herausgegeben werden
SheetNoCurrent: Es gibt momentan kein aktives Übungsblatt.
SheetNoOldUnassigned: Alle Abgaben inaktiver Blätter sind bereits einen Korrektor zugeteilt.
SheetsUnassignable name@Text: Momentan keine Abgaben zuteilbar für #{name}
Deadline: Abgabe
Done: Eingereicht
@ -249,7 +256,7 @@ MaterialEditTitle materialName@MaterialName: Material "#{materialName}" editiere
MaterialSaveOk tid@TermId ssh@SchoolId csh@CourseShorthand materialName@MaterialName: Material "#{materialName}" erfolgreich gespeichert in Kurs #{tid}-#{ssh}-#{csh}
MaterialNameDup tid@TermId ssh@SchoolId csh@CourseShorthand materialName@MaterialName: Es gibt bereits Material mit Namen "#{materialName}" in diesem Kurs #{tid}-#{ssh}-#{csh}
MaterialDeleteCaption: Wollen Sie das unten aufgeführte Material wirklich löschen?
MaterialDelHasFiles count@Int64: inklusive #{tshow count} #{pluralDE count "Datei" "Dateien"}
MaterialDelHasFiles count@Int64: inklusive #{count} #{pluralDE count "Datei" "Dateien"}
MaterialIsVisible: Achtung, dieses Material wurde bereits veröffentlicht.
MaterialDeleted materialName@MaterialName: Material "#{materialName}" gelöscht
@ -316,6 +323,7 @@ Correctors: Korrektoren
CorState: Status
CorByTut: Zuteilung nach Tutorium
CorProportion: Anteil
CorDeficitProportion: Defizit Anteile
CorByProportionOnly proportion@Rational: #{rationalToFixed3 proportion} Anteile
CorByProportionIncludingTutorial proportion@Rational: #{rationalToFixed3 proportion} Anteile - Tutorium
CorByProportionExcludingTutorial proportion@Rational: #{rationalToFixed3 proportion} Anteile + Tutorium
@ -391,6 +399,8 @@ UpdatedAssignedCorrectorSingle num@Int64: #{num} Abgaben wurden dem neuen Korrek
NoCorrector: Kein Korrektor
RemovedCorrections num@Int64: Korrektur-Daten wurden von #{num} Abgaben entfernt.
UpdatedAssignedCorrectorsAuto num@Int64: #{num} Abgaben wurden unter den Korrektoren aufgeteilt.
UpdatedSheetCorrectorsAutoAssigned n@Int: #{n} #{pluralDE n "Abgabe wurde einem Korrektor" "Abgaben wurden Korrektoren"} zugteilt.
UpdatedSheetCorrectorsAutoFailed n@Int: #{n} #{pluralDE n "Abgabe konnte" "Abgaben konnten"} nicht automatisch zugewiesen werden.
CouldNotAssignCorrectorsAuto num@Int64: #{num} Abgaben konnten nicht automatisch zugewiesen werden:
SelfCorrectors num@Int64: #{num} Abgaben wurden Abgebenden als eigenem Korrektor zugeteilt!
@ -399,16 +409,18 @@ 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
AssignSubmissionExceptionSubmissionsNotFound n@Int: #{n} Abgaben konnten nicht gefunden werden
NrSubmittorsTotal: Abgebende
NrSubmissionsTotal: Abgaben
NrSubmissionsTotalShort: Abg.
NrSubmissionsUnassigned: Ohne Korrektor
NoCorrectorAssigned: Ohne Korrektor
NrCorrectors: Korrektoren
NrSubmissionsNewlyAssigned: Neu zugeteilt
NrSubmissionsNotAssigned: Nicht zugeteilt
NrSubmissionsNotCorrected: Unkorrigiert
CorrectionTime: Korrekturdauer (Min/Avg/Max)
NrSubmissionsNotCorrectedShort: Unkg.
CorrectionTime: Korrekturdauer
AssignSubmissionsRandomWarning: Die Zuteilungsvorschau kann von der tatsächlichen Zuteilung abweichen, wenn mehrere Blätter auf einmal zugeteilt werden, da beim Ausgleich der Kontigente nur bereits zugeteilte Abgaben berücksichtigt werden. Da es ein randomisierte Prozess ist, kann es auch bei einzelnen Blättern gerinfgügige Abweichungen geben.
CorrectionsUploaded num@Int64: #{num} Korrekturen wurden gespeichert:
@ -464,6 +476,7 @@ RatingNegative: Bewertungspunkte dürfen nicht negativ sein
RatingExceedsMax: Bewertung übersteigt die erlaubte Maximalpunktzahl
RatingNotExpected: Keine Bewertungen erlaubt
RatingBinaryExpected: Bewertung muss 0 (=durchgefallen) oder 1 (=bestanden) sein
RatingPointsRequired: Bewertung erfordert für dieses Blatt eine Punktzahl
SubmissionSinkExceptionDuplicateFileTitle file@FilePath: Dateiname #{show file} kommt mehrfach im Zip-Archiv vor
SubmissionSinkExceptionDuplicateRating: Mehr als eine Bewertung gefunden.
@ -642,8 +655,8 @@ MailSubjectTutorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand tutn@Tuto
MailSubjectSubmissionUserInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: [#{tid}-#{ssh}-#{csh}] Einladung zu einer Abgabe für #{shn}
SheetGrading: Bewertung
SheetGradingPoints maxPoints@Points: #{tshow maxPoints} Punkte
SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{tshow passingPoints} von #{tshow maxPoints} Punkten
SheetGradingPoints maxPoints@Points: #{maxPoints} Punkte
SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{passingPoints} von #{maxPoints} Punkten
SheetGradingPassBinary: Bestanden/Nicht Bestanden
SheetGradingInfo: "Bestanden nach Punkten" zählt sowohl zur maximal erreichbaren Gesamtpunktzahl also auch zur Anzahl der zu bestehenden Blätter.
@ -831,6 +844,7 @@ MenuCourseDelete: Kurs löschen
MenuSubmissionNew: Abgabe anlegen
MenuSubmissionOwn: Abgabe
MenuCorrectors: Korrektoren
MenuCorrectorsChange: Korrektoren ändern
MenuSheetEdit: Übungsblatt editieren
MenuSheetDelete: Übungsblatt löschen
MenuSheetClone: Als neues Übungsblatt klonen
@ -889,8 +903,8 @@ CommSubject: Betreff
CommBody: Nachricht
CommRecipients: Empfänger
CommRecipientsTip: Sie selbst erhalten immer eine Kopie der Nachricht
CommDuplicateRecipients n@Int: #{tshow n} #{pluralDE n "doppelter" "doppelte"} Empfänger ignoriert
CommSuccess n@Int: Nachricht wurde an #{tshow n} Empfänger versandt
CommDuplicateRecipients n@Int: #{n} #{pluralDE n "doppelter" "doppelte"} Empfänger ignoriert
CommSuccess n@Int: Nachricht wurde an #{n} Empfänger versandt
CommCourseHeading: Kursmitteilung
CommTutorialHeading: Tutorium-Mitteilung
@ -981,7 +995,7 @@ TutorialDelete: Löschen
CourseTutorials: Übungen
ParticipantsN n@Int: #{tshow n} Teilnehmer
ParticipantsN n@Int: #{n} Teilnehmer
TutorialDeleteQuestion: Wollen Sie das unten aufgeführte Tutorium wirklich löschen?
TutorialDeleted: Tutorium gelöscht
@ -1017,9 +1031,9 @@ 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"}
CourseParticipantsRegistered n@Int: #{tshow n} Teilnehmer erfolgreich angemeldet
CourseParticipants n@Int: Derzeit #{n} angemeldete Kursteilnehmer
CourseParticipantsInvited n@Int: #{n} #{pluralDE n "Einladung" "Einladungen"} per E-Mail verschickt
CourseParticipantsAlreadyRegistered n@Int: #{n} Teilnehmer #{pluralDE n "ist" "sind"} bereits angemeldet
CourseParticipantsRegisteredWithoutField n@Int: #{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"}
CourseParticipantsRegistered n@Int: #{n} Teilnehmer erfolgreich angemeldet
CourseParticipantsRegisterHeading: Kursteilnehmer hinzufügen

7
shell.nix
View File

@ -1,8 +1,7 @@
{ nixpkgs ? import <nixpkgs>, compiler ? null }:
{ nixpkgs ? import <nixpkgs> }:
let
inherit (nixpkgs {}) pkgs;
haskellPackages = if isNull compiler then pkgs.haskellPackages else pkgs.haskell.packages."${compiler}";
haskellPackages = import ./stackage.nix { inherit nixpkgs; };
drv = haskellPackages.callPackage ./uniworx.nix {};
@ -19,7 +18,7 @@ let
'';
override = oldAttrs: {
nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ postgresql pgadmin openldap ]) ++ (with haskellPackages; [ stack yesod-bin hlint cabal-install ]);
nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ nodejs-8_x postgresql pgadmin openldap ]) ++ (with haskellPackages; [ stack yesod-bin hlint cabal-install ]);
shellHook = ''
export PROMPT_INFO="${oldAttrs.name}"

7
src/Database/Esqueleto/Utils.hs
View File

@ -2,6 +2,7 @@
module Database.Esqueleto.Utils
( true, false
, isJust
, isInfixOf, hasInfix
, any, all
, SqlIn(..)
@ -11,7 +12,7 @@ module Database.Esqueleto.Utils
, anyFilter, allFilter
) where
import ClassyPrelude.Yesod hiding (isInfixOf, any, all)
import ClassyPrelude.Yesod hiding (isInfixOf, any, all, isJust)
import qualified Data.Set as Set
import qualified Data.Foldable as F
import qualified Database.Esqueleto as E
@ -34,6 +35,10 @@ true = E.val True
false :: E.SqlExpr (E.Value Bool)
false = E.val False
-- | Negation of `isNothing` which is missing
isJust :: (E.Esqueleto query expr backend, PersistField typ) => expr (E.Value (Maybe typ)) -> expr (E.Value Bool)
isJust = E.not_ . E.isNothing
-- | Check if the first string is contained in the text derived from the second argument
isInfixOf :: (E.Esqueleto query expr backend, E.SqlString s2) =>
Text -> expr (E.Value s2) -> expr (E.Value Bool)

13
src/Foundation.hs
View File

@ -191,6 +191,15 @@ noneOneMoreDE num noneText singularForm pluralForm
| num == 1 = singularForm
| otherwise = pluralForm
noneMoreDE :: (Eq a, Num a)
=> a -- ^ Count
-> Text -- ^ None
-> Text -- ^ Some
-> Text
noneMoreDE num noneText someText
| num == 0 = noneText
| otherwise = someText
-- Convenience Type for Messages, since Yesod messages cannot deal with compound type identifiers
type IntMaybe = Maybe Int
type TextList = [Text]
@ -1446,7 +1455,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 ("Zuteilung" , Just $ CourseR tid ssh csh CCorrectionsR)
breadcrumb (CourseR tid ssh csh CAssignR) = return ("Zuteilung Korrekturen" , 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)
@ -1464,7 +1473,7 @@ instance YesodBreadcrumbs UniWorX where
breadcrumb (CSheetR tid ssh csh shn SEditR) = return ("Bearbeiten" , Just $ CSheetR tid ssh csh shn SShowR)
breadcrumb (CSheetR tid ssh csh shn SDelR ) = return ("Löschen" , Just $ CSheetR tid ssh csh shn SShowR)
breadcrumb (CSheetR tid ssh csh shn SSubsR) = return ("Abgaben" , Just $ CSheetR tid ssh csh shn SShowR)
breadcrumb (CSheetR tid ssh csh shn SAssignR) = return ("Zuteilen" , Just $ CSheetR tid ssh csh shn SSubsR)
breadcrumb (CSheetR tid ssh csh shn SAssignR) = return ("Zuteilung Korrekturen" , Just $ CSheetR tid ssh csh shn SSubsR)
breadcrumb (CSheetR tid ssh csh shn SubmissionNewR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR)
breadcrumb (CSheetR tid ssh csh shn SubmissionOwnR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR)
breadcrumb (CSubmissionR tid ssh csh shn _ SubShowR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR)

215
src/Handler/Corrections.hs
View File

@ -337,13 +337,13 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
, ( "isassigned"
, FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) criterion -> case getLast (criterion :: Last Bool) of
Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
Just True -> E.not_ . E.isNothing $ submission E.^. SubmissionRatingBy
Just True -> E.isJust $ submission E.^. SubmissionRatingBy
Just False-> E.isNothing $ submission E.^. SubmissionRatingBy
)
, ( "israted"
, FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) criterion -> case getLast (criterion :: Last Bool) of
Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
Just True -> E.not_ . E.isNothing $ submission E.^. SubmissionRatingTime
Just True -> E.isJust $ submission E.^. SubmissionRatingTime
Just False-> E.isNothing $ submission E.^. SubmissionRatingTime
)
, ( "corrector-name-email" -- corrector filter does not work for text-filtering
@ -710,12 +710,12 @@ postCorrectionR tid ssh csh shn cid = do
results <- runDB $ correctionData tid ssh csh shn sub
case results of
[(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector)] -> do
[(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ subm@Submission{..}, corrector)] -> do
let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c))
pointsForm = case sheetType of
NotGraded -> pure Nothing
_otherwise -> aopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType)
(fslpI MsgRatingPoints "Punktezahl")
(fslpI MsgRatingPoints "Punktezahl" & setTooltip sheetType)
(Just submissionRatingPoints)
((corrResult, corrForm'), corrEncoding) <- runFormPost . identifyForm FIDcorrection . renderAForm FormStandard $ (,,)
@ -734,22 +734,20 @@ postCorrectionR tid ssh csh shn cid = do
, formEncoding = uploadEncoding
}
case corrResult of
FormMissing -> return ()
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
FormSuccess (rated, ratingPoints', ratingComment') -> do
uid <- liftHandlerT requireAuthId
now <- liftIO getCurrentTime
formResult corrResult $ \(rated, ratingPoints', ratingComment') -> do
uid <- liftHandlerT requireAuthId
now <- liftIO getCurrentTime
if
| errs <- validateRating sheetType Rating'
{ ratingPoints = ratingPoints'
, ratingComment = ratingComment'
, ratingTime = (now <$ guard rated)
}
, not $ null errs
-> mapM_ (addMessageI Error) errs
| otherwise -> runDBJobs $ do
if
| errs <- validateRating sheetType Rating'
{ ratingPoints = ratingPoints'
, ratingComment = ratingComment'
, ratingTime = (now <$ guard rated)
}
, not $ null errs
-> mapM_ (addMessageI Error) errs
| otherwise -> do
runDBJobs $ do
update sub [ SubmissionRatingBy =. Just uid
, SubmissionRatingTime =. (now <$ guard rated)
, SubmissionRatingPoints =. ratingPoints'
@ -761,25 +759,29 @@ postCorrectionR tid ssh csh shn cid = do
when (rated && isNothing submissionRatingTime) $ do
$logDebugS "CorrectionR" [st|Rated #{tshow sub}|]
queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub
redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
case uploadResult of
FormMissing -> return ()
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
FormSuccess fileUploads -> do
uid <- requireAuthId
res <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
case res of
Nothing -> return () -- ErrorMessages are already added by msgSubmissionErrors
(Just _) -> do
addMessageI Success MsgRatingFilesUpdated
redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
formResult uploadResult $ \fileUploads -> do
uid <- requireAuthId
res <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
case res of
Nothing -> return () -- ErrorMessages are already added by msgSubmissionErrors
(Just _) -> do
addMessageI Success MsgRatingFilesUpdated
redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
mr <- getMessageRender
let sheetTypeDesc = mr sheetType
defaultLayout $ do
heading = MsgCorrectionHead tid ssh csh shn cid
headingWgt = [whamlet|
$newline never
_{heading}
$if not (submissionRatingDone subm)
\ ^{isVisibleWidget False}
|]
siteLayout headingWgt $ do
setTitleI heading
let userCorrection = $(widgetFile "correction-user")
$(widgetFile "correction")
_ -> notFound
@ -1050,11 +1052,8 @@ data SubAssignInfo = SubAssignInfo { saiName :: SheetName, saiSubmissionNr, saiC
getCAssignR, postCAssignR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCAssignR = postCAssignR
postCAssignR tid ssh csh = do
(shids,cid) <- runDB $ do
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
shids <- selectKeysList [SheetCourse ==. cid] [Asc SheetActiveTo]
return (shids,cid)
assignHandler tid ssh csh cid shids
cid <- runDB $ getKeyBy404 $ TermSchoolCourseShort tid ssh csh
assignHandler tid ssh csh cid []
getSAssignR, postSAssignR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSAssignR = postSAssignR
@ -1062,51 +1061,13 @@ postSAssignR tid ssh csh shn = do
(shid,cid) <- runDB $ fetchSheetIdCourseId tid ssh csh shn
assignHandler tid ssh csh cid [shid]
-- 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
Just Sheet{sheetName=saiName} <- lift $ get sid
guardM $ lift $ hasWriteAccessTo $ CSheetR tid ssh csh saiName SAssignR -- we must check, whether the submission is already closed and thus assignable
saiUnassignedNr <- lift $ count [SubmissionSheet ==. sid, SubmissionRatingBy ==. Nothing]
guard $ 0 < saiUnassignedNr -- only consider sheets with unassigned submissions
saiSubmissionNr <- lift $ count [SubmissionSheet ==. sid]
saiCorrectorNr <- lift $ count [SheetCorrectorSheet ==. sid, SheetCorrectorState ==. CorrectorNormal]
-- guard $ saiCorrectorNr > 0 -- COMMENTED OUT BECAUSE we should show sheets without possible correctors to inform the user about these problematic sheets
return $ Map.insert sid SubAssignInfo{..} acc
let sids = Map.keys openSubs
linkBack <- simpleLinkI (SomeMessage MsgGenericBack) <$> case sids of
[sid] -> do Sheet{sheetName} <- runDB $ getJust sid
return $ CSheetR tid ssh csh sheetName SSubsR
_ -> return $ CourseR tid ssh csh CCorrectionsR
-- process form
currentRoute <- getCurrentRoute
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm FIDAssignSubmissions buttonForm
assignmentStatus <- fmap (fromMaybe Map.empty) . formResultMaybe btnResult $ \BtnSubmissionsAssign ->
-- Assign submissions
fmap Just . runDB $ (\f -> foldM f Map.empty sids) $
\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
, formEncoding = btnEnctype
, formSubmit = FormNoSubmit
}
headingShort = MsgMenuCorrectionsAssign
headingLong = prependCourseTitle tid ssh csh MsgMenuCorrectionsAssign
siteLayoutMsg headingShort $ do
setTitleI headingLong
$(widgetFile "corrections-assign")
if null sids || not (null assignmentStatus)
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: Feature:
make distivt buttons for each sheet, so that users see which sheet will be assigned.
Currently this information is available within the page heading!
{- TODO: make buttons for each sheet, so that users see which sheet is assigned
Stub:
data ButtonCorrectionsAssign = BtnCorrectionsAssignAll | BtnCorrectionsAssignSheet SheetName
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Button UniWorX ButtonCorrectionsAssign
-- Are those needed any more?
instance Universe ButtonCorrectionsAssign
@ -1124,7 +1085,7 @@ assignHandler tid ssh csh cid assignSids = do
(btnWdgt, btnResult) <- runButtonForm FIDAssignSubmissions
-- gather data
(nrParticipants, groupsPossible, infoMap, correctorMap, assignment) <- runDB $ do
(assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment) <- runDB $ do
-- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
nrParticipants <- count [CourseParticipantCourse ==. cid]
@ -1135,33 +1096,40 @@ assignHandler tid ssh csh cid assignSids = do
groupsPossible =
let foldFun (Entity _ Sheet{sheetGrouping=sgr}) acc = acc || sgr /= NoGroups
in List.foldr foldFun False sheetList
assignSheetNames = fmap sheetName $ mapMaybe (\sid -> Map.lookup sid sheets) assignSids
-- 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))
let buildA :: (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int, Map UserId Rational)) -> SheetId -> DB (Map SheetName ((Set SubmissionId, Set SubmissionId), Map (Maybe UserId) Int, Map UserId Rational))
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 uncorrected / unassigned 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 -- no corrector
E.where_ $ E.isNothing $ submission E.^. SubmissionRatingTime -- not done
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
-- ask for assignment plan
let ignoreExceptions :: AssignSubmissionException -> DB (Map SubmissionId (Maybe UserId), Map UserId Rational) -- silently ignore errors, since we check all sheets and only care about sheets with unassigned corrections
ignoreExceptions NoCorrectors = return mempty
ignoreExceptions NoCorrectorsByProportion = return mempty
ignoreExceptions (SubmissionsNotFound _sids_not_found) = return mempty -- cannot happen, since last argument to planSubmissions is Nothing
(plan,deficit) <- lift $ handle ignoreExceptions $ planSubmissions sid Nothing
guard $ not $ null plan -- only proceed if there is a plan for this sheet
-- implement assignment plan
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
(Just BtnSubmissionsAssign) -> do
status@(sub_ok,sub_fail) <- writeSubmissionPlan plan
let nr_ok = olength sub_ok
nr_fail = olength sub_fail
alert_ok = toMaybe (nr_ok > 0) $ SomeMessage $ MsgUpdatedSheetCorrectorsAutoAssigned nr_ok
alert_fail = toMaybe (nr_fail > 0) $ SomeMessage $ MsgUpdatedSheetCorrectorsAutoFailed nr_fail
msg_status = bool Success Error $ nr_fail > 0
msg_header = SomeMessage $ shn <> ":"
when (nr_ok > 0 || nr_fail > 0) $
addMessageI msg_status $ UniWorXMessages $ msg_header : catMaybes [alert_ok, alert_fail]
return status
return $ Map.insert shn (status, countMapElems plan, deficit) acc
assignSids' <- if null assignSids -- assignAll; we distinguish assignSids' here avoid useless Alerts
then selectKeysList [SheetCourse ==. cid] [Asc SheetActiveTo]
else return assignSids
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
@ -1205,34 +1173,61 @@ assignHandler tid ssh csh cid assignSids = do
}
in Map.insertWith (Map.unionWith (<>)) shnm cinf m
return (nrParticipants, groupsPossible, infoMap, correctorMap, assignment)
return (assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment)
let -- infoMap :: Map SheetName (Map (Maybe UserId) CorrectionInfo) -- repeated here for easier reference
-- create aggregate maps
sheetNames :: [SheetName]
sheetNames = Map.keys infoMap
sheetMap :: Map SheetName CorrectionInfo
sheetMap = Map.map fold infoMap
sheetLoad :: Map SheetName Load
sheetLoad = -- Map.unionsWith (<>) ((Map.filter () ) . snd) <$> Map.elems correctorMap)
let buildSL acc (_user,mSnSc) = Map.foldlWithKey buildL acc mSnSc
buildL acc s SheetCorrector{sheetCorrectorLoad=l, sheetCorrectorState=CorrectorNormal}
= Map.insertWith (<>) s l acc
buildL acc _ _ = acc
in Map.foldl buildSL Map.empty correctorMap
deficitMap :: Map UserId Rational
deficitMap = foldMap (view _3) assignment
corrMap :: Map (Maybe UserId) CorrectionInfo
corrMap = Map.unionsWith (<>) $ Map.elems infoMap
sheetNames = Map.keys infoMap
corrMapSum :: CorrectionInfo
corrMapSum = fold corrMap
let -- whamlet convenience functions
-- avoid nestes hamelt $maybe with duplicated $nothing
-- avoid nestes hamlet $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
-- avoid nestes hamlet $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
-- avoid nestes hamlet $maybe with duplicated $nothing
getCorrNewAssignment :: Maybe UserId -> SheetName -> Maybe Int
getCorrNewAssignment corr shn
| (Just (_,cass)) <- Map.lookup shn assignment
| (Just (_,cass,_)) <- Map.lookup shn assignment
= Map.lookup corr cass
getCorrNewAssignment _ _ = Nothing
-- avoid nestes hamlet $maybe with duplicated $nothing
getCorrDeficit :: Maybe UserId -> Maybe Rational
getCorrDeficit (Just uid) = Map.lookup uid deficitMap
getCorrDeficit _ = Nothing
getLoadSum :: SheetName -> Text
getLoadSum shn | (Just load) <- Map.lookup shn sheetLoad
= showCompactCorrectorLoad load CorrectorNormal
getLoadSum _ = mempty
showDiffDays :: Maybe NominalDiffTime -> Text
showDiffDays = foldMap formatDiffDays
@ -1245,6 +1240,10 @@ assignHandler tid ssh csh cid assignSids = do
| 0 < Map.size assignment = MsgMenuCorrectionsAssignSheet $ Text.intercalate ", " $ fmap CI.original $ Map.keys assignment
| otherwise = MsgMenuCorrectionsAssign
headingLong = prependCourseTitle tid ssh csh MsgMenuCorrectionsAssign
unassignableSheets = filter (\shn -> Map.notMember shn assignment) assignSheetNames
unless (null unassignableSheets) $ addMessageI Warning $ MsgSheetsUnassignable $ Text.intercalate ", " $ fmap CI.original unassignableSheets
siteLayoutMsg headingShort $ do
setTitleI headingLong
$(widgetFile "corrections-overview")

4
src/Handler/Health.hs
View File

@ -63,7 +63,7 @@ getHealthR = do
<dd .deflist__dd>#{boolSymbol passed}
$of HealthLDAPAdmins (Just found)
<dt .deflist__dt>_{MsgHealthLDAPAdmins}
<dd .deflist__dd>#{textPercent found}
<dd .deflist__dd>#{textPercent found 1}
$of HealthSMTPConnect (Just passed)
<dt .deflist__dt>_{MsgHealthSMTPConnect}
<dd .deflist__dd>#{boolSymbol passed}
@ -80,7 +80,7 @@ getInstanceR = do
instanceInfo@(clusterId, instanceId) <- getsYesod $ (,) <$> appClusterID <*> appInstanceID
setWeakEtagHashable (clusterId, instanceId)
selectRep $ do
provideRep $
siteLayoutMsg MsgInstanceIdentification $ do

2
src/Handler/Help.hs
View File

@ -66,6 +66,6 @@ postHelpR = do
let formWidget = wrapForm formWidget' def
{ formAction = Just $ SomeRoute HelpR
, formEncoding = formEnctype
, formAttrs = [ ("data-ajax-submit", "") | isModal ]
, formAttrs = [ asyncSubmitAttr | isModal ]
}
$(widgetFile "help")

4
src/Handler/Profile.hs
View File

@ -147,7 +147,7 @@ postProfileR = do
siteLayout [whamlet|_{MsgProfileFor} ^{nameWidget userDisplayName userSurname}|] $ do
setTitle . toHtml $ "Profil " <> userIdent
let settingsForm =
let settingsForm =
wrapForm formWidget FormSettings
{ formMethod = POST
, formAction = Just . SomeRoute $ ProfileR :#: ProfileSettings
@ -593,7 +593,7 @@ postUserNotificationR cID = do
let formWidget = wrapForm nsInnerWdgt def
{ formAction = Just . SomeRoute $ UserNotificationR cID
, formEncoding = nsEnc
, formAttrs = [ ("data-ajax-submit", "") | isModal ]
, formAttrs = [ asyncSubmitAttr | isModal ]
}
formResultModal nsRes (UserNotificationR cID, [ (toPathPiece GetBearer, toPathPiece jwt) | Just jwt <- pure mJwt ]) $ \ns -> do

4
src/Handler/Sheet.hs
View File

@ -257,9 +257,7 @@ getSheetListR tid ssh csh = do
(Just (Entity _ Submission{submissionRatingPoints=Just sPoints})) ->
case preview (_grading . _maxPoints) sType of
Just maxPoints
| maxPoints /= 0 ->
let percent = sPoints / maxPoints
in textCell $ textPercent $ realToFrac percent
| maxPoints /= 0 -> textCell $ textPercent sPoints maxPoints
_other -> mempty
_other -> mempty
]

7
src/Handler/Utils/Rating.hs
View File

@ -56,7 +56,7 @@ instance Pretty SheetGrading where
validateRating :: SheetType -> Rating' -> [RatingException]
validateRating ratingSheetType Rating'{ratingPoints=Just rp, ..}
validateRating ratingSheetType Rating'{ ratingPoints=Just rp, .. }
| rp < 0
= [RatingNegative]
| NotGraded <- ratingSheetType
@ -67,6 +67,11 @@ validateRating ratingSheetType Rating'{ratingPoints=Just rp, ..}
| (Just PassBinary) <- ratingSheetType ^? _grading
, not (rp == 0 || rp == 1)
= [RatingBinaryExpected]
validateRating ratingSheetType Rating'{ .. }
| has _grading ratingSheetType
, is _Nothing ratingPoints
, isn't _Nothing ratingTime
= [RatingPointsRequired]
validateRating _ _ = []
getRating :: SubmissionId -> YesodDB UniWorX (Maybe Rating)

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

@ -66,7 +66,9 @@ 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 = planSubmissions sid restriction >>= writeSubmissionPlan
assignSubmissions sid restriction = do
(plan,_) <- planSubmissions sid restriction
writeSubmissionPlan plan
-- | Assigns all submissions according to an already given assignment plan
writeSubmissionPlan :: Map SubmissionId (Maybe UserId)
@ -89,8 +91,8 @@ writeSubmissionPlan newSubmissionData = do
-- 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
-> YesodDB UniWorX (Map SubmissionId (Maybe UserId), Map UserId Rational)
-- ^ Return map that assigns submissions to Corrector and another map showing each current correctors _previous_ deficit
planSubmissions sid restriction = do
Sheet{..} <- getJust sid
correctorsRaw <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do
@ -171,6 +173,10 @@ planSubmissions sid restriction = do
-> m b
withSubmissionData f = f <$> (mappend <$> ask <*> State.get)
-- | Old Deficit for protocol purposes, not used here
oldDeficit :: Map UserId Rational
oldDeficit = Map.mapWithKey (\k _v -> calculateDeficit k submissionData) sheetCorrectors
-- | How many additional submission should the given corrector be assigned, if possible?
calculateDeficit :: UserId -> Map SubmissionId (Maybe UserId, Map UserId _, SheetId) -> Rational
calculateDeficit corrector submissionState = getSum $ foldMap Sum deficitBySheet
@ -235,7 +241,7 @@ planSubmissions sid restriction = do
ix subId . _1 <~ Just <$> liftIO (Rand.uniform bestCorrectors)
return $ fmap (view _1) newSubmissionData
return (fmap (view _1) newSubmissionData, oldDeficit)
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

1
src/Model/Rating.hs
View File

@ -31,6 +31,7 @@ data RatingException = RatingNotUnicode UnicodeException -- ^ Rating failed to p
| RatingExceedsMax -- ^ Rating point must not exceed maximum points
| RatingNotExpected -- ^ Rating not expected
| RatingBinaryExpected -- ^ Rating must be 0 or 1
| RatingPointsRequired -- ^ Rating without points for sheet that requires there to be points
deriving (Show, Eq, Generic, Typeable)
instance Exception RatingException

34
src/Utils.hs
View File

@ -2,12 +2,13 @@ module Utils
( module Utils
) where
import ClassyPrelude.Yesod hiding (foldlM)
import ClassyPrelude.Yesod hiding (foldlM, Proxy)
-- import Data.Double.Conversion.Text -- faster implementation for textPercent?
import qualified Data.Foldable as Fold
import Data.Foldable as Utils (foldlM, foldrM)
import Data.Monoid (Sum(..))
import Data.Proxy
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
@ -63,7 +64,7 @@ import qualified Crypto.Saltine.Class as Saltine
import qualified Crypto.Data.PKCS7 as PKCS7
import Data.Fixed
import Data.Ratio ((%))
-- import Data.Ratio ((%))
import Data.Binary (Binary)
import qualified Data.Binary as Binary
@ -237,15 +238,28 @@ withFragment form html = flip fmap form $ over _2 (toWidget html >>)
rationalToFixed3 :: Rational -> Fixed E3
rationalToFixed3 = fromRational
textPercent :: Real a => a -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead?
textPercent x = lz <> pack (show rx) <> "%"
where
rx :: Centi
rx = realToFrac (x * 100)
lz = if rx < 10.0 then "0" else ""
-- | Convert `part` and `whole` into percentage including symbol
-- showing trailing zeroes and to decimal digits
textPercent :: Real a => a -> a -> Text
textPercent = textPercent' False 2
-- | Convert `part` and `whole` into percentage including symbol
-- `trailZero` shows trailing Zeros, `precision` is number of decimal digits
textPercent' :: Real a => Bool -> Int -> a -> a -> Text
textPercent' trailZero precision part whole
| precision == 0 = showPercent (frac :: Uni)
| precision == 1 = showPercent (frac :: Deci)
| precision == 2 = showPercent (frac :: Centi)
| precision == 3 = showPercent (frac :: Milli)
| precision == 4 = showPercent (frac :: Micro)
| otherwise = showPercent (frac :: Pico)
where
frac :: forall a . HasResolution a => Fixed a
frac = MkFixed $ round $ (* (fromInteger $ resolution (Proxy :: Proxy a))) $ (100*) $ toRational part / toRational whole
showPercent :: HasResolution a => Fixed a -> Text
showPercent f = pack $ showFixed trailZero f <> "%"
textPercentInt :: Integral a => a -> a -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead?
textPercentInt part whole = textPercent $ fromIntegral part % fromIntegral whole
-- | Convert number of bytes to human readable format
textBytes :: Integral a => a -> Text

5
src/Utils/Form.hs
View File

@ -156,6 +156,11 @@ inputReadonly = addAttr "readonly" ""
addAutosubmit :: FieldSettings site -> FieldSettings site
addAutosubmit = addAttr "uw-auto-submit-input" ""
-- | Asynchronous Submit, e.g. use with forms in modals
asyncSubmitAttr :: (Text,Text)
asyncSubmitAttr = ("uw-async-form", "")
------------------------------------------------
-- Unique Form Identifiers to avoid accidents --
------------------------------------------------

3
src/index.md
View File

@ -7,8 +7,7 @@ Utils, Utils.*
: Hilfsfunktionionen _unabhängig von Foundation_
Utils
: Yesod Hilfsfunktionen und Instanzen, Text-HTML-Widget-Konvertierungen
(`DisplayAble`), Crud, `NTop`, Utility-Funktionen für `MonadPlus`, `Maybe`,
: Yesod Hilfsfunktionen und Instanzen, Crud, `NTop`, Utility-Funktionen für `MonadPlus`, `Maybe`,
`MaybeT`, `Map`, und Attrs-Lists
Utils.TH

13
stack.nix
View File

@ -1,16 +1,11 @@
{ ghc, nixpkgs ? import <nixpkgs> }:
let
snapshot = "lts-10.5";
stackage = import (fetchTarball {
url = "https://stackage.serokell.io/drczwlyf6mi0ilh3kgv01wxwjfgvq14b-stackage/default.nix.tar.gz";
sha256 = "1bwlbxx6np0jfl6z9gkmmcq22crm0pa07a8zrwhz5gkal64y6jpz";
});
inherit (nixpkgs { overlays = [ stackage."${snapshot}" ]; }) haskell pkgs;
haskellPackages = pkgs.haskell.packages."${snapshot}";
in haskell.lib.buildStackProject {
haskellPackages = import ./stackage.nix { inherit nixpkgs; };
inherit (nixpkgs {}) pkgs;
in pkgs.haskell.lib.buildStackProject {
inherit ghc;
inherit (haskellPackages) stack;
name = "stackenv";
buildInputs = (with pkgs;
[ postgresql zlib libsodium

19
stack.yaml
View File

@ -9,20 +9,15 @@ extra-package-dbs: []
packages:
- .
- location:
git: https://github.com/pngwjpgh/zip-stream.git
commit: 9272bbed000928d500febad1cdc98d1da29d399e
extra-dep: true
- location:
git: https://github.com/pngwjpgh/encoding.git
commit: 67bb87ceff53f0178c988dd4e15eeb2daee92b84
extra-dep: true
- location:
git: https://github.com/pngwjpgh/memcached-binary.git
commit: b5461747e7be226d3b67daebc3c9aefe8a4490ad
extra-dep: true
extra-deps:
- git: https://github.com/pngwjpgh/zip-stream.git
commit: 9272bbed000928d500febad1cdc98d1da29d399e
- git: https://github.com/pngwjpgh/encoding.git
commit: 67bb87ceff53f0178c988dd4e15eeb2daee92b84
- git: https://github.com/pngwjpgh/memcached-binary.git
commit: b5461747e7be226d3b67daebc3c9aefe8a4490ad
- colonnade-1.2.0
- yesod-colonnade-1.2.0

30
stackage.nix Normal file
View File

@ -0,0 +1,30 @@
{ nixpkgs ? import <nixpkgs>
, snapshot ? "lts-10.5"
}:
let
stackage = import (fetchTarball {
url = "https://stackage.serokell.io/drczwlyf6mi0ilh3kgv01wxwjfgvq14b-stackage/default.nix.tar.gz";
sha256 = "1bwlbxx6np0jfl6z9gkmmcq22crm0pa07a8zrwhz5gkal64y6jpz";
});
overlays =
[ stackage."${snapshot}"
(self: super: {
haskell = super.haskell // {
packages = super.haskell.packages // {
"${snapshot}" = super.haskell.packages."${snapshot}".override {
overrides = hself: hsuper: {
zip-archive = self.haskell.lib.overrideCabal hsuper.zip-archive (old: {
testToolDepends = old.testToolDepends ++ (with self; [ unzip ]);
});
};
};
};
};
}
)
];
inherit (nixpkgs { inherit overlays; }) pkgs;
in pkgs.haskell.packages."${snapshot}"

89
templates/corrections-overview.hamlet
View File

@ -3,20 +3,26 @@
_{MsgCourseParticipants nrParticipants}
<table .table .table--striped .table--hover>
<tr .table__row .table__row--head>
<th .table__th>_{MsgSheet}
<th .table__th rowspan=2>_{MsgSheet}
$if groupsPossible
<th .table__th>_{MsgNrSubmittorsTotal}
<th .table__th >_{MsgNrSubmissionsTotal}
<th .table__th rowspan=2>_{MsgNrSubmittorsTotal}
<th .table__th rowspan=2>_{MsgNrSubmissionsTotal}
<th .table__th colspan=2>_{MsgNrSubmissionsNotAssigned}
<th .table__th>_{MsgNrSubmissionsNotCorrected}
<th .table__th rowspan=2>_{MsgNrSubmissionsNotCorrected}
<th .table__th colspan=3>_{MsgCorrectionTime}
<tr .table__row .table__row--head>
<th .table__th>
<th .table__th>_{MsgGenericNumChange}
<th .table__th>_{MsgGenericMin}
<th .table__th>_{MsgGenericAvg}
<th .table__th>_{MsgGenericMax}
$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
$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)})
@ -24,9 +30,11 @@
<td .table__td>#{ciSubmissions - ciAssigned}
<td .table__td .alert-info>(-#{show (Set.size splus)})
$else
<td .table__td colspan=2>#{ciSubmissions - ciAssigned}
<td .table__td>#{ciSubmissions - ciAssigned}
<td .table__td>
$nothing
<td .table__td colspan=2>#{ciSubmissions - ciAssigned}
<td .table__td>#{ciSubmissions - ciAssigned}
<td .table__td>
<td .table__td>#{ciSubmissions - ciCorrected}
<td .table__td>#{showDiffDays ciMin}
<td .table__td>#{showAvgsDays ciTot ciCorrected}
@ -35,43 +43,78 @@
<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 rowspan=2>_{MsgCorrector}
<th .table__th colspan=2>_{MsgGenericAll}
<th .table__th rowspan=2>_{MsgCorDeficitProportion}
<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
<tr .table__row .table__row--head>
<th .table__th>_{MsgNrSubmissionsTotal}
<th .table__th>_{MsgNrSubmissionsNotCorrected}
<th .table__th>_{MsgGenericMin}
<th .table__th>_{MsgGenericAvg}
<th .table__th>_{MsgGenericMax}
$forall _shn <- sheetNames
<th .table__th>_{MsgCorProportion}
<th .table__th>_{MsgNrSubmissionsTotalShort}
<th .table__th>_{MsgGenericNumChange}
<th .table__th>_{MsgNrSubmissionsNotCorrectedShort}
<th .table__th>_{MsgGenericAvg}
$forall (CorrectionInfo{ciCorrector, ciSubmissions=ciSubmissionsNr, 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>#{ciSubmissionsNr}
$with total <- ciSubmissions corrMapSum
$if total > 0
\ (#{textPercent' True 0 ciSubmissionsNr total})
<td .table__td .heated style="--hotness: #{heat ciSubmissionsNr ciCorrected}">#{ciSubmissionsNr - ciCorrected}
<td .table__td>
$maybe deficit <- getCorrDeficit ciCorrector
#{rationalToFixed3 deficit}
<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>
$forall (shn, CorrectionInfo{ciSubmissions=sheetSubmissionsNr}) <- Map.toList sheetMap
<td .table__td>
$maybe SheetCorrector{sheetCorrectorLoad, sheetCorrectorState} <- Map.lookup shn loadM
#{showCompactCorrectorLoad sheetCorrectorLoad sheetCorrectorState}
$if sheetCorrectorState == CorrectorNormal
$maybe Load{byProportion=total} <- Map.lookup shn sheetLoad
$if total > 0
\ (#{textPercent' True 0 (byProportion sheetCorrectorLoad) total})
$maybe CorrectionInfo{ciSubmissions,ciCorrected,ciTot} <- getCorrSheetStatus ciCorrector shn
<td .table__td>#{ciSubmissions}
$if sheetSubmissionsNr > 0
\ (#{textPercent' True 0 ciSubmissions sheetSubmissionsNr})
$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-info>(+#{nrNew})
$nothing
<td .table__td colspan=2>#{ciSubmissions}
<td .table__td>
<td .table__td .heated style="--hotness: #{heat ciSubmissions ciCorrected}">#{ciSubmissions - ciCorrected}
<td .table__td>#{showAvgsDays ciTot ciCorrected}
$nothing
<td .table__td colspan=4>
<td .table__td>
<td .table__td>
<td .table__td>
<td .table__td>
$if 0 < length sheetNames
<tr .table__row>
<td colspan=6>
<td .table__th>Σ
$with ciSubmissionsNr <- ciSubmissions corrMapSum
$with ciCorrectedNr <- ciCorrected corrMapSum
<td .table__th>#{ciSubmissionsNr}
<td .table__td .heated style="--hotness: #{heat ciSubmissionsNr ciCorrectedNr}">#{ciSubmissionsNr - ciCorrectedNr}
<td .table__th>#{ciCorrected corrMapSum}
<td .table__th>#{showDiffDays (ciMin corrMapSum)}
<td .table__th>#{showAvgsDays (ciTot corrMapSum) (ciCorrected corrMapSum)}
<td .table__th>#{showDiffDays (ciMax corrMapSum)}
$forall shn <- sheetNames
<td .table__td colspan=5>^{simpleLinkI (SomeMessage MsgMenuCorrectors) (CSheetR tid ssh csh shn SCorrR)}
<td .table__th>#{getLoadSum shn}
<td .table__td colspan=4>^{simpleLinkI (SomeMessage MsgMenuCorrectorsChange) (CSheetR tid ssh csh shn SCorrR)}
^{btnWdgt}
<div>
<p>_{MsgAssignSubmissionsRandomWarning}

4
templates/default-layout.lucius
View File

@ -502,7 +502,7 @@ ul.list--inline {
@media (min-width: 768px) {
.deflist {
grid-template-columns: max-content minmax(auto, max-content);
grid-template-columns: max-content minmax(0, max-content);
.deflist {
margin-top: -10px;
@ -580,7 +580,7 @@ section {
justify-content: center;
}
}
.form-group__input > .notification {
margin: 0;
}

4
templates/widgets/grading-summary/grading-summary-row.hamlet
View File

@ -19,7 +19,7 @@ $#
$with Sum pacv <- summary ^. _achievedPasses
<td .table__td>
$if pmax > 0
#{textPercentInt pacv pmax}
#{textPercent pacv pmax}
<td .table__td>
_{pacv} / _{pmax}
$else
@ -35,7 +35,7 @@ $#
$with Sum pacv <- summary ^. _achievedPoints
<td .table__td>
$if pmax > 0
#{textPercent $ realToFrac $ pacv / pmax}
#{textPercent pacv pmax}
<td .table__td>
_{pacv} / _{pmax}
$if ((summary ^. _numMarkedPoints) /= (summary ^. _numSheets))