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

feat(course-registration): allow independent course application

Browse Source
This commit is contained in:
Gregor Kleen 2019-08-09 16:44:26 +02:00
parent e54d6e4acf
commit a00698e99e
20 changed files with 341 additions and 177 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

59
messages/uniworx/de.msg
View File

@ -86,8 +86,9 @@ CourseCapacityTip: Anzahl erlaubter Kursanmeldungen, leer lassen für unbeschrä
CourseNoCapacity: In diesem Kurs sind keine Plätze mehr frei.
TutorialNoCapacity: In dieser Übung sind keine Plätze mehr frei.
CourseNotEmpty: In diesem Kurs sind momentan Teilnehmer angemeldet.
CourseRegisterOk: Anmeldung erfolgreich
CourseDeregisterOk: Erfolgreich abgemeldet
CourseRegistration: Kursanmeldung
CourseRegisterOk: Erfolgreich zum Kurs angemeldet
CourseDeregisterOk: Erfolgreich vom Kurs abgemeldet
CourseDeregisterLecturerTip: Wenn Sie den Teilnehmer vom Kurs abmelden kann es sein, dass sie Zugriff auf diese Daten verlieren
CourseStudyFeature: Assoziiertes Hauptfach
CourseStudyFeatureUpdated: Assoziiertes Hauptfach geändert
@ -112,7 +113,7 @@ CourseMembers: Teilnehmer
CourseMemberOf: Teilnehmer
CourseMembersCount n@Int: #{n}
CourseMembersCountLimited n@Int max@Int: #{n}/#{max}
CourseMembersCountOf n@Int mbNum@IntMaybe: #{n} Anmeldungen #{maybeToMessage " von " mbNum " möglichen"}
CourseMembersCountOf n@Int mbNum@IntMaybe: #{n} Kursanmeldungen #{maybeToMessage " von " mbNum " möglichen"}
CourseName: Name
CourseDescription: Beschreibung
CourseDescriptionTip: Beliebiges HTML-Markup ist gestattet
@ -136,8 +137,8 @@ CourseUserNote: Notiz
CourseUserNoteTooltip: Nur für Dozenten dieses Kurses einsehbar
CourseUserNoteSaved: Notizänderungen gespeichert
CourseUserNoteDeleted: Teilnehmernotiz gelöscht
CourseUserDeregister: Abmelden
CourseUsersDeregistered count@Int64: #{show count} Teilnehmer abgemeldet
CourseUserDeregister: Vom Kurs abmelden
CourseUsersDeregistered count@Int64: #{show count} Teilnehmer vom Kurs abgemeldet
CourseUserSendMail: Mitteilung verschicken
TutorialUserDeregister: Vom Tutorium Abmelden
TutorialUserSendMail: Mitteilung verschicken
@ -149,20 +150,28 @@ CourseAllocationOption term@Text name@Text: #{name} (#{term})
CourseAllocationMinCapacity: Minimale Teilnehmeranzahl
CourseAllocationMinCapacityTip: Wenn der Veranstaltung bei der Zentralanmeldung weniger als diese Anzahl von Teilnehmern zugeteilt würden, werden diese stattdessen auf andere Kurse umverteilt
CourseAllocationMinCapacityMustBeNonNegative: Minimale Teilnehmeranzahl darf nicht negativ sein
CourseAllocationInstructions: Anweisungen zur Bewerbung
CourseAllocationInstructionsTip: Wird den Studierenden angezeigt, wenn diese sich für Ihre Veranstaltung bewerben
CourseAllocationApplicationTemplate: Bewerbungsvorlagen
CourseAllocationApplicationText: Text-Bewerbungen
CourseAllocationApplicationTextTip: Sollen die Studierenden Bewerbungen (ggf. zusätzlich zu abgegebenen Dateien) als unformatierten Text einreichen?
CourseAllocationApplicationRatingsVisible: Feedback für Bewerbungen
CourseAllocationApplicationRatingsVisibleTip: Sollen Bewertung und Kommentar der Bewerbungen den Studierenden nach Ende der Bewertungs-Phase angezeigt werden?
CourseApplicationInstructions: Anweisungen zur Bewerbung/Anmeldung
CourseApplicationInstructionsTip: Wird den Studierenden angezeigt, wenn diese sich für Ihre Veranstaltung bewerben bzw. bei dieser anmelden
CourseApplicationTemplate: Bewerbungsvorlagen
CourseApplicationTemplateTip: Werden den Studierenden zum download angeboten, wenn diese sich für Ihre Veranstaltung bewerben bzw. bei dieser anmelden
CourseApplicationText: Text-Bewerbungen
CourseApplicationTextTip: Sollen die Studierenden Bewerbungen (ggf. zusätzlich zu abgegebenen Dateien) als unformatierten Text einreichen?
CourseApplicationRatingsVisible: Feedback für Bewerbungen
CourseApplicationRatingsVisibleTip: Sollen Bewertung und Kommentar der Bewerbungen den Studierenden nach Ende der Bewertungs-Phase angezeigt werden?
CourseApplicationRequired: Bewerbungsverfahren
CourseApplicationRequiredTip: Sollen Anmeldungen zu diesem Kurs zunächst provisorisch (ohne Kapazitätsbeschränkung) sein, bis sie durch einen Kursverwalter (nach Bewertung der Bewerbungen) akzeptiert werden?
CourseApplicationInstructionsApplication: Anweisungen zur Bewerbung
CourseApplicationInstructionsRegistration: Anweisungen zur Anmeldung
CourseApplicationTemplateApplication: Bewerbungsvorlage(n)
CourseApplicationTemplateRegistration: Anmeldungsvorlage(n)
CourseApplicationTemplateArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-bewerbungsvorlagen
CourseNoAllocationsAvailable: Es sind aktuell keine Zentralanmeldungen verfügbar
AllocationStaffRegisterToExpired: Es dürfen keine Änderungen an der Eintragung des Kurses zur Zentralanmeldung mehr vorgenommen werden
CourseFormSectionRegistration: Anmeldung
CourseFormSectionRegistration: Anmeldung zum Kurs
CourseFormSectionAdministration: Verwaltung
CourseLecturers: Kursverwalter
@ -290,6 +299,7 @@ MaterialDeleteCaption: Wollen Sie das unten aufgeführte Material wirklich lösc
MaterialDelHasFiles count@Int64: inklusive #{count} #{pluralDE count "Datei" "Dateien"}
MaterialIsVisible: Achtung, dieses Material wurde bereits veröffentlicht.
MaterialDeleted materialName@MaterialName: Material "#{materialName}" gelöscht
MaterialArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand materialName@MaterialName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase materialName}
Unauthorized: Sie haben hierfür keine explizite Berechtigung.
@ -445,6 +455,10 @@ UpdatedSheetCorrectorsAutoFailed n@Int: #{n} #{pluralDE n "Abgabe konnte" "Abgab
CouldNotAssignCorrectorsAuto num@Int64: #{num} Abgaben konnten nicht automatisch zugewiesen werden:
SelfCorrectors num@Int64: #{num} Abgaben wurden Abgebenden als eigenem Korrektor zugeteilt!
SubmissionOriginal: Original
SubmissionCorrected: Korrigiert
SubmissionArchiveName: abgaben
SubmissionTypeArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName subId@CryptoFileNameSubmission renderedSfType@Text: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase shn}-#{foldCase (toPathPiece subId)}-#{foldCase renderedSfType}
CorrectionSheets: Übersicht Korrekturen nach Blättern
CorrectionCorrectors: Übersicht Korrekturen nach Korrektoren
@ -770,6 +784,9 @@ SheetGroupMaxGroupsize: Maximale Gruppengröße
SheetFiles: Übungsblatt-Dateien
SheetFileTypeHeader: Zugehörigkeit
SheetArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase shn}
SheetTypeArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName renderedSft@Text: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase shn}-#{foldCase renderedSft}
NotificationTriggerSubmissionRatedGraded: Meine Abgabe in einem gewerteten Übungsblatt wurde korrigiert
NotificationTriggerSubmissionRated: Meine Abgabe wurde korrigiert
NotificationTriggerSheetActive: Ich kann ein neues Übungsblatt herunterladen
@ -1262,11 +1279,11 @@ ExamPassed: Bestanden
ExamNotPassed: Nicht bestanden
ExamResult: Prüfungsergebnis
ExamRegisteredSuccess exam@ExamName: Erfolgreich zur #{exam} angemeldet
ExamDeregisteredSuccess exam@ExamName: Erfolgreich von der #{exam} abgemeldet
ExamRegistered: Angemeldet
ExamNotRegistered: Nicht angemeldet
ExamRegistration: Anmeldung
ExamRegisteredSuccess exam@ExamName: Erfolgreich zur Prüfung #{exam} angemeldet
ExamDeregisteredSuccess exam@ExamName: Erfolgreich von der Prüfung #{exam} abgemeldet
ExamRegistered: Zur Prüfung angemeldet
ExamNotRegistered: Nicht zur Prüfung angemeldet
ExamRegistration: Prüfungsanmeldung
ExamRegisterToMustBeAfterRegisterFrom: "Anmeldung ab" muss vor "Anmeldung bis" liegen
ExamDeregisterUntilMustBeAfterRegisterFrom: "Abmeldung bis" muss nach "Anmeldung bis" liegen
@ -1291,7 +1308,7 @@ ImplementationDetails: Implementierung
ExamUsersHeading: Prüfungsteilnehmer
ExamUserDeregister: Teilnehmer von Prüfung abmelden
ExamUserAssignOccurrence: Termin/Raum zuweisen
ExamUsersDeregistered count@Int64: #{show count} Teilnehmer abgemeldet
ExamUsersDeregistered count@Int64: #{show count} Teilnehmer von der Prüfung abgemeldet
ExamUsersOccurrenceUpdated count@Int64: Termin/Raum für #{show count} Teilnehmer gesetzt
CsvFile: CSV-Datei
@ -1364,8 +1381,8 @@ BtnPasswordReset: Passwort zurücksetzen
AuthLDAPLookupFailed: Nutzer konnte aufgrund eines LDAP-Fehlers nicht nachgeschlagen werden
AuthLDAPInvalidLookup: Bestehender Nutzer konnte nicht eindeutig einem LDAP-Eintrag zugeordnet werden
AuthLDAPAlreadyConfigured: Nutzer meldet sich bereits per Campus-Kennung an
AuthLDAPConfigured: Nutzer meldet sich nun per Campus-Kennung an
AuthLDAPAlreadyConfigured: Nutzer meldet sich bereits per Campus-Kennung in Uni2work an
AuthLDAPConfigured: Nutzer meldet sich nun per Campus-Kennung in Uni2work an
AuthPWHashAlreadyConfigured: Nutzer meldet sich bereits per Uni2work-Kennung an
AuthPWHashConfigured: Nutzer meldet sich nun per Uni2work-Kennung an

