diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 730487adc..1af89344d 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -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 \ No newline at end of file +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 \ No newline at end of file diff --git a/models/allocations b/models/allocations.model similarity index 100% rename from models/allocations rename to models/allocations.model diff --git a/models/audit b/models/audit.model similarity index 100% rename from models/audit rename to models/audit.model diff --git a/models/config b/models/config.model similarity index 100% rename from models/config rename to models/config.model diff --git a/models/courses b/models/courses.model similarity index 85% rename from models/courses rename to models/courses.model index 260c4254f..5cdecddd6 100644 --- a/models/courses +++ b/models/courses.model @@ -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 \ No newline at end of file diff --git a/models/courses/applications.model b/models/courses/applications.model new file mode 100644 index 000000000..d1d3a4876 --- /dev/null +++ b/models/courses/applications.model @@ -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 diff --git a/models/materials b/models/courses/materials.model similarity index 89% rename from models/materials rename to models/courses/materials.model index 01076a1cf..b8d321fc3 100644 --- a/models/materials +++ b/models/courses/materials.model @@ -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 \ No newline at end of file + file FileId + UniqueMaterialFile material file \ No newline at end of file diff --git a/models/courses/news.model b/models/courses/news.model new file mode 100644 index 000000000..8596d0930 --- /dev/null +++ b/models/courses/news.model @@ -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 \ No newline at end of file diff --git a/models/exam-office b/models/exam-office.model similarity index 100% rename from models/exam-office rename to models/exam-office.model diff --git a/models/exams b/models/exams.model similarity index 100% rename from models/exams rename to models/exams.model diff --git a/models/files b/models/files.model similarity index 100% rename from models/files rename to models/files.model diff --git a/models/invitations b/models/invitations.model similarity index 100% rename from models/invitations rename to models/invitations.model diff --git a/models/jobs b/models/jobs.model similarity index 100% rename from models/jobs rename to models/jobs.model diff --git a/models/schools b/models/schools.model similarity index 100% rename from models/schools rename to models/schools.model diff --git a/models/sheets b/models/sheets.model similarity index 100% rename from models/sheets rename to models/sheets.model diff --git a/models/submissions b/models/submissions.model similarity index 100% rename from models/submissions rename to models/submissions.model diff --git a/models/system-messages b/models/system-messages.model similarity index 100% rename from models/system-messages rename to models/system-messages.model diff --git a/models/terms b/models/terms.model similarity index 100% rename from models/terms rename to models/terms.model diff --git a/models/tutorials b/models/tutorials.model similarity index 100% rename from models/tutorials rename to models/tutorials.model diff --git a/models/users b/models/users.model similarity index 100% rename from models/users rename to models/users.model diff --git a/package.yaml b/package.yaml index 9b0b96354..132f0f6cd 100644 --- a/package.yaml +++ b/package.yaml @@ -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) diff --git a/routes b/routes index f056b1f98..d74bb5568 100644 --- a/routes +++ b/routes @@ -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 diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 0f1296887..35ec7af50 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -48,6 +48,7 @@ decCryptoIDs [ ''SubmissionId , ''AllocationId , ''CourseApplicationId , ''CourseId + , ''CourseNewsId ] -- CryptoIDNamespace (CI FilePath) SubmissionId ~ "Submission" diff --git a/src/Foundation.hs b/src/Foundation.hs index e3de692ef..4f9445f3e 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -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 diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 241aba4cf..6aefcff7b 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -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 diff --git a/src/Handler/Course/News.hs b/src/Handler/Course/News.hs new file mode 100644 index 000000000..640e4b242 --- /dev/null +++ b/src/Handler/Course/News.hs @@ -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 diff --git a/src/Handler/Course/News/Delete.hs b/src/Handler/Course/News/Delete.hs new file mode 100644 index 000000000..88bc72d90 --- /dev/null +++ b/src/Handler/Course/News/Delete.hs @@ -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{..} diff --git a/src/Handler/Course/News/Download.hs b/src/Handler/Course/News/Download.hs new file mode 100644 index 000000000..f83244ce8 --- /dev/null +++ b/src/Handler/Course/News/Download.hs @@ -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 diff --git a/src/Handler/Course/News/Edit.hs b/src/Handler/Course/News/Edit.hs new file mode 100644 index 000000000..af701c4ca --- /dev/null +++ b/src/Handler/Course/News/Edit.hs @@ -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 + } diff --git a/src/Handler/Course/News/Form.hs b/src/Handler/Course/News/Form.hs new file mode 100644 index 000000000..eb4edaf0a --- /dev/null +++ b/src/Handler/Course/News/Form.hs @@ -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) + } diff --git a/src/Handler/Course/News/New.hs b/src/Handler/Course/News/New.hs new file mode 100644 index 000000000..c6b2f10be --- /dev/null +++ b/src/Handler/Course/News/New.hs @@ -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 + } diff --git a/src/Handler/Course/News/Show.hs b/src/Handler/Course/News/Show.hs new file mode 100644 index 000000000..9fb4f81b1 --- /dev/null +++ b/src/Handler/Course/News/Show.hs @@ -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") diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index cdab9b549..7f14b544e 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -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") diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index c9d1e2677..740ed670d 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -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") diff --git a/src/Handler/Utils/Delete.hs b/src/Handler/Utils/Delete.hs index 6c5e6a0f2..291d8f34c 100644 --- a/src/Handler/Utils/Delete.hs +++ b/src/Handler/Utils/Delete.hs @@ -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 =<< diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index f0573a00f..b2b48ec82 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -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" diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index a268d550a..a5845696b 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -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 diff --git a/src/Utils.hs b/src/Utils.hs index 82c19d0b2..65ea3be49 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -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 -- ------------ diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 80a4443db..392ade039 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -196,6 +196,7 @@ data FormIdentifier | FIDcourseRegister | FIDsheet | FIDmaterial + | FIDCourseNews | FIDsubmission | FIDsettings | FIDcorrectors diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index a97ae8355..c094419a1 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -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 diff --git a/stack.yaml b/stack.yaml index 46618df8e..f83be73a7 100644 --- a/stack.yaml +++ b/stack.yaml @@ -58,5 +58,7 @@ extra-deps: - process-1.6.5.1 + - generic-lens-1.2.0.0 + resolver: lts-13.21 allow-newer: true diff --git a/templates/course-news.hamlet b/templates/course-news.hamlet new file mode 100644 index 000000000..5ba795962 --- /dev/null +++ b/templates/course-news.hamlet @@ -0,0 +1,12 @@ +$newline never +$maybe summary <- courseNewsSummary +
+
+
+ _{MsgCourseNewsSummary} +
+ #{summary} +
+ #{courseNewsContent} +$nothing + #{courseNewsContent} diff --git a/templates/course.hamlet b/templates/course.hamlet index 1372fd58d..8e156bde0 100644 --- a/templates/course.hamlet +++ b/templates/course.hamlet @@ -1,16 +1,75 @@ $newline never
-
Fakultät/Institut -
-
- #{schoolName} - + $if not (null news) || not visibleNews +
+ _{MsgCourseNews} + $if not visibleNews + \ #{iconInvisible} +
+ $if not (null news) +