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

feat(course): introduce CourseNews

Browse Source
This commit is contained in:
Gregor Kleen 2019-10-01 19:46:40 +02:00
parent 6aa44b1585
commit aa93b75e00
48 changed files with 802 additions and 186 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
messages/uniworx/de.msg
View File

@ -36,6 +36,9 @@ RegisterTo: Anmeldungen bis
DeRegUntil: Abmeldungen bis
RegisterRetry: Sie wurden noch nicht angemeldet. Drücken Sie dazu den Knopf "Anmelden"
CourseRegistrationInterval: Anmeldezeitraum
CourseDeregisterUntil time@Text: Abmeldung nur bis #{time}
GenericKey: Schlüssel
GenericShort: Kürzel
GenericIsNew: Neu
@ -378,12 +381,14 @@ UnauthorizedRegistered: Sie sind nicht als Teilnehmer für diese Veranstaltung r
UnauthorizedAllocationRegistered: Sie sind nicht als Teilnehmer für diese Zentralanmeldung registriert.
UnauthorizedExamResult: Sie haben keine Ergebnisse in dieser Prüfung.
UnauthorizedParticipant: Angegebener Benutzer ist nicht als Teilnehmer dieser Veranstaltung registriert.
UnauthorizedCourseNewsParticipant: Sie sind kein Teilnehmer dieser Veranstaltung.
UnauthorizedCourseTime: Dieses Kurs erlaubt momentan keine Anmeldungen.
UnauthorizedAllocationRegisterTime: Diese Zentralanmeldung erlaubt momentan keine Bewerbungen.
UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben.
UnauthorizedApplicationTime: Diese Bewerbung ist momentan nicht freigegeben.
UnauthorizedMaterialTime: Dieses Material ist momentan nicht freigegeben.
UnauthorizedTutorialTime: Dieses Tutorium erlaubt momentan keine Anmeldungen.
UnauthorizedCourseNewsTime: Diese Nachricht ist momentan nicht freigegeben.
UnauthorizedExamTime: Diese Prüfung ist momentan nicht freigegeben.
UnauthorizedSubmissionOwner: Sie sind an dieser Abgabe nicht beteiligt.
UnauthorizedSubmissionRated: Diese Abgabe ist noch nicht korrigiert.
@ -1021,7 +1026,7 @@ MenuAllocationList: Zentralanmeldungen
MenuCourseList: Kurse
MenuCourseMembers: Kursteilnehmer
MenuCourseAddMembers: Kursteilnehmer hinzufügen
MenuCourseCommunication: Kursmitteilung
MenuCourseCommunication: Kursmitteilung (E-Mail)
MenuCourseApplications: Bewerbungen
MenuCourseExamOffice: Prüfungsämter
MenuTermShow: Semester
@ -1085,6 +1090,8 @@ MenuAllocationInfo: Hinweise zum Ablauf einer Zentralanmeldung
MenuCourseApplicationsFiles: Dateien aller Bewerbungen
MenuSchoolList: Institute
MenuSchoolNew: Neues Institut anlegen
MenuCourseNewsNew: Neue Kursnachricht
MenuCourseNewsEdit: Kursnachricht bearbeiten
AuthPredsInfo: Um eigene Veranstaltungen aus Sicht der Teilnehmer anzusehen, können Veranstalter und Korrektoren hier die Prüfung ihrer erweiterten Berechtigungen temporär deaktivieren. Abgewählte Prädikate schlagen immer fehl. Abgewählte Prädikate werden also nicht geprüft um Zugriffe zu gewähren, welche andernfalls nicht erlaubt wären. Diese Einstellungen gelten nur temporär bis Ihre Sitzung abgelaufen ist, d.h. bis ihr Browser-Cookie abgelaufen ist. Durch Abwahl von Prädikaten kann man sich höchstens temporär aussperren.
AuthPredsActive: Aktive Authorisierungsprädikate
@ -1124,6 +1131,7 @@ AuthTagRead: Zugriff ist nur lesend
AuthTagWrite: Zugriff ist i.A. schreibend
DeleteCopyStringIfSure n@Int: Wenn Sie sich sicher sind, dass Sie #{pluralDE n "das obige Objekt" "obige Objekte"} unwiderbringlich löschen möchten, schreiben Sie bitte zunächst den angezeigten Text ab.
DeletePressButtonIfSure n@Int: Wenn Sie sich sicher sind, dass Sie #{pluralDE n "das obige Objekt" "obige Objekte"} unwiderbringlich löschen möchten, bestätigen Sie dies bitte durch Drücken des untigen Knopfes.
DeleteConfirmation: Bestätigung
DeleteConfirmationWrong: Bestätigung muss genau dem angezeigten Text entsprechen.
@ -1289,6 +1297,9 @@ HealthSMTPConnect: SMTP-Server kann erreicht werden
HealthWidgetMemcached: Memcached-Server liefert Widgets korrekt aus
HealthActiveJobExecutors: Anteil der job-workers, die neue Befehle annehmen
CourseParticipantsHeading: Kursteilnehmer
CourseParticipantsCount n@Int: #{n}
CourseParticipantsCountOf n@Int m@Int: #{n} von #{m}
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
@ -1823,4 +1834,28 @@ CsvQuoteNone: Nie
CsvQuoteMinimal: Nur wenn nötig
CsvQuoteAll: Immer
CsvOptionsUpdated: CSV-Optionen erfolgreich angepasst
CsvChangeOptionsLabel: Export-Optionen
CsvChangeOptionsLabel: Export-Optionen
CourseNews: Aktuelles
CourseNewsArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand newsTitle@Text: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldCase newsTitle}
CourseNewsFiles: Dateien
CourseNewsLastEdited time@Text: Zuletzt verändert: #{time}
CourseNewsActionEdit: Bearbeiten
CourseNewsActionDelete: Löschen
CourseNewsActionCreate: Neue Nachricht
CourseMaterial: Material
CourseMaterialFree: Das Kursmaterial ist ohne Anmeldung frei zugänglich
CourseMaterialNotFree: Eine Anmeldung zum Kurs ist Voraussetzung zum Zugang zu Kursmaterial
CourseNewsVisibleFromEditWarning: Das Datum der Veröffentlichung liegt in der Vergangenheit und sollte nicht mehr verändert werden, da dies die Teilnehmer verwirren könnte.
CourseNewsVisibleFromTip: Ohne Datum nie sichtbar für Teilnehmer; leer lassen ist nur sinnvoll für noch unfertige Nachrichten
CourseNewsTitle: Titel
CourseNewsSummary: Zusammenfassung
CourseNewsSummaryTip: Wenn angegeben, wird auf der Kursübersichtsseite, platzsparend, nur die Zusammenfassung angezeigt und der Inhalt in ein Popup ausgelagert
CourseNewsContent: Inhalt
CourseNewsParticipantsOnly: Nur für Kursteilnehmer
CourseNewsVisibleFrom: Sichtbar ab
CourseNewsCreated: Kursnachricht erfolgreich angelegt
CourseNewsEdited: Kursnachricht erfolgreich editiert
CourseNewsDeleteQuestion: Wollen Sie die unten aufgeführte Nachricht wirklich löschen?
CourseNewsDeleted: Kursnachricht erfolgreich gelöscht

0
models/allocations → models/allocations.model
View File

0
models/audit → models/audit.model
View File

0
models/config → models/config.model
View File

17
models/courses → models/courses.model
View File