24
models/allocations
View File

@ -31,38 +31,14 @@ AllocationCourse
allocation AllocationId
course CourseId
minCapacity Int -- if the course would get assigned fewer than this many applicants, restart the assignment process without the course
instructions Html Maybe -- instructions from the lecturer to applicants
applicationText Bool -- lecturer will read application texts supplied by users
applicationFiles UploadMode -- lecturer wants to receive course specific application files
ratingsVisible Bool -- lecturer wants applicants to receive feedback on their application (Grade & comment)
UniqueAllocationCourse course
AllocationCourseFile
allocationCourse AllocationCourseId
file FileId
UniqueAllocationCourseFile allocationCourse file
AllocationUser
allocation AllocationId
user UserId
totalCourses Natural -- number of total allocated courses for this user must be <= than this number
UniqueAllocationUser allocation user
AllocationApplication
allocationCourse AllocationCourseId
allocationUser AllocationUserId
text Text Maybe -- free text entered by user
priority Natural -- priority, higher number means higher priority
ratingVeto Bool
ratingPoints ExamGrade Maybe
ratingComment Text Maybe
UniqueAllocationApplication allocationCourse allocationUser
AllocationApplicationFile -- supplemental file for application by a user for a certain course
application AllocationApplicationId
file FileId
UniqueAllocationUserFile application file
AllocationDeregister -- self-inflicted user-deregistrations from an allocated course
user UserId
allocation AllocationId Maybe

24
models/courses
View File

@ -17,9 +17,20 @@ Course -- Information about a single course; contained info is always visible
deregisterUntil UTCTime Maybe -- unenrolement may be prohibited from a given date onwards
registerSecret Text Maybe -- enrolement maybe protected by a simple common passphrase
materialFree Bool -- False: only enrolled users may see course materials not stored in this table
applicationsRequired Bool
applicationsInstructions Html Maybe
applicationsText Bool
applicationsFiles UploadMode
applicationsRatingsVisible Bool
TermSchoolCourseShort term school shorthand -- shorthand must be unique within school and semester
TermSchoolCourseName term school name -- name must be unique within school and semester
deriving Generic
CourseAppInstructionFile
course CourseId
file FileId
UniqueCourseAppInstructionFile course file
CourseEdit -- who edited when a row in table "Course", kept indefinitely (might be replaced by generic Audit Table; like all ...-Edit tables)
user UserId
time UTCTime
@ -59,3 +70,16 @@ CourseUserNoteEdit -- who edited a participants course note when
user UserId
time UTCTime
note CourseUserNoteId -- PROBLEM: deleted notes have no modification date any more
CourseApplication
course CourseId
user UserId
text Text Maybe -- free text entered by user
ratingPoints ExamGrade Maybe
ratingComment Text Maybe
allocation AllocationId Maybe
allocationPriority Natural Maybe
CourseApplicationFile
application CourseApplication
file FileId
UniqueApplicationFile application file

1
routes
View File

@ -87,6 +87,7 @@
/course/#TermId/#SchoolId/#CourseShorthand CourseR !lecturer:
/ CShowR GET !free
/register CRegisterR GET POST !timeANDcapacityANDallocation-time !lecturerANDallocation-time
/register-template CRegisterTemplateR GET
/edit CEditR GET POST
/lecturer-invite CLecInviteR GET POST
/delete CDeleteR GET POST !lecturerANDemptyANDallocation-time

1
src/Foundation.hs
View File

@ -282,6 +282,7 @@ embedRenderMessage ''UniWorX ''MessageStatus ("Message" <>)
embedRenderMessage ''UniWorX ''NotificationTrigger $ ("NotificationTrigger" <>) . concat . drop 1 . splitCamel
embedRenderMessage ''UniWorX ''StudyFieldType id
embedRenderMessage ''UniWorX ''SheetFileType id
embedRenderMessage ''UniWorX ''SubmissionFileType id
embedRenderMessage ''UniWorX ''CorrectorState id
embedRenderMessage ''UniWorX ''RatingException id
embedRenderMessage ''UniWorX ''SubmissionSinkException ("SubmissionSinkException" <>)

197
src/Handler/Course/Edit.hs
View File