@ -76,20 +76,3 @@ CourseUserExamOfficeOptOut
user UserId
school SchoolId
UniqueCourseUserExamOfficeOptOut course user school
CourseApplication
course CourseId
user UserId
field StudyFeaturesId Maybe -- associated degree course, user-defined; required for communicating grades
text Text Maybe -- free text entered by user
ratingVeto Bool default=false
ratingPoints ExamGrade Maybe
ratingComment Text Maybe
allocation AllocationId Maybe
allocationPriority Natural Maybe
time UTCTime default=now()
ratingTime UTCTime Maybe
CourseApplicationFile
application CourseApplicationId
file FileId
UniqueApplicationFile application file

16
models/courses/applications.model Normal file
View File

@ -0,0 +1,16 @@
CourseApplication
course CourseId
user UserId
field StudyFeaturesId Maybe -- associated degree course, user-defined; required for communicating grades
text Text Maybe -- free text entered by user
ratingVeto Bool default=false
ratingPoints ExamGrade Maybe
ratingComment Text Maybe
allocation AllocationId Maybe
allocationPriority Natural Maybe
time UTCTime default=now()
ratingTime UTCTime Maybe
CourseApplicationFile
application CourseApplicationId
file FileId
UniqueApplicationFile application file

3
models/materials → models/courses/materials.model
View File

@ -9,4 +9,5 @@ Material -- course material for disemination to course participants
deriving Generic
MaterialFile -- a file that is part of a material distribution
material MaterialId
file FileId
file FileId
UniqueMaterialFile material file

12
models/courses/news.model Normal file
View File

@ -0,0 +1,12 @@
CourseNews
course CourseId
visibleFrom UTCTime Maybe
participantsOnly Bool
title Text Maybe
content Html
summary Html Maybe
lastEdit UTCTime
CourseNewsFile
news CourseNewsId
file FileId
UniqueCourseNewsFile news file

0
models/exam-office → models/exam-office.model
View File

0
models/exams → models/exams.model
View File

0
models/files → models/files.model
View File

0
models/invitations → models/invitations.model
View File

0
models/jobs → models/jobs.model
View File

0
models/schools → models/schools.model
View File

0
models/sheets → models/sheets.model
View File

0
models/submissions → models/submissions.model
View File

0
models/system-messages → models/system-messages.model
View File

0
models/terms → models/terms.model
View File

0
models/tutorials → models/tutorials.model
View File

0
models/users → models/users.model
View File

2
package.yaml
View File

@ -138,6 +138,7 @@ dependencies:
- deepseq
- multiset
- retry
- generic-lens
other-extensions:
- GeneralizedNewtypeDeriving
@ -202,6 +203,7 @@ ghc-options:
- -fno-warn-partial-type-signatures
- -fno-max-relevant-binds
- -j
- -freduction-depth=0
when:
- condition: flag(pedantic)

7
routes
View File

@ -179,6 +179,13 @@
/apps/#CryptoFileNameCourseApplication CourseApplicationR:
/ CAEditR GET POST !timeANDself !lecturerANDstaff-time !selfANDread
/files CAFilesR GET !self !lecturerANDstaff-time
!/news/add CNewsNewR GET POST
/news/#CryptoUUIDCourseNews CourseNewsR:
/ CNShowR GET !timeANDparticipant
/edit CNEditR GET POST
/delete CNDeleteR GET POST
!/download CNArchiveR GET !timeANDparticipant
!/download/*FilePath CNFileR GET !timeANDparticipant
/subs CorrectionsR GET POST !corrector !lecturer
/subs/upload CorrectionsUploadR GET POST !corrector !lecturer

1
src/CryptoID.hs
View File

@ -48,6 +48,7 @@ decCryptoIDs [ ''SubmissionId
, ''AllocationId
, ''CourseApplicationId
, ''CourseId
, ''CourseNewsId
]
-- CryptoIDNamespace (CI FilePath) SubmissionId ~ "Submission"

270
src/Foundation.hs
View File

@ -156,8 +156,20 @@ deriving instance Generic CourseApplicationR
deriving instance Generic AllocationR
deriving instance Generic SchoolR
deriving instance Generic ExamOfficeR
deriving instance Generic CourseNewsR
deriving instance Generic (Route UniWorX)
data RouteChildren
type instance Children RouteChildren a = ChildrenRouteChildren a
type family ChildrenRouteChildren a where
ChildrenRouteChildren (Route EmbeddedStatic) = '[]
ChildrenRouteChildren (Route Auth) = '[]
ChildrenRouteChildren UUID = '[]
ChildrenRouteChildren (Key a) = '[]
ChildrenRouteChildren (CI a) = '[]
ChildrenRouteChildren a = Children ChGeneric a
-- | Convenient Type Synonyms:
type DB = YesodDB UniWorX
type Form x = Html -> MForm (HandlerFor UniWorX) (FormResult x, Widget)
@ -188,6 +200,10 @@ pattern CSubmissionR tid ssh csh shn cid ptn
pattern CApplicationR :: TermId -> SchoolId -> CourseShorthand -> CryptoFileNameCourseApplication -> CourseApplicationR -> Route UniWorX
pattern CApplicationR tid ssh csh appId ptn
= CourseR tid ssh csh (CourseApplicationR appId ptn)
pattern CNewsR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> CourseNewsR -> Route UniWorX
pattern CNewsR tid ssh csh nId ptn
= CourseR tid ssh csh (CourseNewsR nId ptn)
pluralDE :: (Eq a, Num a)
@ -934,6 +950,13 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
&& NTop systemMessageTo >= cTime
return Authorized
CNewsR _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedCourseNewsTime) $ do
nId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
CourseNews{courseNewsVisibleFrom} <- $cachedHereBinary nId . MaybeT $ get nId
cTime <- (NTop . Just) <$> liftIO getCurrentTime
guard $ NTop courseNewsVisibleFrom <= cTime
return Authorized
r -> $unsupportedAuthPredicate AuthTime r
tagAccessPredicate AuthStaffTime = APDB $ \_ route isWrite -> case route of
CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do
@ -1104,81 +1127,96 @@ tagAccessPredicate AuthAllocationRegistered = APDB $ \mAuthId route _ -> case ro
void . MaybeT . $cachedHereBinary (uid, aId) . getKeyBy $ UniqueAllocationUser aId uid
return Authorized
r -> $unsupportedAuthPredicate AuthAllocationRegistered r
tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of
CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do
cTime <- liftIO getCurrentTime
let
authorizedIfExists :: E.From a => (a -> E.SqlQuery b) -> ExceptT AuthResult DB ()
authorizedIfExists = flip whenExceptT Authorized <=< lift . E.selectExists . E.from
participant <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedParticipant) (const True :: CryptoIDError -> Bool) $ decrypt cID
-- participant is currently registered
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` courseParticipant) -> do
E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val participant
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
-- participant has at least one submission
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do
E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val participant
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
-- participant is member of a submissionGroup
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser) -> do
E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup
E.on $ course E.^. CourseId E.==. submissionGroup E.^. SubmissionGroupCourse
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val participant
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
-- participant is a sheet corrector
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val participant
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
-- participant is a tutorial user
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialUser) -> do
E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val participant
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
-- participant is tutor for this course
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do
E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
E.where_ $ tutor E.^. TutorUser E.==. E.val participant
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
-- participant is lecturer for this course
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` lecturer) -> do
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
E.where_ $ lecturer E.^. LecturerUser E.==. E.val participant
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
-- participant is applicant for this course
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \((course `E.InnerJoin` courseApplication) `E.LeftOuterJoin` allocation) -> do
E.on $ allocation E.?. AllocationId E.==. courseApplication E.^. CourseApplicationAllocation
E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
E.where_ $ courseApplication E.^. CourseApplicationUser E.==. E.val participant
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
E.where_ $ E.maybe E.true (E.maybe E.false $ \f -> f E.<=. E.val cTime) (allocation E.?. AllocationStaffAllocationFrom)
E.&&. E.maybe E.true (E.maybe E.true $ \t -> t E.>=. E.val cTime) (allocation E.?. AllocationStaffAllocationTo)
tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of
CNewsR tid ssh csh cID _ -> maybeT (unauthorizedI MsgUnauthorizedCourseNewsParticipant) $ do
uid <- hoistMaybe mAuthId
nId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
CourseNews{courseNewsParticipantsOnly} <- $cachedHereBinary nId . MaybeT $ get nId
if | courseNewsParticipantsOnly
-> exceptT return (const mzero) . hoist lift $ isCourseParticipant tid ssh csh uid
| otherwise
-> return Authorized
CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do
participant <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedParticipant) (const True :: CryptoIDError -> Bool) $ decrypt cID
isCourseParticipant tid ssh csh participant
unauthorizedI MsgUnauthorizedParticipant
r -> $unsupportedAuthPredicate AuthParticipant r
where
isCourseParticipant tid ssh csh participant = do
cTime <- liftIO getCurrentTime
let
authorizedIfExists :: E.From a => (a -> E.SqlQuery b) -> ExceptT AuthResult DB ()
authorizedIfExists = flip whenExceptT Authorized <=< lift . E.selectExists . E.from
-- participant is currently registered
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` courseParticipant) -> do
E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val participant
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
-- participant has at least one submission
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do
E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val participant
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
-- participant is member of a submissionGroup
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser) -> do
E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup
E.on $ course E.^. CourseId E.==. submissionGroup E.^. SubmissionGroupCourse
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val participant
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
-- participant is a sheet corrector
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val participant
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
-- participant is a tutorial user
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialUser) -> do
E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val participant
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
-- participant is tutor for this course
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do
E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
E.where_ $ tutor E.^. TutorUser E.==. E.val participant
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
-- participant is lecturer for this course
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` lecturer) -> do
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
E.where_ $ lecturer E.^. LecturerUser E.==. E.val participant
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
-- participant is applicant for this course
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \((course `E.InnerJoin` courseApplication) `E.LeftOuterJoin` allocation) -> do
E.on $ allocation E.?. AllocationId E.==. courseApplication E.^. CourseApplicationAllocation
E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
E.where_ $ courseApplication E.^. CourseApplicationUser E.==. E.val participant
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
E.where_ $ E.maybe E.true (E.maybe E.false $ \f -> f E.<=. E.val cTime) (allocation E.?. AllocationStaffAllocationFrom)
E.&&. E.maybe E.true (E.maybe E.true $ \t -> t E.>=. E.val cTime) (allocation E.?. AllocationStaffAllocationTo)
return ()
tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of
CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgTutorialNoCapacity) $ do
cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
@ -1848,6 +1886,11 @@ instance YesodBreadcrumbs UniWorX where
breadcrumb (CourseR tid ssh csh CTutorialListR) = return ("Tutorien", Just $ CourseR tid ssh csh CShowR)
breadcrumb (CourseR tid ssh csh CTutorialNewR) = return ("Anlegen", Just $ CourseR tid ssh csh CTutorialListR)
breadcrumb (CourseR tid ssh csh CNewsNewR) = return ("Neue Nachricht", Just $ CourseR tid ssh csh CShowR)
breadcrumb (CNewsR tid ssh csh _ CNShowR) = return ("Kursnachricht" , Just $ CourseR tid ssh csh CShowR)
breadcrumb (CNewsR tid ssh csh cID CNEditR) = return ("Bearbeiten" , Just $ CNewsR tid ssh csh cID CNShowR)
breadcrumb (CNewsR tid ssh csh cID CNDeleteR) = return ("Löschen" , Just $ CNewsR tid ssh csh cID CNShowR)
breadcrumb (CourseR tid ssh csh CExamListR) = return ("Prüfungen", Just $ CourseR tid ssh csh CShowR)
breadcrumb (CourseR tid ssh csh CExamNewR) = return ("Anlegen", Just $ CourseR tid ssh csh CExamListR)
@ -3135,12 +3178,18 @@ routeNormalizers :: [Route UniWorX -> WriterT Any DB (Route UniWorX)]
routeNormalizers =
[ normalizeRender
, ncSchool
, ncAllocation
, ncCourse
, ncSheet
, ncMaterial
, ncTutorial
, ncExam
, verifySubmission
, verifyCourseApplication
, verifyCourseNews
]
where
normalizeRender :: Route UniWorX -> WriterT Any DB (Route UniWorX)
normalizeRender route = route <$ do
YesodRequest{..} <- liftHandler getRequest
let original = (W.pathInfo reqWaiRequest, reqGetParams)
@ -3151,37 +3200,64 @@ routeNormalizers =
| otherwise -> do
$logDebugS "normalizeRender" [st|Redirecting because #{tshow rendered} does not match #{tshow original}|]
tell $ Any True
maybeOrig :: (Route UniWorX -> MaybeT (WriterT Any DB) (Route UniWorX))
-> Route UniWorX -> WriterT Any DB (Route UniWorX)
maybeOrig f route = maybeT (return route) $ f route
hasChanged a b
caseChanged :: (Eq a, Show a) => CI a -> CI a -> MaybeT (WriterT Any DB) ()
caseChanged a b
| ((/=) `on` original) a b = do
$logDebugS "routeNormalizers" [st|#{tshow a} /= #{tshow b}|]
tell $ Any True
| otherwise = return ()
ncSchool = maybeOrig $ \route -> do
TermSchoolCourseListR tid ssh <- return route
ncSchool = maybeOrig . typesUsing @RouteChildren @SchoolId $ \ssh -> $cachedHereBinary ssh $ do
let schoolShort :: SchoolShorthand
schoolShort = unSchoolKey ssh
Entity ssh' _ <- MaybeT . lift . getBy $ UniqueSchoolShorthand schoolShort
(hasChanged `on` unSchoolKey)ssh ssh'
return $ TermSchoolCourseListR tid ssh'
(caseChanged `on` unSchoolKey) ssh ssh'
return ssh'
ncAllocation = maybeOrig $ \route -> do
AllocationR tid ssh ash _ <- return route
Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . lift . getBy $ TermSchoolAllocationShort tid ssh ash
caseChanged ash allocationShorthand
return $ route & typesUsing @RouteChildren @AllocationShorthand . filtered (== ash) .~ allocationShorthand
ncCourse = maybeOrig $ \route -> do
CourseR tid ssh csh subRoute <- return route
Entity _ Course{..} <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
hasChanged csh courseShorthand
(hasChanged `on` unSchoolKey) ssh courseSchool
return $ CourseR tid courseSchool courseShorthand subRoute
CourseR tid ssh csh _ <- return route
Entity _ Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh
caseChanged csh courseShorthand
return $ route & typesUsing @RouteChildren @CourseShorthand . filtered (== csh) .~ courseShorthand
ncSheet = maybeOrig $ \route -> do
CSheetR tid ssh csh shn subRoute <- return route
Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
Entity _ Sheet{..} <- MaybeT . lift . getBy $ CourseSheet cid shn
hasChanged shn sheetName
return $ CSheetR tid ssh csh sheetName subRoute
CSheetR tid ssh csh shn _ <- return route
Entity cid Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh
Entity _ Sheet{..} <- MaybeT . $cachedHereBinary (cid, shn) . lift . getBy $ CourseSheet cid shn
caseChanged shn sheetName
return $ route & typesUsing @RouteChildren @SheetName . filtered (== shn) .~ sheetName
ncMaterial = maybeOrig $ \route -> do
CMaterialR tid ssh csh mnm _ <- return route
Entity cid Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh
Entity _ Material{..} <- MaybeT . $cachedHereBinary (cid, mnm) . lift . getBy $ UniqueMaterial cid mnm
caseChanged mnm materialName
return $ route & typesUsing @RouteChildren @MaterialName . filtered (== mnm) .~ materialName
ncTutorial = maybeOrig $ \route -> do
CTutorialR tid ssh csh tutn _ <- return route
Entity cid Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh
Entity _ Tutorial{..} <- MaybeT . $cachedHereBinary (cid, tutn) . lift . getBy $ UniqueTutorial cid tutn
caseChanged tutn tutorialName
return $ route & typesUsing @RouteChildren @TutorialName . filtered (== tutn) .~ tutorialName
ncExam = maybeOrig $ \route -> do
CExamR tid ssh csh examn _ <- return route
Entity cid Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh
Entity _ Exam{..} <- MaybeT . $cachedHereBinary (cid, examn) . lift . getBy $ UniqueExam cid examn
caseChanged examn examName
return $ route & typesUsing @RouteChildren @ExamName . filtered (== examn) .~ examName
verifySubmission = maybeOrig $ \route -> do
CSubmissionR _tid _ssh _csh _shn cID sr <- return route
sId <- decrypt cID
Submission{submissionSheet} <- lift . lift $ get404 sId
Sheet{sheetCourse, sheetName} <- lift . lift $ get404 submissionSheet
Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 sheetCourse
sId <- $cachedHereBinary cID $ decrypt cID
Submission{submissionSheet} <- MaybeT . $cachedHereBinary cID . lift $ get sId
Sheet{sheetCourse, sheetName} <- MaybeT . $cachedHereBinary submissionSheet . lift $ get submissionSheet
Course{courseTerm, courseSchool, courseShorthand} <- MaybeT . $cachedHereBinary sheetCourse . lift $ get sheetCourse
let newRoute = CSubmissionR courseTerm courseSchool courseShorthand sheetName cID sr
tell . Any $ route /= newRoute
return newRoute
@ -3193,6 +3269,14 @@ routeNormalizers =
let newRoute = CApplicationR courseTerm courseSchool courseShorthand cID sr
tell . Any $ route /= newRoute
return newRoute
verifyCourseNews = maybeOrig $ \route -> do
CNewsR _tid _ssh _csh cID sr <- return route
aId <- decrypt cID
CourseNews{courseNewsCourse} <- lift . lift $ get404 aId
Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 courseNewsCourse
let newRoute = CNewsR courseTerm courseSchool courseShorthand cID sr
tell . Any $ route /= newRoute
return newRoute
-- How to run database actions.
@ -3202,7 +3286,9 @@ instance YesodPersist UniWorX where
$logDebugS "YesodPersist" "runDB"
runSqlPool action =<< appConnPool <$> getYesod
instance YesodPersistRunner UniWorX where
getDBRunner = defaultGetDBRunner appConnPool
getDBRunner = do
(DBRunner{..}, cleanup) <- defaultGetDBRunner appConnPool
return . (, cleanup) $ DBRunner (\act -> $logDebugS "YesodPersist" "runDBRunner" >> runDBRunner act)
data CampusUserConversionException
= CampusUserInvalidEmail

1
src/Handler/Course.hs
View File

@ -17,6 +17,7 @@ import Handler.Course.User as Handler.Course
import Handler.Course.Users as Handler.Course
import Handler.Course.Application as Handler.Course
import Handler.ExamOffice.Course as Handler.Course
import Handler.Course.News as Handler.Course
getCHiWisR :: TermId -> SchoolId -> CourseShorthand -> Handler Html

9
src/Handler/Course/News.hs Normal file
View File

@ -0,0 +1,9 @@
module Handler.Course.News
( module Handler.Course.News
) where
import Handler.Course.News.New as Handler.Course.News
import Handler.Course.News.Edit as Handler.Course.News
import Handler.Course.News.Download as Handler.Course.News
import Handler.Course.News.Show as Handler.Course.News
import Handler.Course.News.Delete as Handler.Course.News

44
src/Handler/Course/News/Delete.hs Normal file
View File

@ -0,0 +1,44 @@
module Handler.Course.News.Delete
( getCNDeleteR, postCNDeleteR
) where
import Import
import Handler.Utils.Delete
import qualified Data.Set as Set
getCNDeleteR, postCNDeleteR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> Handler Html
getCNDeleteR = postCNDeleteR
postCNDeleteR tid ssh csh cID = do
nId <- decrypt cID
let
drRecords :: Set (Key CourseNews)
drRecords = Set.singleton nId
drGetInfo = return
drUnjoin = id
drRenderRecord :: Entity CourseNews -> DB Widget
drRenderRecord (Entity _ CourseNews{..})
= return . fromMaybe (toWidget courseNewsContent) $ asum
[ toWidget <$> courseNewsTitle
, toWidget <$> courseNewsSummary
]
drRecordConfirmString :: Entity CourseNews -> DB Text
drRecordConfirmString _ = return ""
drCaption, drSuccessMessage :: SomeMessage UniWorX
drCaption = SomeMessage MsgCourseNewsDeleteQuestion
drSuccessMessage = SomeMessage MsgCourseNewsDeleted
drAbort, drSuccess :: SomeRoute UniWorX
drAbort = SomeRoute $ CourseR tid ssh csh CShowR :#: [st|news-#{toPathPiece cID}|]
drSuccess = SomeRoute $ CourseR tid ssh csh CShowR
drDelete :: forall a. CourseNewsId -> DB a -> DB a
drDelete _ = id
deleteR DeleteRoute{..}

41
src/Handler/Course/News/Download.hs Normal file
View File

@ -0,0 +1,41 @@
module Handler.Course.News.Download
( getCNArchiveR
, getCNFileR
) where
import Import
import Handler.Utils
import qualified Database.Esqueleto as E
import qualified Data.Conduit.List as C
getCNArchiveR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> Handler TypedContent
getCNArchiveR tid ssh csh cID = do
nId <- decrypt cID
CourseNews{..} <- runDB $ get404 nId
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgCourseNewsArchiveName tid ssh csh (fromMaybe (toPathPiece courseNewsLastEdit) courseNewsTitle)
let getFilesQuery = (.| C.map entityVal) . E.selectSource . E.from $
\(newsFile `E.InnerJoin` file) -> do
E.on $ file E.^. FileId E.==. newsFile E.^. CourseNewsFileFile
E.where_ $ newsFile E.^. CourseNewsFileNews E.==. E.val nId
return file
serveSomeFiles archiveName getFilesQuery
getCNFileR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> FilePath -> Handler TypedContent
getCNFileR _ _ _ cID title = do
nId <- decrypt cID
let
fileQuery = E.selectSource . E.from $ \(newsFile `E.InnerJoin` file) -> do
E.on $ newsFile E.^. CourseNewsFileFile E.==. file E.^. FileId
E.where_ $ newsFile E.^. CourseNewsFileNews E.==. E.val nId
E.&&. file E.^. FileTitle E.==. E.val title
return file
serveOneFile $ fileQuery .| C.map entityVal

54
src/Handler/Course/News/Edit.hs Normal file
View File

@ -0,0 +1,54 @@
module Handler.Course.News.Edit
( getCNEditR, postCNEditR
) where
import Import
import Handler.Utils
import Handler.Course.News.Form
import qualified Data.Set as Set
import qualified Data.Conduit.List as C
getCNEditR, postCNEditR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> Handler Html
getCNEditR = postCNEditR
postCNEditR tid ssh csh cID = do
nId <- decrypt cID
(courseNews@CourseNews{..}, fids) <- runDB $ do
courseNews <- get404 nId
cnfs <- selectList [CourseNewsFileNews ==. nId] []
return ( courseNews
, setOf (folded . _entityVal . _courseNewsFileFile) cnfs
)
((newsRes, newsWgt'), newsEnctype) <- runFormPost . courseNewsForm . Just $ courseNewsToForm courseNews fids
formResult newsRes $ \CourseNewsForm{..} -> do
now <- liftIO getCurrentTime
runDB $ do
replace nId CourseNews
{ courseNewsCourse
, courseNewsVisibleFrom = cnfVisibleFrom
, courseNewsParticipantsOnly = cnfParticipantsOnly
, courseNewsTitle = cnfTitle
, courseNewsContent = cnfContent
, courseNewsSummary = cnfSummary
, courseNewsLastEdit = now
}
let
insertFile (Left fId) = fId <$ upsertBy (UniqueCourseNewsFile nId fId) (CourseNewsFile nId fId) []
insertFile (Right f ) = insert f >>= \fId -> fId <$ insert_ (CourseNewsFile nId fId)
newFids <- runConduit $ transPipe lift (fromMaybe (return ()) cnfFiles) .| C.mapM insertFile .| C.foldMap Set.singleton
deleteWhere [ CourseNewsFileNews ==. nId, CourseNewsFileFile /<-. Set.toList newFids ]
addMessageI Success MsgCourseNewsEdited
redirect $ CourseR tid ssh csh CShowR :#: [st|news-#{toPathPiece cID}|]
siteLayoutMsg MsgMenuCourseNewsEdit $ do
setTitleI MsgMenuCourseNewsEdit
wrapForm newsWgt' def
{ formAction = Just . SomeRoute $ CNewsR tid ssh csh cID CNEditR
, formEncoding = newsEnctype
}

71
src/Handler/Course/News/Form.hs Normal file
View File

@ -0,0 +1,71 @@
module Handler.Course.News.Form
( CourseNewsForm(..)
, courseNewsForm
, courseNewsToForm
) where
import Import
import Handler.Utils
import Text.Blaze.Renderer.Text (renderMarkup)
import qualified Data.Conduit.List as C
import qualified Data.Set as Set
data CourseNewsForm = CourseNewsForm
{ cnfTitle :: Maybe Text
, cnfSummary :: Maybe Html
, cnfContent :: Html
, cnfParticipantsOnly :: Bool
, cnfVisibleFrom :: Maybe UTCTime
, cnfFiles :: Maybe (ConduitT () (Either FileId File) Handler ())
}
courseNewsForm :: Maybe CourseNewsForm -> Form CourseNewsForm
courseNewsForm template = identifyForm FIDCourseNews . renderWForm FormStandard $ do
now <- liftIO getCurrentTime
let oldFileIds = maybe (return mempty) (\s -> runConduit $ s .| C.foldMap (either opoint $ const mempty)) $ template >>= cnfFiles
cTime = ceilingQuarterHour now
visibleFromTip
| Just vFrom <- template >>= cnfVisibleFrom
, vFrom <= now
= MsgCourseNewsVisibleFromEditWarning
| otherwise
= MsgCourseNewsVisibleFromTip
cnfTitle' <- wopt
(textField & cfStrip & guardField (not . null))
(fslI MsgCourseNewsTitle)
(cnfTitle <$> template)
cnfSummary' <- wopt
(htmlField & guardField (not . null . renderMarkup))
(fslI MsgCourseNewsSummary & setTooltip MsgCourseNewsSummaryTip)
(cnfSummary <$> template)
cnfContent' <- wreq
(htmlField & guardField (not . null . renderMarkup))
(fslI MsgCourseNewsContent)
(cnfContent <$> template)
cnfParticipantsOnly' <- wpopt checkBoxField (fslI MsgCourseNewsParticipantsOnly) (cnfParticipantsOnly <$> template)
cnfVisibleFrom' <- wopt utcTimeField (fslI MsgCourseNewsVisibleFrom & setTooltip visibleFromTip) (cnfVisibleFrom <$> template <|> Just (Just cTime))
cnfFiles' <- wopt (multiFileField oldFileIds) (fslI MsgCourseNewsFiles) (cnfFiles <$> template)
return $ CourseNewsForm
<$> cnfTitle'
<*> cnfSummary'
<*> cnfContent'
<*> cnfParticipantsOnly'
<*> cnfVisibleFrom'
<*> cnfFiles'
courseNewsToForm :: CourseNews -> Set FileId -> CourseNewsForm
courseNewsToForm CourseNews{..} fs = CourseNewsForm
{ cnfTitle = courseNewsTitle
, cnfSummary = courseNewsSummary
, cnfContent = courseNewsContent
, cnfParticipantsOnly = courseNewsParticipantsOnly
, cnfVisibleFrom = courseNewsVisibleFrom
, cnfFiles = guardOn (not $ Set.null fs) $ C.sourceList (Left <$> Set.toList fs)
}

47
src/Handler/Course/News/New.hs Normal file
View File

@ -0,0 +1,47 @@
module Handler.Course.News.New
( getCNewsNewR, postCNewsNewR
) where
import Import
import Handler.Utils
import Handler.Course.News.Form
import qualified Data.Conduit.List as C
getCNewsNewR, postCNewsNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCNewsNewR = postCNewsNewR
postCNewsNewR tid ssh csh = do
cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
((newsRes, newsWgt'), newsEnctype) <- runFormPost $ courseNewsForm Nothing
formResult newsRes $ \CourseNewsForm{..} -> do
now <- liftIO getCurrentTime
cID <- runDB $ do
nId <- insert CourseNews
{ courseNewsCourse = cid
, courseNewsVisibleFrom = cnfVisibleFrom
, courseNewsParticipantsOnly = cnfParticipantsOnly
, courseNewsTitle = cnfTitle
, courseNewsContent = cnfContent
, courseNewsSummary = cnfSummary
, courseNewsLastEdit = now
}
let
insertFile (Left fId) = insert_ $ CourseNewsFile nId fId
insertFile (Right f ) = insert_ . CourseNewsFile nId =<< insert f
forM_ cnfFiles $ \fSource ->
runConduit $ transPipe lift fSource .| C.mapM_ insertFile
encrypt nId :: DB CryptoUUIDCourseNews
addMessageI Success MsgCourseNewsCreated
redirect $ CourseR tid ssh csh CShowR :#: [st|news-#{toPathPiece cID}|]
siteLayoutMsg MsgMenuCourseNewsNew $ do
setTitleI MsgMenuCourseNewsNew
wrapForm newsWgt' def
{ formAction = Just . SomeRoute $ CourseR tid ssh csh CNewsNewR
, formEncoding = newsEnctype
}

17
src/Handler/Course/News/Show.hs Normal file
View File

@ -0,0 +1,17 @@
module Handler.Course.News.Show
( getCNShowR
) where
import Import
import Handler.Utils
getCNShowR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> Handler Html
getCNShowR tid ssh csh cID = do
nId <- decrypt cID
CourseNews{..} <- runDB $ get404 nId
siteLayout' (toWidget <$> courseNewsTitle) $ do
setTitleI . prependCourseTitle tid ssh csh $ maybe (SomeMessage MsgCourseNews) SomeMessage courseNewsTitle
$(widgetFile "course-news")

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

@ -18,7 +18,7 @@ import qualified Database.Esqueleto as E
import Handler.Course.Register
import System.FilePath (addExtension)
import System.FilePath (addExtension, pathSeparator)
import qualified Data.Conduit.List as C
@ -26,7 +26,7 @@ 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,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication) <- runDB . maybeT notFound $ do
(cid,course,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news) <- 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
@ -71,12 +71,25 @@ getCShowR tid ssh csh = do
hasApplicationTemplate <- lift . E.selectExists . E.from $ \courseAppInstructionFile ->
E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. E.val cid
mApplication <- lift . fmap (listToMaybe =<<) . for mbAid $ \uid -> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Nothing] []
return (cid,course,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication)
news' <- lift $ selectList [ CourseNewsCourse ==. cid ] [ Desc CourseNewsVisibleFrom, Desc CourseNewsTitle, Desc CourseNewsSummary, Desc CourseNewsContent ]
cTime <- NTop . Just <$> liftIO getCurrentTime
news <- forMaybeM news' $ \(Entity nId n@CourseNews{..}) -> do
cID <- encrypt nId :: MaybeT (MaybeT DB) CryptoUUIDCourseNews
guardM . hasReadAccessTo $ CNewsR tid ssh csh cID CNShowR
let visible = cTime >= NTop courseNewsVisibleFrom
files' <- lift . lift . E.select . E.from $ \(newsFile `E.InnerJoin` file) -> do
E.on $ file E.^. FileId E.==. newsFile E.^. CourseNewsFileFile
E.where_ $ newsFile E.^. CourseNewsFileNews E.==. E.val nId
return (E.isNothing $ file E.^. FileContent, file E.^. FileTitle)
let files = files'
& over (mapped . _1) E.unValue
& over (mapped . _2) E.unValue
lastEditText <- formatTime SelFormatDateTime $ maybe id max (guardOn visible =<< courseNewsVisibleFrom) courseNewsLastEdit
return (cID, n, visible, files, lastEditText)
return (cid,course,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news)
mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course
mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course
mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course
mRegAt <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration
cID <- encrypt cid :: Handler CryptoUUIDCourse
mAllocation' <- for mAllocation $ \Allocation{..} -> (,)
<$> pure allocationName
@ -236,6 +249,14 @@ getCShowR tid ssh csh = do
& defaultSorting [SortAscBy "time"]
(Any hasExams, examTable) <- runDB $ dbTable examDBTableValidator examDBTable
let visibleNews = any (view _3) news
showNewsFiles fs = and
[ not $ null fs
, length fs <= 3
, all (not . elem pathSeparator . view _2) fs
]
mayCreateNews <- hasWriteAccessTo $ CourseR tid ssh csh CNewsNewR
siteLayout (toWgt $ courseName course) $ do
setTitleI $ prependCourseTitle tid ssh csh (""::Text)
$(widgetFile "course")

2
src/Handler/Material.hs
View File

@ -61,7 +61,7 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do
flip (renderAForm FormStandard) html $ MaterialForm
<$> areq (textField & cfStrip & cfCI) (fslI MsgMaterialName) (mfName <$> template)
<*> aopt (textField & cfStrip & cfCI & addDatalist typeOptions)
<*> aopt (textField & cfStrip & guardField (not . null) & cfCI & addDatalist typeOptions)
(fslpI MsgMaterialType $ mr MsgMaterialTypePlaceholder)
(mfType <$> template)
<*> aopt htmlField (fslpI MsgMaterialDescription "Html")

11
src/Handler/Utils/Delete.hs
View File

@ -53,14 +53,17 @@ confirmForm confirmString = flip traverseAForm aform $ \(inpConfirmStr, BtnDelet
where
aform = (,)
<$> areq confirmField (fslI MsgDeleteConfirmation) Nothing
<*> disambiguateButtons (combinedButtonFieldF "")
<*> pure BtnDelete
confirmField
| multiple = convertField unTextarea Textarea textareaField
| otherwise = textField
multiple = length (filter (not . Text.null . Text.strip) $ Text.lines confirmString) > 1
confirmFormReduced :: Monad m => AForm m Bool
confirmFormReduced = pure True
confirmForm' :: PersistEntity record => Set (Key record) -> Text -> Form Bool
confirmForm' drRecords confirmString = addDeleteTargets . identifyForm FIDDelete . renderAForm FormStandard $ confirmForm confirmString
confirmForm' drRecords confirmString = addDeleteTargets . identifyForm FIDDelete . renderAForm FormStandard . maybe confirmFormReduced confirmForm $ assertM' (not . Text.null . Text.strip) confirmString
where
addDeleteTargets :: Form a -> Form a
addDeleteTargets form csrf = do
@ -99,10 +102,10 @@ getDeleteR DeleteRoute{..} = do
(deleteFormWdgt, deleteFormEnctype) <- generateFormPost $ confirmForm' drRecords confirmString
targetRoute <- fromMaybe (error "getDeleteR called from 404-handler") <$> getCurrentRoute
let deleteForm = wrapForm deleteFormWdgt def
let deleteForm = wrapForm' BtnDelete deleteFormWdgt def
{ formAction = Just $ SomeRoute targetRoute
, formEncoding = deleteFormEnctype
, formSubmit = FormNoSubmit
, formSubmit = FormSubmit
}
sendResponse =<<

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

@ -746,10 +746,11 @@ multiFileField permittedFiles' = Field{..}
| Right sentVals' <- sentVals = fuiId' `elem` sentVals'
| otherwise = True
return FileUploadInfo{..}
fileInfos <- mapM toFUI <=< handlerToWidget . runDB . E.select . E.from $ \file -> do
fileInfos' <- mapM toFUI <=< handlerToWidget . runDB . E.select . E.from $ \file -> do
E.where_ $ file E.^. FileId `E.in_` E.valList (setToList pVals)
E.orderBy [E.asc $ file E.^. FileTitle]
return (file E.^. FileId, file E.^. FileTitle)
let fileInfos = sortOn fuiTitle fileInfos'
$(widgetFile "widgets/multiFileField")
unpackZips :: Text
unpackZips = "unpack-zip"

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

@ -961,7 +961,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (Map.findWithDefault (error $ "Invalid filter key: " <> show key) key dbtFilter) args t) >> expr) (return ()) psFilter
return (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64), dbtRowKey t, res)
let mapMaybeM f = fmap catMaybes . mapM (\(k, v) -> runMaybeT $ (,) <$> pure k <*> f v)
let mapMaybeM' f = mapMaybeM $ \(k, v) -> (,) <$> pure k <*> f v
firstRow :: Int64
firstRow
| PagesizeLimit l <- psLimit
@ -974,7 +974,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
| otherwise
= id
(currentKeys, rows) <- fmap unzip . mapMaybeM dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrKey, dbrOutput)) -> (dbrKey, DBRow{..})) . zip [firstRow..] $ reproduceSorting rows'
(currentKeys, rows) <- fmap unzip . mapMaybeM' dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrKey, dbrOutput)) -> (dbrKey, DBRow{..})) . zip [firstRow..] $ reproduceSorting rows'
formResult csvMode $ \case

16
src/Utils.hs
View File

@ -51,7 +51,9 @@ import Control.Arrow as Utils ((>>>))
import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT)
import Control.Monad.Except (MonadError(..))
import Control.Monad.Trans.Maybe as Utils (MaybeT(..))
import Control.Monad.Trans.Writer.Lazy (execWriterT, tell)
import Control.Monad.Catch
import Control.Monad.Morph (hoist)
import Language.Haskell.TH
import Language.Haskell.TH.Instances ()
@ -529,6 +531,20 @@ maybeThrow exc = maybe (throwM exc) return
maybeThrowM :: (MonadThrow m, Exception e) => m e -> Maybe a -> m a
maybeThrowM excM = maybe (throwM =<< excM) return
mapMaybeM :: ( Monad m
, MonoFoldable (f a)
, MonoPointed (f b)
, Monoid (f b)
) => (Element (f a) -> MaybeT m (Element (f b))) -> f a -> m (f b)
mapMaybeM f = execWriterT . mapM_ (void . runMaybeT . (lift . tell . opoint <=< hoist lift . f))
forMaybeM :: ( Monad m
, MonoFoldable (f a)
, MonoPointed (f b)
, Monoid (f b)
) => f a -> (Element (f a) -> MaybeT m (Element (f b))) -> m (f b)
forMaybeM = flip mapMaybeM
------------
-- Either --
------------

1
src/Utils/Form.hs
View File

@ -196,6 +196,7 @@ data FormIdentifier
| FIDcourseRegister
| FIDsheet
| FIDmaterial
| FIDCourseNews
| FIDsubmission
| FIDsettings
| FIDcorrectors

9
src/Utils/Lens.hs
View File

@ -19,10 +19,14 @@ import Utils.Lens.TH as Utils.Lens
import Data.Set.Lens as Utils.Lens
import Data.Map.Lens as Utils.Lens
import Data.Generics.Product.Types as Utils.Lens
import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
import qualified Database.Esqueleto as E (Value(..),InnerJoin(..))
import qualified Data.CaseInsensitive as CI
_PathPiece :: PathPiece v => Prism' Text v
_PathPiece = prism' toPathPiece fromPathPiece
@ -48,6 +52,9 @@ _SchoolId = iso unSchoolKey SchoolKey
_Maybe :: Iso' (Maybe ()) Bool
_Maybe = iso (is _Just) (bool Nothing (Just ()))
_CI :: FoldCase s => Iso' (CI s) s
_CI = iso CI.original CI.mk
-----------------------------------
-- Lens Definitions for our Types
@ -197,6 +204,8 @@ makeLenses_ ''SchoolLdap
makeLenses_ ''UserFunction
makeLenses_ ''CourseUserExamOfficeOptOut
makeLenses_ ''CourseNewsFile
-- makeClassy_ ''Load

2
stack.yaml
View File

@ -58,5 +58,7 @@ extra-deps:
- process-1.6.5.1
- generic-lens-1.2.0.0
resolver: lts-13.21
allow-newer: true

12
templates/course-news.hamlet Normal file
View File

@ -0,0 +1,12 @@
$newline never
$maybe summary <- courseNewsSummary
<section>
<dl .deflist>
<dt .deflist__dt>
_{MsgCourseNewsSummary}
<dd .deflist__dd>
#{summary}
<section>
#{courseNewsContent}
$nothing
#{courseNewsContent}

150
templates/course.hamlet
View File

@ -1,16 +1,75 @@
$newline never
<dl .deflist>
<dt .deflist__dt>Fakultät/Institut
<dd .deflist__dd>
<div>
#{schoolName}
$if not (null news) || not visibleNews
<dt .deflist__dt>
_{MsgCourseNews}
$if not visibleNews
\ #{iconInvisible}
<dd .deflist__dd>
$if not (null news)
<ul .course-news .list--iconless>
$forall (cID, CourseNews{courseNewsTitle, courseNewsSummary, courseNewsContent}, isVisible, files, lastEditText) <- news
<li .course-news-item ##{"news-" <> toPathPiece cID}>
$case (courseNewsTitle, courseNewsSummary)
$# $of (Just title, Just summary)
$# <div .div-h3 .course-news-item__title>
$# ^{modal (toWidget title) (Left (SomeRoute (CNewsR tid ssh csh cID CNShowR)))}
$# $if not isVisible
$# \ #{iconInvisible}
$# <p .course-news-item__summary>
$# #{summary}
$of (_, Just summary)
$if not isVisible
<h3 .course-news-item__title>
#{iconInvisible}
<div .div-p .course-news-item__summary>
^{modal (toWidget summary) (Left (SomeRoute (CNewsR tid ssh csh cID CNShowR)))}
$of (Just title, Nothing)
<h3 .course-news-item__title>
#{title}
$if not isVisible
\ #{iconInvisible}
<p .course-news-item__content>
#{courseNewsContent}
$of (Nothing, Nothing)
$if not isVisible
<h3 .course-news-item__title>
#{iconInvisible}
<p .course-news-item__content>
#{courseNewsContent}
$if showNewsFiles files
<ul .course-news-item__files-links .list--inline .list--comma-separated>
$forall (_, fp) <- filter (not . view _1) files
<li .course-news-item__file-link>
<a href=@{CNewsR tid ssh csh cID (CNFileR fp)}>
#{fp}
$elseif not (null files)
<p .course-news-item__files-link>
<a href=@{CNewsR tid ssh csh cID CNArchiveR}>
#{iconFileZip}
\ _{MsgCourseNewsFiles}
<p .course-news-item__last-edit>
_{MsgCourseNewsLastEdited lastEditText}
<ul .course-news-item__actions .list--inline .list--comma-separated>
<li>
^{modal (i18n MsgCourseNewsActionEdit) (Left (SomeRoute (CNewsR tid ssh csh cID CNEditR)))}
<li>
^{modal (i18n MsgCourseNewsActionDelete) (Left (SomeRoute (CNewsR tid ssh csh cID CNDeleteR)))}
$if mayCreateNews
<div .div-p>
^{modal (i18n MsgCourseNewsActionCreate) (Left (SomeRoute (CourseR tid ssh csh CNewsNewR)))}
$maybe descr <- courseDescription course
<dt .deflist__dt>_{MsgCourseDescription}
<dd .deflist__dd>
<div>
#{descr}
<dt .deflist__dt>_{MsgCourseSchool}
<dd .deflist__dd>
#{schoolName}
$with numlecs <- length lecturers
$if numlecs /= 0
$if numlecs > 1
@ -18,10 +77,9 @@ $newline never
$else
<dt .deflist__dt>_{MsgLecturerFor}
<dd .deflist__dd>
<div>
<ul .list--inline .list--comma-separated>
$forall lect <- lecturers
<li>^{nameEmailWidget' lect}
<ul .list--inline .list--comma-separated>
$forall lect <- lecturers
<li>^{nameEmailWidget' lect}
$with numassi <- length assistants
$if numassi /= 0
$if numassi > 1
@ -29,58 +87,53 @@ $newline never
$else
<dt .deflist__dt>_{MsgAssistantFor}
<dd .deflist__dd>
<div>
<ul .list--inline .list--comma-separated>
$forall assi <- assistants
<li>^{nameEmailWidget' assi}
<ul .list--inline .list--comma-separated>
$forall assi <- assistants
<li>^{nameEmailWidget' assi}
$with numtutor <- length tutors
$if numtutor /= 0
<dt .deflist__dt>_{MsgTutorsFor numtutor}
<dd .deflist__dd>
<div>
<ul .list--inline .list--comma-separated>
$forall tutor <- tutors
<li>^{nameEmailWidget' tutor}
<ul .list--inline .list--comma-separated>
$forall tutor <- tutors
<li>^{nameEmailWidget' tutor}
$with numcorrector <- length correctors
$if numcorrector /= 0
<dt .deflist__dt>_{MsgCorrectorsFor numcorrector}
<dd .deflist__dd>
<div>
<ul .list--inline .list--comma-separated>
$forall corrector <- correctors
<li>^{nameEmailWidget' corrector}
<ul .list--inline .list--comma-separated>
$forall corrector <- correctors
<li>^{nameEmailWidget' corrector}
$maybe link <- courseLinkExternal course
<dt .deflist__dt>Website
<dt .deflist__dt>_{MsgCourseHomepageExternal}
<dd .deflist__dd>
<div>
<a href=#{link} target="_blank" rel="noopener" title="Website des Kurses">#{link}
<a href=#{link} target="_blank" rel="noopener" title="_{MsgCourseHomepageExternal}">
#{iconLink}
\ #{link}
$# $if NTop (Just 0) < NTop (courseCapacity course)
<dt .deflist__dt>Teilnehmer
<dt .deflist__dt>_{MsgCourseParticipantsHeading}
<dd .deflist__dd>
<div>
#{participants}
$maybe capacity <- courseCapacity course
\ von #{capacity}
$maybe capacity <- courseCapacity course
_{MsgCourseParticipantsCountOf participants capacity}
$nothing
_{MsgCourseParticipantsCount participants}
$maybe (name, url) <- mAllocation'
<dt .deflist__dt>_{MsgCourseAllocation}
<dd .deflist__dd>
<a href=#{url}>
#{name}
$nothing
$maybe regFrom <- mRegFrom
<dt .deflist__dt>Anmeldezeitraum
$maybe regFrom <- courseRegisterFrom course
<dt .deflist__dt>_{MsgCourseRegistrationInterval}
<dd .deflist__dd>
<div>
Ab #{regFrom}
$maybe regTo <- mRegTo
\ bis #{regTo}
<p>
^{formatTimeRangeW SelFormatDateTime regFrom (courseRegisterTo course)}
$maybe dereg <- mDereg
<div>
\ <em>Achtung:</em>
\ Abmeldung nur bis #{dereg} erlaubt.
<p .emph>
_{MsgCourseDeregisterUntil dereg}
$maybe aInst <- courseApplicationsInstructions course
<dt .deflist__dt>
$if courseApplicationsRequired course
@ -98,7 +151,7 @@ $# $if NTop (Just 0) < NTop (courseCapacity course)
_{MsgCourseApplicationTemplateApplication}
$else
_{MsgCourseApplicationTemplateRegistration}
$if registrationOpen || isJust mRegAt
$if registrationOpen || isJust registration
<dt .deflist__dt>
_{MsgCourseRegistration}
<dd .deflist__dd>
@ -110,20 +163,19 @@ $# $if NTop (Just 0) < NTop (courseCapacity course)
<p>
_{MsgCourseApplicationDeleteToEdit}
$else
$if isJust mRegAt
$if isJust registration
<p>
_{MsgCourseRegistrationDeleteToEdit}
$maybe date <- mRegAt
_{MsgRegisteredSince} #{date}
$maybe CourseParticipant{courseParticipantRegistration} <- registration
_{MsgRegisteredSince}
\ ^{formatTimeW SelFormatDateTime courseParticipantRegistration}
<dt .deflist__dt>
Material
_{MsgCourseMaterial}
<dd .deflist__dd>
<div>
$if courseMaterialFree course
Das Kursmaterial ist ohne Anmeldung frei zugänglich.
$else
Eine Anmeldung zum Kurs ist Voraussetzung zum Zugang zu Kursmaterial
(z.B. Übungsblätter).
$if courseMaterialFree course
_{MsgCourseMaterialFree}
$else
_{MsgCourseMaterialNotFree}
$if hasExams
<dt .deflist__dt>_{MsgCourseExams}
<dd .deflist__dd>

34
templates/course.lucius
View File

@ -6,3 +6,37 @@ th {
th, td {
padding-bottom: 7px;
}
.course-news {
max-height: 50vh;
overflow: auto;
.course-news-item {
padding: 12px 0;
border-bottom: 1px solid #d3d3d3;
&:last-child {
padding-bottom: 0;
border-bottom: none;
}
&:first-child {
padding-top: 0;
}
.course-news-item__last-edit {
color: var(--color-fontsec);
font-style: italic;
}
.course-news-item__title .modal__trigger-label {
font-style: normal;
}
.course-news-item__summary .modal__trigger-label {
font-weight: normal;
font-style: normal;
color: var(--color-font);
}
}
}

22
templates/default-layout.lucius
View File

@ -104,6 +104,10 @@ body {
/* END THEMES */
.emph {
font-style: italic;
}
a,
a:visited {
text-decoration: none;
@ -124,7 +128,7 @@ ul {
margin-left: 20px;
}
h1, h2, h3, h4, h5 {
h1, h2, h3, .div-h3 , h4, h5 {
font-weight: 600;
}
h1 {
@ -134,10 +138,18 @@ h1 {
h2 {
font-size: 24px;
margin: 10px 0;
&:first-child {
margin-top: 0;
}
}
h3 {
h3, .div-h3 {
font-size: 20px;
margin: 10px 0;
&:first-child {
margin-top: 0;
}
}
h4 {
font-size: 16px;
@ -154,7 +166,7 @@ h4 {
font-size: 20px;
}
h3 {
h3, .div-h3 {
font-size: 16px;
}
}
@ -181,7 +193,7 @@ h4 {
text-decoration: underline;
}
p, form {
p, form, .div-p {
margin: 0.5rem 0;
&:last-child {
@ -534,7 +546,7 @@ ul.list--inline {
font-size: 18px;
margin-bottom: 10px;
> p {
> p, > .div-p {
margin-top: 0;
}
}

6
templates/i18n/changelog/de.hamlet
View File

@ -1,5 +1,11 @@
$newline never
<dl .deflist>
<dt .deflist__dt>
^{formatGregorianW 2019 10 01}
<dd .deflist__dd>
<ul>
<li>"Aktuelles" für Kurse
<dt .deflist__dt>
^{formatGregorianW 2019 09 27}
<dd .deflist__dd>

9
templates/i18n/info-lecturer/de.hamlet
View File

@ -124,6 +124,15 @@ $newline text
<a href=@{AuthPredsR}>Berechtigungen hier temporär selbst entziehen
. Um die eigene Veranstaltung aus Sicht eines Teilnehmers zu sehen, deaktiviert man #
die Berechtigungsprüfungen "_{MsgAuthTagLecturer}" und/oder "_{MsgAuthTagCorrector}"
<dt .deflist__dt> Aktuelles
<dd .deflist__dd>
<p>
Es lassen sich, direkt auf der Kursübersichtsseite, Neuigkeiten in Bezug
auf die Veranstaltung auf der Übersichtsseite publizieren ("Aktuelles").
<p>
In Zukunft sind ein RSS-Feed und (opt-in) E-Mail-Benachrichtigungen
hierfür geplant.
<section>
<h2>Übungsbetrieb

23
templates/widgets/delete-confirmation/delete-confirmation.hamlet
View File

@ -1,10 +1,21 @@
<p>_{drCaption}
<ul>
$forall (wdgt, _) <- targets
<li>
^{wdgt}
$newline never
<p>_{SomeMessage $ MsgDeleteCopyStringIfSure (Set.size drRecords)}
<p>_{drCaption}
$case targets
$of [(wdgt, _)]
<p>^{wdgt}
$of _
<ul>
$forall (wdgt, _) <- targets
<li>
^{wdgt}
<p>
$if Text.null (Text.strip confirmString)
_{SomeMessage $ MsgDeletePressButtonIfSure (Set.size drRecords)}
$else
_{SomeMessage $ MsgDeleteCopyStringIfSure (Set.size drRecords)}
<p .confirmationText>
#{confirmString}