@ -41,6 +41,12 @@ data CourseForm = CourseForm
, cfLink :: Maybe Text
, cfMatFree :: Bool
, cfAllocation :: Maybe AllocationCourseForm
, cfAppRequired :: Bool
, cfAppInstructions :: Maybe Html
, cfAppInstructionFiles :: Maybe (Source Handler (Either FileId File))
, cfAppText :: Bool
, cfAppFiles :: UploadMode
, cfAppRatingsVisible :: Bool
, cfCapacity :: Maybe Int
, cfSecret :: Maybe Text
, cfRegFrom :: Maybe UTCTime
@ -51,43 +57,45 @@ data CourseForm = CourseForm
data AllocationCourseForm = AllocationCourseForm
{ acfAllocation :: AllocationId
, acfInstructions :: Maybe Html
, acfFiles :: Maybe (Source Handler (Either FileId File))
, acfApplicationText :: Bool
, acfApplicationFiles :: UploadMode
, acfApplicationRatingsVisible :: Bool
, acfMinCapacity :: Int
}
courseToForm :: Entity Course -> [Lecturer] -> [(UserEmail, InvitationDBData Lecturer)] -> Maybe (Entity AllocationCourse) -> CourseForm
courseToForm (Entity cid Course{..}) lecs lecInvites alloc = CourseForm
{ cfCourseId = Just cid
, cfName = courseName
, cfDesc = courseDescription
, cfLink = courseLinkExternal
, cfShort = courseShorthand
, cfTerm = courseTerm
, cfSchool = courseSchool
, cfCapacity = courseCapacity
, cfSecret = courseRegisterSecret
, cfMatFree = courseMaterialFree
, cfRegFrom = courseRegisterFrom
, cfRegTo = courseRegisterTo
, cfDeRegUntil = courseDeregisterUntil
, cfAllocation = allocationCourseToForm <$> alloc
, cfLecturers = [Right (lecturerUser, lecturerType) | Lecturer{..} <- lecs]
++ [Left (email, mType) | (email, InvDBDataLecturer mType) <- lecInvites ]
{ cfCourseId = Just cid
, cfName = courseName
, cfDesc = courseDescription
, cfLink = courseLinkExternal
, cfShort = courseShorthand
, cfTerm = courseTerm
, cfSchool = courseSchool
, cfCapacity = courseCapacity
, cfSecret = courseRegisterSecret
, cfMatFree = courseMaterialFree
, cfAllocation = allocationCourseToForm <$> alloc
, cfAppRequired = courseApplicationsRequired
, cfAppInstructions = courseApplicationsInstructions
, cfAppInstructionFiles
, cfAppText = courseApplicationsText
, cfAppFiles = courseApplicationsFiles
, cfAppRatingsVisible = courseApplicationsRatingsVisible
, cfRegFrom = courseRegisterFrom
, cfRegTo = courseRegisterTo
, cfDeRegUntil = courseDeregisterUntil
, cfLecturers = [Right (lecturerUser, lecturerType) | Lecturer{..} <- lecs]
++ [Left (email, mType) | (email, InvDBDataLecturer mType) <- lecInvites ]
}
where
cfAppInstructionFiles = Just . transPipe runDB $ selectAppFiles .| C.map (Left . E.unValue)
where selectAppFiles = E.selectSource . E.from $ \courseAppInstructionFile -> do
E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. E.val cid
return $ courseAppInstructionFile E.^. CourseAppInstructionFileFile
allocationCourseToForm :: Entity AllocationCourse -> AllocationCourseForm
allocationCourseToForm (Entity _ AllocationCourse{..}) = AllocationCourseForm
{ acfAllocation = allocationCourseAllocation
, acfMinCapacity = allocationCourseMinCapacity
, acfInstructions = allocationCourseInstructions
, acfFiles = Nothing
, acfApplicationText = allocationCourseApplicationText
, acfApplicationFiles = allocationCourseApplicationFiles
, acfApplicationRatingsVisible = allocationCourseRatingsVisible
}
makeCourseForm :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Form CourseForm
@ -213,21 +221,9 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do
_ -> do
allocationOptions <- mkOptionList <$> mapM mkAllocationOption availableAllocations
oldFileIds <- for ((,) <$> (fmap acfAllocation $ template >>= cfAllocation) <*> (template >>= cfCourseId)) $ \(allId, cId) -> fmap (Set.fromList . map E.unValue) . liftHandlerT . runDB . E.select . E.from $ \(allocationCourseFile `E.InnerJoin` allocationCourse) -> do
E.on $ allocationCourseFile E.^. AllocationCourseFileAllocationCourse E.==. allocationCourse E.^. AllocationCourseId
E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. E.val cId
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val allId
return $ allocationCourseFile E.^. AllocationCourseFileFile
let
allocationForm' = AllocationCourseForm
<$> apreq (selectField' Nothing $ return allocationOptions) (fslI MsgCourseAllocation) (fmap acfAllocation $ template >>= cfAllocation)
<*> (assertM (not . null . renderHtml) <$> aopt htmlField (fslI MsgCourseAllocationInstructions & setTooltip MsgCourseAllocationInstructionsTip) (fmap acfInstructions $ template >>= cfAllocation))
<*> aopt (multiFileField . return $ fromMaybe Set.empty oldFileIds) (fslI MsgCourseAllocationApplicationTemplate) (fmap acfFiles $ template >>= cfAllocation)
<*> apopt checkBoxField (fslI MsgCourseAllocationApplicationText & setTooltip MsgCourseAllocationApplicationTextTip) (fmap acfApplicationText $ template >>= cfAllocation)
<*> uploadModeForm (fmap acfApplicationFiles $ template >>= cfAllocation)
<*> apopt checkBoxField (fslI MsgCourseAllocationApplicationRatingsVisible & setTooltip MsgCourseAllocationApplicationRatingsVisibleTip) (fmap acfApplicationRatingsVisible $ template >>= cfAllocation)
<*> apreq (natFieldI MsgCourseAllocationMinCapacityMustBeNonNegative) (fslI MsgCourseAllocationMinCapacity & setTooltip MsgCourseAllocationMinCapacityTip) (fmap acfMinCapacity $ template >>= cfAllocation)
optionalActionW allocationForm' (fslI MsgCourseAllocationParticipate & setTooltip MsgCourseAllocationParticipateTip) (is _Just . cfAllocation <$> template)
@ -247,6 +243,12 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do
<*> apopt checkBoxField (fslI MsgMaterialFree) (cfMatFree <$> template)
<* aformSection MsgCourseFormSectionRegistration
<*> allocationForm
<*> apopt checkBoxField (fslI MsgCourseApplicationRequired & setTooltip MsgCourseApplicationRequiredTip) (cfAppRequired <$> template)
<*> (assertM (not . null . renderHtml) <$> aopt htmlField (fslI MsgCourseApplicationInstructions & setTooltip MsgCourseApplicationInstructionsTip) (cfAppInstructions <$> template))
<*> aopt (multiFileField' . fromMaybe (return ()) $ cfAppInstructionFiles =<< template) (fslI MsgCourseApplicationTemplate & setTooltip MsgCourseApplicationTemplateTip) (cfAppInstructionFiles <$> template)
<*> apopt checkBoxField (fslI MsgCourseApplicationText & setTooltip MsgCourseApplicationTextTip) (cfAppText <$> template)
<*> uploadModeForm (cfAppFiles <$> template)
<*> apopt checkBoxField (fslI MsgCourseApplicationRatingsVisible & setTooltip MsgCourseApplicationRatingsVisibleTip) (cfAppRatingsVisible <$> template)
<*> aopt (natFieldI MsgCourseCapacity) (fslI MsgCourseCapacity
& setTooltip MsgCourseCapacityTip) (cfCapacity <$> template)
<*> aopt textField (fslpI MsgCourseSecret (mr MsgCourseSecretFormat)
@ -425,20 +427,26 @@ courseEditHandler miButtonAction mbCourseForm = do
} -> do -- create new course
now <- liftIO getCurrentTime
insertOkay <- runDBJobs $ do
insertOkay <- insertUnique Course
{ courseName = cfName res
, courseDescription = cfDesc res
, courseLinkExternal = cfLink res
, courseShorthand = cfShort res
, courseTerm = cfTerm res
, courseSchool = cfSchool res
, courseCapacity = cfCapacity res
, courseRegisterSecret = cfSecret res
, courseMaterialFree = cfMatFree res
, courseRegisterFrom = cfRegFrom res
, courseRegisterTo = cfRegTo res
, courseDeregisterUntil = cfDeRegUntil res
}
insertOkay <- let CourseForm{..} = res
in insertUnique Course
{ courseName = cfName
, courseDescription = cfDesc
, courseLinkExternal = cfLink
, courseShorthand = cfShort
, courseTerm = cfTerm
, courseSchool = cfSchool
, courseCapacity = cfCapacity
, courseRegisterSecret = cfSecret
, courseMaterialFree = cfMatFree
, courseApplicationsRequired = cfAppRequired
, courseApplicationsInstructions = cfAppInstructions
, courseApplicationsText = cfAppText
, courseApplicationsFiles = cfAppFiles
, courseApplicationsRatingsVisible = cfAppRatingsVisible
, courseRegisterFrom = cfRegFrom
, courseRegisterTo = cfRegTo
, courseDeregisterUntil = cfDeRegUntil
}
whenIsJust insertOkay $ \cid -> do
let (invites, adds) = partitionEithers $ cfLecturers res
insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds
@ -466,20 +474,26 @@ courseEditHandler miButtonAction mbCourseForm = do
case old of
Nothing -> addMessageI Error MsgInvalidInput $> False
(Just _) -> do
updOkay <- myReplaceUnique cid Course
{ courseName = cfName res
, courseDescription = cfDesc res
, courseLinkExternal = cfLink res
, courseShorthand = cfShort res
, courseTerm = cfTerm res -- dangerous
, courseSchool = cfSchool res
, courseCapacity = cfCapacity res
, courseRegisterSecret = cfSecret res
, courseMaterialFree = cfMatFree res
, courseRegisterFrom = cfRegFrom res
, courseRegisterTo = cfRegTo res
, courseDeregisterUntil = cfDeRegUntil res
}
updOkay <- let CourseForm{..} = res
in myReplaceUnique cid Course
{ courseName = cfName
, courseDescription = cfDesc
, courseLinkExternal = cfLink
, courseShorthand = cfShort
, courseTerm = cfTerm -- dangerous
, courseSchool = cfSchool
, courseCapacity = cfCapacity
, courseRegisterSecret = cfSecret
, courseMaterialFree = cfMatFree
, courseApplicationsRequired = cfAppRequired
, courseApplicationsInstructions = cfAppInstructions
, courseApplicationsText = cfAppText
, courseApplicationsFiles = cfAppFiles
, courseApplicationsRatingsVisible = cfAppRatingsVisible
, courseRegisterFrom = cfRegFrom
, courseRegisterTo = cfRegTo
, courseDeregisterUntil = cfDeRegUntil
}
case updOkay of
(Just _) -> addMessageI Warning (MsgCourseEditDupShort tid ssh csh) $> False
Nothing -> do
@ -490,7 +504,19 @@ courseEditHandler miButtonAction mbCourseForm = do
sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites
insert_ $ CourseEdit aid now cid
let
finsert val = do
fId <- lift $ either return insert val
tell $ Set.singleton fId
lift $
void . insertUnique $ CourseAppInstructionFile cid fId
keep <- execWriterT . runConduit $ transPipe liftHandlerT (traverse_ id $ cfAppInstructionFiles res) .| C.mapM_ finsert
acfs <- selectList [ CourseAppInstructionFileCourse ==. cid, CourseAppInstructionFileFile /<-. Set.toList keep ] []
mapM_ deleteCascade $ map (courseAppInstructionFileFile . entityVal) acfs
upsertAllocationCourse cid $ cfAllocation res
addMessageI Success $ MsgCourseEditOk tid ssh csh
return True
when success $ redirect $ CourseR tid ssh csh CShowR
@ -522,38 +548,17 @@ upsertAllocationCourse cid cfAllocation = do
when doEdit $
case cfAllocation of
Just AllocationCourseForm{..} -> do
Entity acId _ <- upsert AllocationCourse
{ allocationCourseAllocation = acfAllocation
, allocationCourseCourse = cid
, allocationCourseMinCapacity = acfMinCapacity
, allocationCourseInstructions = acfInstructions
, allocationCourseApplicationText = acfApplicationText
, allocationCourseApplicationFiles = acfApplicationFiles
, allocationCourseRatingsVisible = acfApplicationRatingsVisible
Just AllocationCourseForm{..} ->
void $ upsert AllocationCourse
{ allocationCourseAllocation = acfAllocation
, allocationCourseCourse = cid
, allocationCourseMinCapacity = acfMinCapacity
}
[ AllocationCourseAllocation =. acfAllocation
, AllocationCourseCourse =. cid
, AllocationCourseMinCapacity =. acfMinCapacity
, AllocationCourseInstructions =. acfInstructions
, AllocationCourseApplicationText =. acfApplicationText
, AllocationCourseApplicationFiles =. acfApplicationFiles
, AllocationCourseRatingsVisible =. acfApplicationRatingsVisible
[ AllocationCourseAllocation =. acfAllocation
, AllocationCourseCourse =. cid
, AllocationCourseMinCapacity =. acfMinCapacity
]
let
finsert val = do
fId <- lift $ either return insert val
tell $ Set.singleton fId
lift $
void . insertUnique $ AllocationCourseFile acId fId
keep <- execWriterT . runConduit $ transPipe liftHandlerT (traverse_ id acfFiles) .| C.mapM_ finsert
acfs <- selectList [ AllocationCourseFileAllocationCourse ==. acId, AllocationCourseFileFile /<-. Set.toList keep ] []
mapM_ deleteCascade $ map (allocationCourseFileFile . entityVal) acfs
Nothing
| Just (Entity prevId _) <- prevAllocationCourse
-> do
acfs <- selectList [ AllocationCourseFileAllocationCourse ==. prevId ] []
mapM_ deleteCascade $ map (allocationCourseFileFile . entityVal) acfs
delete prevId
-> delete prevId
_other -> return ()

23
src/Handler/Course/Show.hs
View File

@ -1,5 +1,6 @@
module Handler.Course.Show
( getCShowR
, getCRegisterTemplateR
) where
import Import
@ -19,11 +20,15 @@ import qualified Database.Esqueleto as E
import Handler.Course.Register
import System.FilePath (addExtension)
import qualified Data.Conduit.List as C
getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCShowR tid ssh csh = do
mbAid <- maybeAuthId
(cid,course,schoolName,participants,registration,defSFid,lecturers,assistants,correctors,tutors,mAllocation) <- runDB . maybeT notFound $ do
(cid,course,schoolName,participants,registration,defSFid,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate) <- runDB . maybeT notFound $ do
[(E.Entity cid course, E.Value schoolName, E.Value participants, fmap entityVal -> registration)]
<- lift . E.select . E.from $
\((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do
@ -66,7 +71,9 @@ getCShowR tid ssh csh = do
E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. E.val cid
E.limit 1
return allocation
return (cid,course,schoolName,participants,registration,entityKey <$> defSFid,lecturers,assistants,correctors,tutors,mAllocation)
hasApplicationTemplate <- lift . E.selectExists . E.from $ \courseAppInstructionFile ->
E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. E.val cid
return (cid,course,schoolName,participants,registration,entityKey <$> defSFid,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate)
mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course
mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course
@ -224,3 +231,15 @@ getCShowR tid ssh csh = do
siteLayout (toWgt $ courseName course) $ do
setTitleI $ prependCourseTitle tid ssh csh (""::Text)
$(widgetFile "course")
getCRegisterTemplateR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent
getCRegisterTemplateR tid ssh csh = do
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgCourseApplicationTemplateArchiveName tid ssh csh
let source = (.| C.map entityVal) . E.selectSource . E.from $ \(file `E.InnerJoin` courseAppInstructionFile `E.InnerJoin` course) -> do
E.on $ course E.^. CourseId E.==. courseAppInstructionFile E.^. CourseAppInstructionFileCourse
E.on $ courseAppInstructionFile E.^. CourseAppInstructionFileFile E.==. file E.^. FileId
E.where_ $ course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
return file
serveSomeFiles archiveName source

31
src/Handler/Material.hs
View File

@ -23,6 +23,8 @@ import Handler.Utils.Table.Columns
import Control.Monad.Writer (MonadWriter(..), execWriterT)
import System.FilePath (addExtension)
data MaterialForm = MaterialForm
{ mfName :: MaterialName
@ -358,16 +360,19 @@ postMDelR tid ssh csh mnm = do
-- | Serve all material-files
getMArchiveR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler TypedContent
getMArchiveR tid ssh csh mnm = serveSomeFiles archivename getMatQuery
where
archivename = unpack (termToText (unTermKey tid) <> "-" <> toPathPiece (unSchoolKey ssh <> "-" <> csh <> "-" <> mnm)) <.> "zip"
getMatQuery = (.| C.map entityVal) . E.selectSource . E.from $
\(course `E.InnerJoin` material `E.InnerJoin` materialFile `E.InnerJoin` file) -> do
E.on $ file E.^. FileId E.==. materialFile E.^. MaterialFileFile
E.on $ material E.^. MaterialId E.==. materialFile E.^. MaterialFileMaterial
E.on $ material E.^. MaterialCourse E.==. course E.^. CourseId
E.where_ $ course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
E.&&. material E.^. MaterialName E.==. E.val mnm
return file
getMArchiveR tid ssh csh mnm = do
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgMaterialArchiveName tid ssh csh mnm
let getMatQuery = (.| C.map entityVal) . E.selectSource . E.from $
\(course `E.InnerJoin` material `E.InnerJoin` materialFile `E.InnerJoin` file) -> do
E.on $ file E.^. FileId E.==. materialFile E.^. MaterialFileFile
E.on $ material E.^. MaterialId E.==. materialFile E.^. MaterialFileMaterial
E.on $ material E.^. MaterialCourse E.==. course E.^. CourseId
E.where_ $ course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
E.&&. material E.^. MaterialName E.==. E.val mnm
return file
serveSomeFiles archiveName getMatQuery

11
src/Handler/Sheet.hs
View File

@ -60,6 +60,8 @@ import Utils.Sql
import Data.Aeson hiding (Result(..))
import Text.Hamlet (ihamlet)
import System.FilePath (addExtension)
{-
* Implement Handlers
@ -439,9 +441,8 @@ getSShowR tid ssh csh shn = do
getSArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent
getSArchiveR tid ssh csh shn = do
MsgRenderer mr <- getMsgRenderer
let archiveName = (unpack . stripAll $ mr (prependCourseTitle tid ssh csh $ SomeMessage shn)) <.> "zip"
sftArchive = CSheetR tid ssh csh shn . SZipR -- used to check access to SheetFileTypes
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgSheetArchiveName tid ssh csh shn
let sftArchive = CSheetR tid ssh csh shn . SZipR -- used to check access to SheetFileTypes
allowedSFTs <- filterM (hasReadAccessTo . sftArchive) [minBound..maxBound]
serveZipArchive archiveName $ sheetFilesSFTsQuery tid ssh csh shn allowedSFTs .| C.map entityVal
@ -476,8 +477,8 @@ getSFileR tid ssh csh shn sft file = serveOneFile $ sheetFileQuery tid ssh csh s
getSZipR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> Handler TypedContent
getSZipR tid ssh csh shn sft = do
MsgRenderer mr <- getMsgRenderer
let archiveName = (unpack . stripAll $ mr (prependCourseTitle tid ssh csh $ SomeMessage shn)) <> "_" <> (unpack $ toPathPiece sft) <.> "zip"
sft' <- ap getMessageRender $ pure sft
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgSheetTypeArchiveName tid ssh csh shn sft'
serveSomeFiles archiveName $ sheetFilesAllQuery tid ssh csh shn sft .| C.map entityVal

11
src/Handler/Submission.hs
View File

@ -45,6 +45,8 @@ import Text.Hamlet (ihamlet)
-- import qualified Yesod.Colonnade as Yesod
-- import qualified Text.Blaze.Html5.Attributes as HA
import System.FilePath (addExtension)
-- DEPRECATED: We always show all edits!
-- numberOfSubmissionEditDates :: Int64
-- numberOfSubmissionEditDates = 3 -- for debugging only, should be 1 in production.
@ -574,11 +576,10 @@ getSubArchiveR tid ssh csh shn cID sfType = do
when (sfType == SubmissionCorrected) $
guardAuthResult =<< evalAccess (CSubmissionR tid ssh csh shn cID CorrectionR) False
let filename
| SubmissionOriginal <- sfType = toPathPiece cID <> "-" <> toPathPiece sfType
| otherwise = toPathPiece cID
sfType' <- ap getMessageRender $ pure sfType
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgSubmissionTypeArchiveName tid ssh csh shn cID sfType'
source = do
let source = do
submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID
rating <- lift $ getRating submissionID
@ -593,7 +594,7 @@ getSubArchiveR tid ssh csh shn cID sfType = do
when (sfType == SubmissionCorrected) $
maybe (return ()) (yieldM . ratingFile cID) rating
serveSomeFiles (unpack filename <.> "zip") source
serveSomeFiles archiveName source
getSubDelR, postSubDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
getSubDelR = postSubDelR

4
src/Handler/Utils.hs
View File

@ -75,7 +75,7 @@ serveSomeFiles archiveName source = do
[file] -> sendThisFile file
_moreFiles -> do
setContentDisposition' $ Just archiveName
respondSourceDB "application/zip" $ do
respondSourceDB typeZip $ do
let zipComment = T.encodeUtf8 $ pack archiveName
source .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder
@ -92,7 +92,7 @@ serveZipArchive archiveName source = do
[] -> notFound
_moreFiles -> do
setContentDisposition' $ Just archiveName
respondSourceDB "application/zip" $ do
respondSourceDB typeZip $ do
let zipComment = T.encodeUtf8 $ pack archiveName
source .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder

5
src/Handler/Utils/Csv.hs
View File

@ -32,7 +32,6 @@ import qualified Data.Map as Map
import qualified Data.Vector as Vector
import qualified Data.HashMap.Strict as HashMap
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Attoparsec.ByteString.Lazy as A
@ -43,8 +42,8 @@ instance Exception CsvParseError
typeCsv, typeCsv' :: ContentType
typeCsv = "text/csv"
typeCsv' = BS.intercalate "; " [typeCsv, "charset=UTF-8", "header=present"]
typeCsv = simpleContentType typeCsv'
typeCsv' = "text/csv; charset=UTF-8; header=present"
extensionCsv :: Extension
extensionCsv = fromMaybe "csv" $ listToMaybe [ ext | (ext, mime) <- Map.toList mimeMap, mime == typeCsv ]

9
src/Handler/Utils/Form.hs
View File

@ -645,12 +645,17 @@ zipFileField doUnpack permittedExtensions = Field{..}
| otherwise = return . Left $ SomeMessage MsgOnlyUploadOneFile
fieldView fieldId fieldName attrs _ req = $(widgetFile "widgets/zipFileField")
zipExtensions = mimeExtensions "application/zip"
zipExtensions = mimeExtensions typeZip
acceptRestricted = isJust permittedExtensions
accept = Text.intercalate "," . map ("." <>) $ bool [] (Set.toList zipExtensions) doUnpack ++ toListOf (_Just . re _nullable . folded) permittedExtensions
multiFileField :: Handler (Set FileId) -> Field Handler (Source Handler (Either FileId File))
multiFileField' :: Source Handler (Either FileId File) -- ^ Permitted files in same format as produced by `multiFileField`
-> Field Handler (Source Handler (Either FileId File))
multiFileField' permittedFiles = multiFileField . runConduit $ permittedFiles .| C.mapMaybe (preview _Left) .| C.foldMap Set.singleton
multiFileField :: Handler (Set FileId) -- ^ Set of files that may be submitted by id-reference
-> Field Handler (Source Handler (Either FileId File))
multiFileField permittedFiles' = Field{..}
where
fieldEnctype = Multipart

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

@ -279,8 +279,9 @@ submissionMultiArchive (Set.toList -> ids) = do
execWriter . forM ratedSubmissions $ \(_rating,_submission,(shn,csh,ssh,tid)) ->
tell (Set.singleton shn, Set.singleton csh, Set.singleton ssh, Set.singleton tid)
setContentDisposition' $ Just "submissions.zip"
(<* cleanup) . respondSource "application/zip" . transPipe (runDBRunner dbrunner) $ do
archiveName <- ap getMessageRender $ pure MsgSubmissionArchiveName
setContentDisposition' $ Just ((addExtension `on` unpack) archiveName extensionZip)
(<* cleanup) . respondSource typeZip . transPipe (runDBRunner dbrunner) $ do
let
fileEntitySource' :: (Rating, Entity Submission, (SheetName,CourseShorthand,SchoolId,TermId)) -> Source (YesodDB UniWorX) File
fileEntitySource' (rating, Entity submissionID Submission{..},(shn,csh,ssh,tid)) = do

15
src/Handler/Utils/Zip.hs
View File

@ -2,7 +2,8 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Handler.Utils.Zip
( ZipError(..)
( typeZip, extensionZip
, ZipError(..)
, ZipInfo(..)
, produceZip
, consumeZip
@ -27,6 +28,16 @@ import Data.Time.LocalTime (localTimeToUTC, utcToLocalTime)
import Data.List (dropWhileEnd)
import qualified Data.Map as Map
typeZip :: ContentType
typeZip = "application/zip"
extensionZip :: Extension
extensionZip = fromMaybe "zip" $ listToMaybe [ ext | (ext, mime) <- Map.toList mimeMap, mime == typeZip ]
instance Default ZipInfo where
def = ZipInfo
@ -95,7 +106,7 @@ modifyFileTitle f = mapC $ \x@File{..} -> x{ fileTitle = f fileTitle }
-- Takes FileInfo and if it is a ZIP-Archive, extract files, otherwiese yield fileinfo
sourceFiles :: (MonadLogger m, MonadResource m, MonadThrow m, MonadIO m) => FileInfo -> Source m File
sourceFiles fInfo
| mimeType == "application/zip" = do
| ((==) `on` simpleContentType) mimeType typeZip = do
$logInfoS "sourceFiles" "Unpacking ZIP"
fileSource fInfo =$= void consumeZip
| otherwise = do

47
src/Model/Migration.hs
View File

@ -34,8 +34,11 @@ import Text.Shakespeare.Text (st)
import Control.Monad.Trans.Reader (mapReaderT)
import Control.Monad.Except (MonadError(..))
import Utils (exceptT, allM, whenIsJust, guardM)
import Utils.Lens (_NoUpload)
import Utils.DB (getKeyBy)
import Control.Lens
import Numeric.Natural
import qualified Net.IP as IP
@ -398,6 +401,50 @@ customMigrations = Map.fromListWith (>>)
updateTransactionInfo _ = return ()
runConduit $ getLogEntries .| C.mapM_ updateTransactionInfo
)
, ( AppliedMigrationKey [migrationVersion|16.0.0|] [version|17.0.0|]
, do
whenM (tableExists "allocation_course") $ do
vals <- [sqlQQ| SELECT "course", "instructions", "application_text", "application_files", "ratings_visible" FROM "allocation_course"; |]
whenM (tableExists "course") $ do
[executeQQ|
ALTER TABLE "course" ADD COLUMN "applications_required" boolean not null default #{False}, ADD COLUMN "applications_instructions" varchar null, ADD COLUMN "applications_text" boolean not null default #{False}, ADD COLUMN "applications_files" jsonb not null default #{NoUpload}, ADD COLUMN "applications_ratings_visible" boolean not null default #{False};
ALTER TABLE "course" ALTER COLUMN "applications_required" DROP DEFAULT, ALTER COLUMN "applications_text" DROP DEFAULT, ALTER COLUMN "applications_files" DROP DEFAULT, ALTER COLUMN "applications_ratings_visible" DROP DEFAULT;
|]
forM_ vals $ \(cid :: CourseId, Single applicationsInstructions :: Single (Maybe Html), Single applicationsText :: Single Bool, Single applicationsFiles :: Single UploadMode, Single applicationsRatingsVisible :: Single Bool) -> do
let appRequired = applicationsText || isn't _NoUpload applicationsFiles
[executeQQ|
UPDATE "course" SET ("applications_required", "applications_instructions", "applications_text", "applications_files", "applications_ratings_visible") = (#{appRequired}, #{applicationsInstructions}, #{applicationsText}, #{applicationsFiles}, #{applicationsRatingsVisible}) WHERE "id" = #{cid};
|]
[executeQQ|
ALTER TABLE "allocation_course" DROP COLUMN "instructions", DROP COLUMN "application_text", DROP COLUMN "application_files", DROP COLUMN "ratings_visible";
|]
whenM ((&&) <$> tableExists "allocation_course_file" <*> (not <$> tableExists "course_app_instruction_file")) $ do
[executeQQ|
CREATe TABLE "course_app_instruction_file"("id" SERIAL8 PRIMARY KEY UNIQUE,"course" INT8 NOT NULL,"file" INT8 NOT NULL);
ALTER TABLE "course_app_instruction_file" ADD CONSTRAINT "unique_course_app_instruction_file" UNIQUE("course","file");
ALTER TABLE "course_app_instruction_file" ADD CONSTRAINT "course_app_instruction_file_course_fkey" FOREIGN KEY("course") REFERENCES "course"("id");
ALTER TABLE "course_app_instruction_file" ADD CONSTRAINT "course_app_instruction_file_file_fkey" FOREIGN KEY("file") REFERENCES "file"("id");
|]
let getFileEntries = rawQuery [st|SELECT "allocation_course_file"."id", "allocation_course"."course", "allocation_course_file"."file" FROM "allocation_course_file" INNER JOIN "allocation_course" ON "allocation_course"."id" = "allocation_course_file"."allocation_course"|] []
moveFileEntry [fromPersistValue -> Right (acfId :: Int64), fromPersistValue -> Right (cid :: CourseId), fromPersistValue -> Right (fid :: FileId)] =
[executeQQ|
INSERT INTO "course_app_instruction_file" ("course", "file") VALUES (#{cid}, #{fid});
DELETE FROM "allocation_course_file" WHERE "id" = #{acfId};
|]
moveFileEntry _ = return ()
runConduit $ getFileEntries .| C.mapM_ moveFileEntry
tableDropEmpty "allocation_course_file"
whenM (tableExists "allocation_application") $
tableDropEmpty "allocation_application"
whenM (tableExists "allocation_application_file") $
tableDropEmpty "allocation_application_file"
)
]

2
src/Utils/Icon.hs
View File

@ -54,6 +54,7 @@ data Icon
| IconSFTSolution -- for SheetFileType only
| IconSFTMarking -- for SheetFileType only
| IconEmail
| IconRegisterTemplate
deriving (Eq, Ord, Enum, Bounded, Show, Read)
iconText :: Icon -> Text
@ -82,6 +83,7 @@ iconText = \case
IconSFTSolution -> "exclamation-circle" -- for SheetFileType only
IconSFTMarking -> "check-circle" -- for SheetFileType only
IconEmail -> "envelope"
IconRegisterTemplate -> "file-alt"
instance Universe Icon
instance Finite Icon

1
src/Utils/Lens.hs
View File

@ -120,6 +120,7 @@ makePrisms ''HandlerContents
makePrisms ''ErrorResponse
makePrisms ''UploadMode
makeLenses_ ''UploadMode
makeLenses_ ''SubmissionMode

18
templates/course.hamlet
View File

@ -79,8 +79,26 @@ $# $if NTop (Just 0) < NTop (courseCapacity course)
<div>
\ <em>Achtung:</em>
\ Abmeldung nur bis #{dereg} erlaubt.
$maybe aInst <- courseApplicationsInstructions course
<dt .deflist__dt>
$if courseApplicationsRequired course
_{MsgCourseApplicationInstructionsApplication}
$else
_{MsgCourseApplicationInstructionsRegistration}
<dd .deflist__dd>
<div>
#{aInst}
$if hasApplicationTemplate
<p>
<a href=@{CourseR tid ssh csh CRegisterTemplateR}>
#{iconRegisterTemplate} #
$if courseApplicationsRequired course
_{MsgCourseApplicationTemplateApplication}
$else
_{MsgCourseApplicationTemplateRegistration}
$if registrationOpen || isJust mRegAt
<dt .deflist__dt>
_{MsgCourseRegistration}
<dd .deflist__dd>
<div .course__registration>
$if registrationOpen

30
test/Database.hs
View File

@ -420,6 +420,11 @@ fillDb = do
, courseDeregisterUntil = Nothing
, courseRegisterSecret = Nothing
, courseMaterialFree = True
, courseApplicationsRequired = False
, courseApplicationsInstructions = Nothing
, courseApplicationsText = False
, courseApplicationsFiles = NoUpload
, courseApplicationsRatingsVisible = False
}
insert_ $ CourseEdit jost now ffp
void . insert $ DegreeCourse ffp sdBsc sdInf
@ -452,6 +457,11 @@ fillDb = do
, courseDeregisterUntil = Nothing
, courseRegisterSecret = Nothing
, courseMaterialFree = True
, courseApplicationsRequired = False
, courseApplicationsInstructions = Nothing
, courseApplicationsText = False
, courseApplicationsFiles = NoUpload
, courseApplicationsRatingsVisible = False
}
insert_ $ CourseEdit fhamann now eip
void . insert' $ DegreeCourse eip sdBsc sdInf
@ -470,6 +480,11 @@ fillDb = do
, courseDeregisterUntil = Nothing
, courseRegisterSecret = Nothing
, courseMaterialFree = True
, courseApplicationsRequired = False
, courseApplicationsInstructions = Nothing
, courseApplicationsText = False
, courseApplicationsFiles = NoUpload
, courseApplicationsRatingsVisible = False
}
insert_ $ CourseEdit fhamann now ixd
void . insert' $ DegreeCourse ixd sdBsc sdInf
@ -488,6 +503,11 @@ fillDb = do
, courseDeregisterUntil = Nothing
, courseRegisterSecret = Nothing
, courseMaterialFree = True
, courseApplicationsRequired = False
, courseApplicationsInstructions = Nothing
, courseApplicationsText = False
, courseApplicationsFiles = NoUpload
, courseApplicationsRatingsVisible = False
}
insert_ $ CourseEdit fhamann now ux3
void . insert' $ DegreeCourse ux3 sdBsc sdInf
@ -506,6 +526,11 @@ fillDb = do
, courseDeregisterUntil = Nothing
, courseRegisterSecret = Nothing
, courseMaterialFree = True
, courseApplicationsRequired = False
, courseApplicationsInstructions = Nothing
, courseApplicationsText = False
, courseApplicationsFiles = NoUpload
, courseApplicationsRatingsVisible = False
}
insert_ $ CourseEdit jost now pmo
void . insert $ DegreeCourse pmo sdBsc sdInf
@ -662,6 +687,11 @@ fillDb = do
, courseDeregisterUntil = Nothing
, courseRegisterSecret = Just "dbs"
, courseMaterialFree = False
, courseApplicationsRequired = False
, courseApplicationsInstructions = Nothing
, courseApplicationsText = False
, courseApplicationsFiles = NoUpload
, courseApplicationsRatingsVisible = False
}
insert_ $ CourseEdit gkleen now dbs
void . insert' $ DegreeCourse dbs sdBsc sdInf