Tutorials
This commit is contained in:
Gregor Kleen
parent
dd30a97bfa
commit
64c45c515e
2
db.sh
2
db.sh
@ -1,4 +1,6 @@
|
||||
#!/usr/bin/env bash
|
||||
# Options: see /test/Database.hs (Main)
|
||||
set -e
|
||||
|
||||
stack build --fast --flag uniworx:-library-only --flag uniworx:dev
|
||||
stack exec uniworxdb -- $@
|
||||
|
||||
@ -69,10 +69,12 @@ CourseShort: Kürzel
|
||||
CourseCapacity: Kapazität
|
||||
CourseCapacityTip: Anzahl erlaubter Kursanmeldungen, leer lassen für unbeschränkte Kurskapazität
|
||||
CourseNoCapacity: In diesem Kurs sind keine Plätze mehr frei.
|
||||
TutorialNoCapacity: In dieser Übung sind keine Plätze mehr frei.
|
||||
CourseNotEmpty: In diesem Kurs sind momentan Teilnehmer angemeldet.
|
||||
CourseRegisterOk: Anmeldung erfolgreich
|
||||
CourseDeregisterOk: Erfolgreich abgemeldet
|
||||
CourseStudyFeature: Assoziiertes Hauptfach
|
||||
CourseTutorial: Tutorium
|
||||
CourseStudyFeatureTooltip: Korrekte Angabe kann Notenweiterleitungen beschleunigen
|
||||
CourseSecretWrong: Falsches Kennwort
|
||||
CourseSecret: Zugangspasswort
|
||||
@ -120,6 +122,9 @@ CourseUserNoteDeleted: Teilnehmernotiz gelöscht
|
||||
CourseUserDeregister: Abmelden
|
||||
CourseUsersDeregistered count@Int64: #{show count} Teilnehmer abgemeldet
|
||||
CourseUserSendMail: Mitteilung verschicken
|
||||
TutorialUserDeregister: Vom Tutorium Abmelden
|
||||
TutorialUserSendMail: Mitteilung verschicken
|
||||
TutorialUsersDeregistered count@Int64: #{show count} Tutorium-Teilnehmer abgemeldet
|
||||
|
||||
CourseLecturers: Kursverwalter
|
||||
CourseLecturer: Dozent
|
||||
@ -231,6 +236,7 @@ UnauthorizedRegistered: Sie sind nicht als Teilnehmer für diese Veranstaltung r
|
||||
UnauthorizedParticipant: Angegebener Benutzer ist nicht als Teilnehmer dieser Veranstaltung registriert.
|
||||
UnauthorizedCourseTime: Dieses Kurs erlaubt momentan keine Anmeldungen.
|
||||
UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben.
|
||||
UnauthorizedTutorialTime: Dieses Tutorium erlaubt momentan keine Anmeldungen.
|
||||
UnauthorizedSubmissionOwner: Sie sind an dieser Abgabe nicht beteiligt.
|
||||
UnauthorizedSubmissionRated: Diese Abgabe ist noch nicht korrigiert.
|
||||
UnauthorizedSubmissionCorrector: Sie sind nicht der Korrektor für diese Abgabe.
|
||||
@ -248,6 +254,10 @@ UnauthorizedDisabledTag authTag@AuthTag: Authorisierungsprädikat "#{toPathPiece
|
||||
UnknownAuthPredicate tag@String: Authorisierungsprädikat "#{tag}" ist dem System nicht bekannt
|
||||
UnauthorizedRedirect: Die angeforderte Seite existiert nicht oder Sie haben keine Berechtigung, die angeforderte Seite zu sehen.
|
||||
UnauthorizedSelf: Aktueller Nutzer ist nicht angegebener Benutzer.
|
||||
UnauthorizedTutorialTutor: Sie sind nicht Tutor für dieses Tutorium.
|
||||
UnauthorizedCourseTutor: Sie sind nicht Tutor für diesen Kurs.
|
||||
UnauthorizedTutor: Sie sind nicht Tutor.
|
||||
UnauthorizedTutorialRegisterGroup: Sie sind bereits in einem Tutorium mit derselben Registrierungs-Gruppe.
|
||||
|
||||
EMail: E-Mail
|
||||
EMailUnknown email@UserEmail: E-Mail #{email} gehört zu keinem bekannten Benutzer.
|
||||
@ -408,6 +418,8 @@ LecturerFor: Dozent
|
||||
LecturersFor: Dozenten
|
||||
AssistantFor: Assistent
|
||||
AssistantsFor: Assistenten
|
||||
TutorsFor n@Int: #{pluralDE n "Tutor" "Tutoren"}
|
||||
CorrectorsFor n@Int: #{pluralDE n "Korrektor" "Korrektoren"}
|
||||
ForSchools n@Int: für #{pluralDE n "Institut" "Institute"}
|
||||
UserListTitle: Komprehensive Benutzerliste
|
||||
AccessRightsSaved: Berechtigungsänderungen wurden gespeichert.
|
||||
@ -711,6 +723,8 @@ MenuCorrections: Korrekturen
|
||||
MenuCorrectionsOwn: Meine Korrekturen
|
||||
MenuSubmissions: Abgaben
|
||||
MenuSheetList: Übungsblätter
|
||||
MenuTutorialList: Tutorien
|
||||
MenuTutorialNew: Neues Tutorium anlegen
|
||||
MenuSheetNew: Neues Übungsblatt anlegen
|
||||
MenuSheetCurrent: Aktuelles Übungsblatt
|
||||
MenuSheetOldUnassigned: Abgaben ohne Korrektor
|
||||
@ -727,6 +741,8 @@ MenuCorrectionsUpload: Korrekturen hochladen
|
||||
MenuCorrectionsCreate: Abgaben registrieren
|
||||
MenuCorrectionsGrade: Abgaben bewerten
|
||||
MenuAuthPreds: Authorisierungseinstellungen
|
||||
MenuTutorialDelete: Tutorium löschen
|
||||
MenuTutorialEdit: Tutorium editieren
|
||||
|
||||
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
|
||||
@ -739,9 +755,12 @@ AuthTagDeprecated: Seite ist nicht überholt
|
||||
AuthTagDevelopment: Seite ist nicht in Entwicklung
|
||||
AuthTagLecturer: Nutzer ist Dozent
|
||||
AuthTagCorrector: Nutzer ist Korrektor
|
||||
AuthTagTutor: Nutzer ist Tutor
|
||||
AuthTagTime: Zeitliche Einschränkungen sind erfüllt
|
||||
AuthTagRegistered: Nutzer ist Kursteilnehmer
|
||||
AuthTagCourseRegistered: Nutzer ist Kursteilnehmer
|
||||
AuthTagTutorialRegistered: Nutzer ist Tutoriumsteilnehmer
|
||||
AuthTagParticipant: Nutzer ist mit Kurs assoziiert
|
||||
AuthTagRegisterGroup: Nutzer ist nicht Mitglied eines anderen Tutoriums mit der selben Registrierungs-Gruppe
|
||||
AuthTagCapacity: Kapazität ist ausreichend
|
||||
AuthTagEmpty: Kurs hat keine Teilnehmer
|
||||
AuthTagMaterials: Kursmaterialien sind freigegeben
|
||||
@ -773,6 +792,7 @@ CommDuplicateRecipients n@Int: #{tshow n} #{pluralDE n "doppelter" "doppelte"} E
|
||||
CommSuccess n@Int: Nachricht wurde an #{tshow n} Empfänger versandt
|
||||
|
||||
CommCourseHeading: Kursmitteilung
|
||||
CommTutorialHeading: Tutorium-Mitteilung
|
||||
|
||||
RecipientCustom: Weitere Empfänger
|
||||
RecipientToggleAll: Alle/Keine
|
||||
@ -780,6 +800,8 @@ RecipientToggleAll: Alle/Keine
|
||||
RGCourseParticipants: Kursteilnehmer
|
||||
RGCourseLecturers: Kursverwalter
|
||||
RGCourseCorrectors: Korrektoren
|
||||
RGCourseTutors: Tutoren
|
||||
RGTutorialParticipants: Tutorium-Teilnehmer
|
||||
|
||||
MultiSelectFieldTip: Mehrfach-Auswahl ist möglich (Umschalt bzw. Strg)
|
||||
MultiEmailFieldTip: Es sind mehrere, Komma-separierte, E-Mail-Addressen möglich
|
||||
@ -794,3 +816,60 @@ CorrectorInvitationAccepted shn@SheetName: Sie wurden als Korrektor für #{shn}
|
||||
CorrectorInvitationDeclined shn@SheetName: Sie haben die Einladung, Korrektor für #{shn} zu werden, abgelehnt
|
||||
SheetCorrInviteHeading shn@SheetName: Einladung zum Korrektor für #{shn}
|
||||
SheetCorrInviteExplanation: Sie wurden eingeladen, Korrektor für ein Übungsblatt zu sein.
|
||||
|
||||
ScheduleKindWeekly: Wöchentlich
|
||||
|
||||
ScheduleRegular: Planmäßiger Termin
|
||||
ScheduleRegularKind: Plan
|
||||
WeekDay: Wochentag
|
||||
Day: Tag
|
||||
OccurenceStart: Beginn
|
||||
OccurenceEnd: Ende
|
||||
ScheduleExists: Dieser Plan existiert bereits
|
||||
|
||||
ScheduleExceptions: Termin-Ausnahmen
|
||||
ScheduleExceptionsTip: Ausfälle überschreiben planmäßiges Stattfinden. Außerplanmäßiges Stattfinden überschreibt Ausfall
|
||||
ExceptionKind: Termin ...
|
||||
ExceptionKindOccur: Findet statt
|
||||
ExceptionKindNoOccur: Findet nicht statt
|
||||
ExceptionExists: Diese Ausnahme existiert bereits
|
||||
ExceptionNoOccurAt: Termin
|
||||
|
||||
TutorialType: Typ
|
||||
TutorialName: Bezeichnung
|
||||
TutorialParticipants: Teilnehmer
|
||||
TutorialCapacity: Kapazität
|
||||
TutorialRoom: Regulärer Raum
|
||||
TutorialTime: Zeit
|
||||
TutorialRegistered: Angemeldet
|
||||
TutorialRegGroup: Registrierungs-Gruppe
|
||||
TutorialRegisterFrom: Anmeldungen ab
|
||||
TutorialRegisterTo: Anmeldungen bis
|
||||
TutorialDeregisterUntil: Abmeldungen bis
|
||||
TutorialsHeading: Tutorien
|
||||
TutorialEdit: Bearbeiten
|
||||
TutorialDelete: Löschen
|
||||
|
||||
CourseTutorials: Übungen
|
||||
|
||||
ParticipantsN n@Int: Teilnehmer
|
||||
TutorialDeleteQuestion: Wollen Sie das unten aufgeführte Tutorium wirklich löschen?
|
||||
TutorialDeleted: Tutorium gelöscht
|
||||
|
||||
TutorialRegisteredSuccess tutn@TutorialName: Erfolgreich zum Tutorium #{tutn} angemeldet
|
||||
TutorialDeregisteredSuccess tutn@TutorialName: Erfolgreich vom Tutorium #{tutn} abgemeldet
|
||||
|
||||
TutorialNameTip: Muss eindeutig sein
|
||||
TutorialCapacityNonPositive: Kapazität muss größer oder gleich null sein
|
||||
TutorialCapacityTip: Beschränkt wieviele Studenten sich zu diesem Tutorium anmelden können
|
||||
TutorialRegGroupTip: Studenten können sich in jeweils maximal einem Tutorium pro Registrierungs-Gruppe anmelden. Ist bei zwei oder mehr Tutorien keine Registrierungs-Gruppe gesetzt zählen diese als in verschiedenen Registrierungs-Gruppen
|
||||
TutorialRoomPlaceholder: Raum
|
||||
TutorialTutors: Tutoren
|
||||
TutorialTutorAlreadyAdded: Ein Tutor mit dieser E-Mail ist bereits für dieses Tutorium eingetragen
|
||||
|
||||
TutorialNew: Neues Tutorium
|
||||
|
||||
TutorialNameTaken tutn@TutorialName: Es existiert bereits anderes Tutorium mit Namen #{tutn}
|
||||
TutorialCreated tutn@TutorialName: Tutorium #{tutn} erfolgreich angelegt
|
||||
|
||||
TutorialEditHeading tutn@TutorialName: #{tutn} bearbeiten
|
||||
32
models/rooms
32
models/rooms
@ -1,32 +0,0 @@
|
||||
-- ROOMS ARE TODO; THIS IS JUST AN UNUSED STUB
|
||||
-- Idea is to create a selection of rooms that may be
|
||||
-- associated with exercise classes and exams
|
||||
-- offering links to the LMU Roomfinder
|
||||
-- and allow the creation of neat timetables for users
|
||||
Booking
|
||||
term TermId
|
||||
begin UTCTime
|
||||
end UTCTime
|
||||
weekly Bool
|
||||
exceptions [Day] -- only if weekly, begin in exception
|
||||
bookedFor RoomForId
|
||||
room RoomId
|
||||
BookingEdit
|
||||
user UserId
|
||||
time UTCTime
|
||||
boooking BookingId
|
||||
Room
|
||||
name Text
|
||||
capacity Int Maybe
|
||||
building Text Maybe -- name of building
|
||||
roomfinder Text Maybe -- external url for LMU Roomfinder
|
||||
-- BookingRoom
|
||||
-- subject RoomForId
|
||||
-- room RoomId
|
||||
-- booking BookingId
|
||||
-- UniqueRoomCourse subject room booking
|
||||
+RoomFor
|
||||
course CourseId
|
||||
tutorial TutorialId
|
||||
exam ExamId
|
||||
-- data RoomFor = RoomForCourseSum CourseId | RoomForTutorialSum TutorialId ...
|
||||
@ -1,11 +1,20 @@
|
||||
-- TUTORIALS ARE TODO; THIS IS JUST AN UNUSED STUB
|
||||
-- Idea: management of exercise classes, offering sub-enrolement to distribute all students among all exercise classs
|
||||
Tutorial json
|
||||
name Text
|
||||
tutor UserId
|
||||
course CourseId
|
||||
capacity Int Maybe -- limit for enrolement in this tutorial
|
||||
TutorialUser
|
||||
user UserId
|
||||
name TutorialName
|
||||
course CourseId
|
||||
type (CI Text) -- "Tutorium", "Zentralübung", ...
|
||||
capacity Int Maybe -- limit for enrolment in this tutorial
|
||||
room Text
|
||||
time Occurences
|
||||
regGroup (CI Text) Maybe -- each participant may register for one tutorial per regGroup
|
||||
registerFrom UTCTime Maybe
|
||||
registerTo UTCTime Maybe
|
||||
deregisterUntil UTCTime Maybe
|
||||
UniqueTutorial course name
|
||||
Tutor
|
||||
tutorial TutorialId
|
||||
UniqueTutorialUser user tutorial
|
||||
user UserId
|
||||
UniqueTutor tutorial user
|
||||
TutorialParticipant
|
||||
tutorial TutorialId
|
||||
user UserId
|
||||
UniqueTutorialParticipant tutorial user
|
||||
@ -124,6 +124,7 @@ dependencies:
|
||||
- systemd
|
||||
- lifted-async
|
||||
- streaming-commons
|
||||
- hourglass
|
||||
|
||||
other-extensions:
|
||||
- GeneralizedNewtypeDeriving
|
||||
|
||||
26
routes
26
routes
@ -13,8 +13,12 @@
|
||||
-- !free -- free for all
|
||||
-- !lecturer -- lecturer for this course (or for any school, if route is not connected to a course)
|
||||
-- !corrector -- corrector for this sheet (or the submission, if route is connected to a submission, or the course, if route is not connected to a sheet, or any course, if route is not connected to a course)
|
||||
-- !registered -- participant for this course (no effect outside of courses)
|
||||
-- !course-registered -- participant for this course (no effect outside of courses)
|
||||
-- !tutorial-registered -- participant for this tutorial (no effect outside of courses)
|
||||
-- !participant -- connected with a given course (not necessarily registered), i.e. has a submission, is a corrector, etc. (no effect outside of courses)
|
||||
--
|
||||
-- !register-group -- user is member in no other tutorial with same register group
|
||||
--
|
||||
-- !owner -- part of the group of owners of this submission
|
||||
-- !self -- route refers to the currently logged in user themselves
|
||||
-- !capacity -- course this route is associated with has at least one unit of participant capacity
|
||||
@ -84,16 +88,16 @@
|
||||
/communication CCommR GET POST
|
||||
/notes CNotesR GET POST !corrector
|
||||
/subs CCorrectionsR GET POST
|
||||
/ex SheetListR GET !registered !materials !corrector
|
||||
/ex SheetListR GET !course-registered !materials !corrector
|
||||
/ex/new SheetNewR GET POST
|
||||
/ex/current SheetCurrentR GET !registered !materials !corrector
|
||||
/ex/current SheetCurrentR GET !course-registered !materials !corrector
|
||||
/ex/unassigned SheetOldUnassigned GET
|
||||
/ex/#SheetName SheetR:
|
||||
/show SShowR GET !timeANDregistered !timeANDmaterials !corrector
|
||||
/show SShowR GET !timeANDcourse-registered !timeANDmaterials !corrector
|
||||
/edit SEditR GET POST
|
||||
/delete SDelR GET POST
|
||||
/subs SSubsR GET POST -- for lecturer only
|
||||
!/subs/new SubmissionNewR GET POST !timeANDregisteredANDuser-submissions
|
||||
!/subs/new SubmissionNewR GET POST !timeANDcourse-registeredANDuser-submissions
|
||||
!/subs/own SubmissionOwnR GET !free -- just redirect
|
||||
/subs/#CryptoFileNameSubmission SubmissionR:
|
||||
/ SubShowR GET POST !ownerANDtime !ownerANDread !correctorANDread
|
||||
@ -103,9 +107,17 @@
|
||||
/correction CorrectionR GET POST !corrector !ownerANDreadANDrated
|
||||
!/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector
|
||||
/correctors SCorrR GET POST
|
||||
/pseudonym SPseudonymR GET POST !registeredANDcorrector-submissions
|
||||
/pseudonym SPseudonymR GET POST !course-registeredANDcorrector-submissions
|
||||
/corrector-invite/#UserEmail SCorrInviteR GET POST
|
||||
!/#SheetFileType/*FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector
|
||||
!/#SheetFileType/*FilePath SFileR GET !timeANDcourse-registered !timeANDmaterials !corrector
|
||||
/tuts CTutorialListR GET !tutor
|
||||
/tuts/new CTutorialNewR GET POST
|
||||
/tuts/#TutorialName TutorialR:
|
||||
/edit TEditR GET POST
|
||||
/delete TDeleteR GET POST
|
||||
/participants TUsersR GET POST !tutor
|
||||
/register TRegisterR POST !timeANDcapacityANDcourse-registeredANDregister-group !timeANDtutorial-registered
|
||||
/communication TCommR GET POST !tutor
|
||||
|
||||
|
||||
/subs CorrectionsR GET POST !corrector !lecturer
|
||||
|
||||
@ -91,6 +91,7 @@ import Handler.School
|
||||
import Handler.Course
|
||||
import Handler.Sheet
|
||||
import Handler.Submission
|
||||
import Handler.Tutorial
|
||||
import Handler.Corrections
|
||||
import Handler.CryptoIDDispatch
|
||||
import Handler.SystemMessage
|
||||
|
||||
@ -7,6 +7,7 @@ module Database.Esqueleto.Utils
|
||||
, SqlIn(..)
|
||||
, mkExactFilter, mkExactFilterWith
|
||||
, mkContainsFilter
|
||||
, mkExistsFilter
|
||||
, anyFilter, allFilter
|
||||
) where
|
||||
|
||||
@ -104,6 +105,15 @@ mkContainsFilter lenslike row criterias
|
||||
| Set.null criterias = true
|
||||
| otherwise = any (hasInfix $ lenslike row) criterias
|
||||
|
||||
mkExistsFilter :: PathPiece a
|
||||
=> (t -> a -> E.SqlQuery ())
|
||||
-> t
|
||||
-> Set.Set a
|
||||
-> E.SqlExpr (E.Value Bool)
|
||||
mkExistsFilter query row criterias
|
||||
| Set.null criterias = true
|
||||
| otherwise = any (E.exists . query row) criterias
|
||||
|
||||
-- | Combine several filters, using logical or
|
||||
anyFilter :: (Foldable f)
|
||||
=> f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool))
|
||||
@ -122,4 +132,4 @@ allFilter :: (Foldable f)
|
||||
-> E.SqlExpr (E.Value Bool)
|
||||
allFilter fltrs needle criterias = F.foldr aux true fltrs
|
||||
where
|
||||
aux fltr acc = fltr needle criterias E.&&. acc
|
||||
aux fltr acc = fltr needle criterias E.&&. acc
|
||||
|
||||
@ -45,7 +45,7 @@ import Data.Map (Map, (!?))
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.HashSet as HashSet
|
||||
|
||||
import Data.List (nubBy)
|
||||
import Data.List (nubBy, (!!))
|
||||
|
||||
import Data.Monoid (Any(..))
|
||||
|
||||
@ -161,6 +161,10 @@ pattern CSheetR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetR
|
||||
pattern CSheetR tid ssh csh shn ptn
|
||||
= CourseR tid ssh csh (SheetR shn ptn)
|
||||
|
||||
pattern CTutorialR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> TutorialR -> Route UniWorX
|
||||
pattern CTutorialR tid ssh csh shn ptn
|
||||
= CourseR tid ssh csh (TutorialR shn ptn)
|
||||
|
||||
pattern CSubmissionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionR -> Route UniWorX
|
||||
pattern CSubmissionR tid ssh csh shn cid ptn
|
||||
= CSheetR tid ssh csh shn (SubmissionR cid ptn)
|
||||
@ -402,6 +406,14 @@ appLanguagesOpts = do
|
||||
return $ mkOptionList langOptions
|
||||
|
||||
|
||||
instance RenderMessage UniWorX WeekDay where
|
||||
renderMessage _ ls wDay = pack $ map fst (wDays $ getTimeLocale' ls) !! fromEnum wDay
|
||||
|
||||
newtype ShortWeekDay = ShortWeekDay { longWeekDay :: WeekDay }
|
||||
|
||||
instance RenderMessage UniWorX ShortWeekDay where
|
||||
renderMessage _ ls (ShortWeekDay wDay) = pack $ map snd (wDays $ getTimeLocale' ls) !! fromEnum wDay
|
||||
|
||||
-- Access Control
|
||||
newtype InvalidAuthTag = InvalidAuthTag Text
|
||||
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||
@ -582,7 +594,49 @@ tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return ret
|
||||
_ -> do
|
||||
guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny)
|
||||
return Authorized
|
||||
tagAccessPredicate AuthTutor = APDB $ \mAuthId route _ -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
resList <- lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do
|
||||
E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
|
||||
E.on $ tutorial E.^. TutorialCourse E.==. course E.^. CourseId
|
||||
E.where_ $ tutor E.^. TutorUser E.==. E.val authId
|
||||
return (course E.^. CourseId, tutorial E.^. TutorialId)
|
||||
let
|
||||
resMap :: Map CourseId (Set TutorialId)
|
||||
resMap = Map.fromListWith Set.union [ (cid, Set.singleton tutid) | (E.Value cid, E.Value tutid) <- resList ]
|
||||
case route of
|
||||
CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialTutor) $ do
|
||||
Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity tutid _ <- MaybeT . lift . getBy $ UniqueTutorial cid tutn
|
||||
guard $ tutid `Set.member` fromMaybe Set.empty (resMap !? cid)
|
||||
return Authorized
|
||||
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedCourseTutor) $ do
|
||||
Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
guard $ cid `Set.member` Map.keysSet resMap
|
||||
return Authorized
|
||||
_ -> do
|
||||
guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedTutor)
|
||||
return Authorized
|
||||
tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
|
||||
CTutorialR tid ssh csh tutn TRegisterR -> maybeT (unauthorizedI MsgUnauthorizedTutorialTime) $ do
|
||||
now <- liftIO getCurrentTime
|
||||
course <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity tutId Tutorial{..} <- MaybeT . getBy $ UniqueTutorial course tutn
|
||||
registered <- case mAuthId of
|
||||
Just uid -> lift . existsBy $ UniqueTutorialParticipant tutId uid
|
||||
Nothing -> return False
|
||||
|
||||
if
|
||||
| not registered
|
||||
, maybe False (now >=) tutorialRegisterFrom
|
||||
, maybe True (now <=) tutorialRegisterTo
|
||||
-> return Authorized
|
||||
| registered
|
||||
, maybe True (now <=) tutorialDeregisterUntil
|
||||
-> return Authorized
|
||||
| otherwise
|
||||
-> mzero
|
||||
|
||||
CSheetR tid ssh csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do
|
||||
Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity _sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn
|
||||
@ -630,7 +684,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
|
||||
return Authorized
|
||||
|
||||
r -> $unsupportedAuthPredicate AuthTime r
|
||||
tagAccessPredicate AuthRegistered = APDB $ \mAuthId route _ -> case route of
|
||||
tagAccessPredicate AuthCourseRegistered = APDB $ \mAuthId route _ -> case route of
|
||||
CourseR tid ssh csh _ -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
[E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do
|
||||
@ -642,7 +696,34 @@ tagAccessPredicate AuthRegistered = APDB $ \mAuthId route _ -> case route of
|
||||
return (E.countRows :: E.SqlExpr (E.Value Int64))
|
||||
guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered)
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthRegistered r
|
||||
r -> $unsupportedAuthPredicate AuthCourseRegistered r
|
||||
tagAccessPredicate AuthTutorialRegistered = APDB $ \mAuthId route _ -> case route of
|
||||
CourseR tid ssh csh _ -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
[E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do
|
||||
E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
|
||||
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
|
||||
E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val authId
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
return (E.countRows :: E.SqlExpr (E.Value Int64))
|
||||
guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered)
|
||||
return Authorized
|
||||
CTutorialR tid ssh csh tutn _ -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
[E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do
|
||||
E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
|
||||
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
|
||||
E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val authId
|
||||
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.&&. tutorial E.^. TutorialName E.==. E.val tutn
|
||||
return (E.countRows :: E.SqlExpr (E.Value Int64))
|
||||
guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered)
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthTutorialRegistered r
|
||||
tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of
|
||||
CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do
|
||||
let authorizedIfExists f = do
|
||||
@ -683,16 +764,17 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
-- participant is a tutorial user
|
||||
authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialUser) -> do
|
||||
E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialUserTutorial
|
||||
E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial
|
||||
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
|
||||
E.where_ $ tutorialUser E.^. TutorialUserUser E.==. E.val participant
|
||||
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
|
||||
authorizedIfExists $ \(course `E.InnerJoin` tutorial) -> do
|
||||
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_ $ tutorial E.^. TutorialTutor E.==. E.val participant
|
||||
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
|
||||
@ -706,12 +788,33 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of
|
||||
unauthorizedI MsgUnauthorizedParticipant
|
||||
r -> $unsupportedAuthPredicate AuthParticipant r
|
||||
tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of
|
||||
CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgTutorialNoCapacity) $ do
|
||||
cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity tutId Tutorial{..} <- MaybeT . getBy $ UniqueTutorial cid tutn
|
||||
registered <- lift $ fromIntegral <$> count [ TutorialParticipantTutorial ==. tutId ]
|
||||
guard $ NTop tutorialCapacity > NTop (Just registered)
|
||||
return Authorized
|
||||
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do
|
||||
Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ]
|
||||
guard $ NTop courseCapacity > NTop (Just registered)
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthCapacity r
|
||||
tagAccessPredicate AuthRegisterGroup = APDB $ \mAuthId route _ -> case route of
|
||||
CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialRegisterGroup) $ do
|
||||
cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity _ Tutorial{..} <- MaybeT . getBy $ UniqueTutorial cid tutn
|
||||
case (tutorialRegGroup, mAuthId) of
|
||||
(Nothing, _) -> return Authorized
|
||||
(_, Nothing) -> return AuthenticationRequired
|
||||
(Just rGroup, Just uid) -> do
|
||||
[E.Value hasOther] <- lift . E.select . return . E.exists . E.from $ \(tutorial `E.InnerJoin` participant) -> do
|
||||
E.on $ tutorial E.^. TutorialId E.==. participant E.^. TutorialParticipantTutorial
|
||||
E.where_ $ participant E.^. TutorialParticipantUser E.==. E.val uid
|
||||
E.&&. tutorial E.^. TutorialRegGroup E.==. E.just (E.val rGroup)
|
||||
guard $ not hasOther
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthRegisterGroup r
|
||||
tagAccessPredicate AuthEmpty = APDB $ \_ route _ -> case route of
|
||||
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do
|
||||
-- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
@ -1265,10 +1368,17 @@ instance YesodBreadcrumbs UniWorX where
|
||||
breadcrumb (CourseR tid ssh csh SheetListR) = return ("Übungen" , Just $ CourseR tid ssh csh CShowR)
|
||||
breadcrumb (CourseR tid ssh csh SheetNewR ) = return ("Neu", Just $ CourseR tid ssh csh SheetListR)
|
||||
breadcrumb (CourseR tid ssh csh CCommR ) = return ("Kursmitteilung", Just $ CourseR tid ssh csh CShowR)
|
||||
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 (CTutorialR tid ssh csh tutn TUsersR) = return (CI.original tutn, Just $ CourseR tid ssh csh CTutorialListR)
|
||||
breadcrumb (CTutorialR tid ssh csh tutn TEditR) = return ("Bearbeiten", Just $ CTutorialR tid ssh csh tutn TUsersR)
|
||||
breadcrumb (CTutorialR tid ssh csh tutn TDeleteR) = return ("Löschen", Just $ CTutorialR tid ssh csh tutn TUsersR)
|
||||
breadcrumb (CTutorialR tid ssh csh tutn TCommR) = return ("Mitteilung", Just $ CTutorialR tid ssh csh tutn TUsersR)
|
||||
|
||||
breadcrumb (CSheetR tid ssh csh shn SShowR) = return (CI.original shn, Just $ CourseR tid ssh csh SheetListR)
|
||||
breadcrumb (CSheetR tid ssh csh shn SEditR) = return ("Edit", Just $ CSheetR tid ssh csh shn SShowR)
|
||||
breadcrumb (CSheetR tid ssh csh shn SDelR ) = return ("DELETE", Just $ CSheetR tid ssh csh shn SShowR)
|
||||
breadcrumb (CSheetR tid ssh csh shn SEditR) = return ("Bearbeiten", Just $ CSheetR tid ssh csh shn SShowR)
|
||||
breadcrumb (CSheetR tid ssh csh shn SDelR ) = return ("Löschen", Just $ CSheetR tid ssh csh shn SShowR)
|
||||
breadcrumb (CSheetR tid ssh csh shn SSubsR) = return ("Abgaben", Just $ CSheetR tid ssh csh shn SShowR)
|
||||
breadcrumb (CSheetR tid ssh csh shn SubmissionNewR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR)
|
||||
breadcrumb (CSheetR tid ssh csh shn SubmissionOwnR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR)
|
||||
@ -1635,6 +1745,14 @@ pageActions (CourseR tid ssh csh CShowR) =
|
||||
}
|
||||
] ++ pageActions (CourseR tid ssh csh SheetListR) ++
|
||||
[ MenuItem
|
||||
{ menuItemType = PageActionPrime
|
||||
, menuItemLabel = MsgMenuTutorialList
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = SomeRoute $ CourseR tid ssh csh CTutorialListR
|
||||
, menuItemModal = False
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
, MenuItem
|
||||
{ menuItemType = PageActionSecondary
|
||||
, menuItemLabel = MsgMenuCourseMembers
|
||||
, menuItemIcon = Just "user-graduate"
|
||||
@ -1736,6 +1854,44 @@ pageActions (CourseR tid ssh csh SheetListR) =
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
]
|
||||
pageActions (CourseR tid ssh csh CTutorialListR) =
|
||||
[ MenuItem
|
||||
{ menuItemType = PageActionPrime
|
||||
, menuItemLabel = MsgMenuTutorialNew
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = SomeRoute $ CourseR tid ssh csh CTutorialNewR
|
||||
, menuItemModal = False
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
]
|
||||
pageActions (CTutorialR tid ssh csh tutn TEditR) =
|
||||
[ MenuItem
|
||||
{ menuItemType = PageActionSecondary
|
||||
, menuItemLabel = MsgMenuTutorialDelete
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = SomeRoute $ CTutorialR tid ssh csh tutn TDeleteR
|
||||
, menuItemModal = False
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
]
|
||||
pageActions (CTutorialR tid ssh csh tutn TUsersR) =
|
||||
[ MenuItem
|
||||
{ menuItemType = PageActionPrime
|
||||
, menuItemLabel = MsgMenuTutorialEdit
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = SomeRoute $ CTutorialR tid ssh csh tutn TEditR
|
||||
, menuItemModal = False
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
, MenuItem
|
||||
{ menuItemType = PageActionSecondary
|
||||
, menuItemLabel = MsgMenuTutorialDelete
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = SomeRoute $ CTutorialR tid ssh csh tutn TDeleteR
|
||||
, menuItemModal = False
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
]
|
||||
pageActions (CSheetR tid ssh csh shn SShowR) =
|
||||
[ MenuItem
|
||||
{ menuItemType = PageActionPrime
|
||||
|
||||
@ -165,7 +165,7 @@ postAdminTestR = do
|
||||
|
||||
-- | Make a form for adding a point/line/plane/hyperplane/... (in this case: cell)
|
||||
--
|
||||
-- This /needs/ to replace all occurances of @mreq@ with @mpreq@ (no fields should be /actually/ required)
|
||||
-- This /needs/ to replace all occurences of @mreq@ with @mpreq@ (no fields should be /actually/ required)
|
||||
mkAddForm :: ListPosition -- ^ Approximate position of the add-widget
|
||||
-> Natural -- ^ Dimension Index, outermost dimension ist 0 i.e. if dimension is 3 hyperplane-adders get passed 0, planes get passed 1, lines get 2, and points get 3
|
||||
-> (Text -> Text) -- ^ Nudge deterministic field ids so they're unique
|
||||
|
||||
@ -128,7 +128,7 @@ colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
|
||||
return $ CSubmissionR tid ssh csh shn cid SubShowR
|
||||
in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|])
|
||||
|
||||
colSelect :: forall act h. (Monoid act, Headedness h) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary))
|
||||
colSelect :: forall act h. (Semigroup act, Monoid act, Headedness h) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary))
|
||||
colSelect = dbSelect (_1 . applying _2) id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId
|
||||
|
||||
colSubmittors :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
|
||||
@ -9,6 +9,7 @@ import Utils.Form
|
||||
-- import Utils.DB
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Course
|
||||
import Handler.Utils.Tutorial
|
||||
import Handler.Utils.Communication
|
||||
import Handler.Utils.Form.MassInput
|
||||
import Handler.Utils.Delete
|
||||
@ -24,8 +25,6 @@ import qualified Data.CaseInsensitive as CI
|
||||
import Data.Function ((&))
|
||||
-- import Yesod.Form.Bootstrap3
|
||||
|
||||
import Data.Monoid (Last(..))
|
||||
|
||||
import Data.Maybe (fromJust)
|
||||
import qualified Data.Set as Set
|
||||
import Data.Map ((!))
|
||||
@ -275,7 +274,7 @@ getTermCourseListR tid = do
|
||||
getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCShowR tid ssh csh = do
|
||||
mbAid <- maybeAuthId
|
||||
(course,schoolName,participants,registration,defSFid,lecturers,assistants) <- runDB . maybeT notFound $ do
|
||||
(cid,course,schoolName,participants,registration,defSFid,lecturers,assistants,tutors,correctors) <- 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
|
||||
@ -301,7 +300,18 @@ getCShowR tid ssh csh = do
|
||||
partStaff (CourseLecturer ,name,surn,mail) = Right (name,surn,mail)
|
||||
partStaff (_courseAssistant,name,surn,mail) = Left (name,surn,mail)
|
||||
(assistants,lecturers) = partitionWith partStaff $ map $(unValueN 4) staff
|
||||
return (course,schoolName,participants,registration,entityKey <$> defSFid,lecturers,assistants)
|
||||
tutors <- fmap (map $(unValueN 3)) . lift . E.select $ E.from $ \(tutorial `E.InnerJoin` tutor `E.InnerJoin` user) -> E.distinctOnOrderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName, E.asc $ user E.^. UserEmail ] $ do
|
||||
E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
|
||||
E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
|
||||
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
|
||||
return ( user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname )
|
||||
correctors <- fmap (map $(unValueN 3)) . lift . E.select $ E.from $ \(sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> E.distinctOnOrderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName, E.asc $ user E.^. UserEmail ] $ do
|
||||
E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
|
||||
E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
|
||||
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
||||
E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ]
|
||||
return ( user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname )
|
||||
return (cid,course,schoolName,participants,registration,entityKey <$> defSFid,lecturers,assistants,tutors,correctors)
|
||||
|
||||
mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course
|
||||
mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course
|
||||
@ -314,6 +324,58 @@ getCShowR tid ssh csh = do
|
||||
, formSubmit = FormNoSubmit
|
||||
}
|
||||
registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True
|
||||
|
||||
let
|
||||
tutorialDBTable = DBTable{..}
|
||||
where
|
||||
dbtSQLQuery tutorial = do
|
||||
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
|
||||
return tutorial
|
||||
dbtRowKey = (E.^. TutorialId)
|
||||
dbtProj = return
|
||||
dbtColonnade = dbColonnade $ mconcat
|
||||
[ sortable (Just "type") (i18nCell MsgTutorialType) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> textCell $ CI.original tutorialType
|
||||
, sortable (Just "name") (i18nCell MsgTutorialName) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> indicatorCell <> textCell (CI.original tutorialName)
|
||||
, sortable (Just "room") (i18nCell MsgTutorialRoom) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> textCell tutorialRoom
|
||||
, sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> occurencesCell tutorialTime
|
||||
, sortable (Just "register-from") (i18nCell MsgTutorialRegisterFrom) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> maybeDateTimeCell tutorialRegisterFrom
|
||||
, sortable (Just "register-to") (i18nCell MsgTutorialRegisterTo) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> maybeDateTimeCell tutorialRegisterTo
|
||||
, sortable (Just "deregister-until") (i18nCell MsgTutorialDeregisterUntil) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> maybeDateTimeCell tutorialDeregisterUntil
|
||||
, sortable Nothing mempty $ \DBRow{ dbrOutput = Entity tutId Tutorial{..} } -> sqlCell $ do
|
||||
mayRegister <- (== Authorized) <$> evalAccessDB (CTutorialR tid ssh csh tutorialName TRegisterR) True
|
||||
isRegistered <- case mbAid of
|
||||
Nothing -> return False
|
||||
Just uid -> existsBy $ UniqueTutorialParticipant tutId uid
|
||||
if
|
||||
| mayRegister -> do
|
||||
(tutRegisterForm, tutRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
|
||||
return $ wrapForm tutRegisterForm def
|
||||
{ formAction = Just . SomeRoute $ CTutorialR tid ssh csh tutorialName TRegisterR
|
||||
, formEncoding = tutRegisterEnctype
|
||||
, formSubmit = FormNoSubmit
|
||||
}
|
||||
| isRegistered -> return [whamlet|_{MsgTutorialRegistered}|]
|
||||
| otherwise -> return mempty
|
||||
]
|
||||
dbtSorting = Map.fromList
|
||||
[ ("type", SortColumn $ \tutorial -> tutorial E.^. TutorialType )
|
||||
, ("name", SortColumn $ \tutorial -> tutorial E.^. TutorialName )
|
||||
, ("room", SortColumn $ \tutorial -> tutorial E.^. TutorialRoom )
|
||||
, ("register-from", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterFrom )
|
||||
, ("register-to", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterTo )
|
||||
, ("deregister-until", SortColumn $ \tutorial -> tutorial E.^. TutorialDeregisterUntil )
|
||||
]
|
||||
dbtFilter = Map.empty
|
||||
dbtFilterUI = const mempty
|
||||
dbtStyle = def
|
||||
dbtParams = def
|
||||
dbtIdent :: Text
|
||||
dbtIdent = "tutorials"
|
||||
|
||||
tutorialDBTableValidator = def
|
||||
& defaultSorting [SortAscBy "type", SortAscBy "name"]
|
||||
(Any hasTutorials, tutorialTable) <- runDB $ dbTable tutorialDBTableValidator tutorialDBTable
|
||||
|
||||
siteLayout (toWgt $ courseName course) $ do
|
||||
setTitleI $ prependCourseTitle tid ssh csh (""::Text)
|
||||
$(widgetFile "course")
|
||||
@ -870,13 +932,28 @@ instance Finite CourseUserAction
|
||||
nullaryPathPiece ''CourseUserAction $ camelToPathPiece' 2
|
||||
embedRenderMessage ''UniWorX ''CourseUserAction id
|
||||
|
||||
makeCourseUserTable :: CourseId -> _ -> _ -> DB (FormResult (CourseUserAction, Set UserId), Widget)
|
||||
makeCourseUserTable cid colChoices psValidator = do
|
||||
data TutorialUserAction = TutorialUserSendMail | TutorialUserDeregister
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
||||
|
||||
instance Universe TutorialUserAction
|
||||
instance Finite TutorialUserAction
|
||||
nullaryPathPiece ''TutorialUserAction $ camelToPathPiece' 2
|
||||
embedRenderMessage ''UniWorX ''TutorialUserAction id
|
||||
|
||||
makeCourseUserTable :: forall h act.
|
||||
( Functor h, ToSortable h
|
||||
, RenderMessage UniWorX act, Eq act, PathPiece act, Finite act)
|
||||
=> CourseId
|
||||
-> (UserTableExpr -> E.SqlExpr (E.Value Bool))
|
||||
-> Colonnade h UserTableData (DBCell (MForm Handler) (FormResult (First act, DBFormResult UserId Bool UserTableData)))
|
||||
-> PSValidator (MForm Handler) (FormResult (First act, DBFormResult UserId Bool UserTableData))
|
||||
-> DB (FormResult (act, Set UserId), Widget)
|
||||
makeCourseUserTable cid restrict colChoices psValidator = do
|
||||
Just currentRoute <- liftHandlerT getCurrentRoute
|
||||
-- -- psValidator has default sorting and filtering
|
||||
let dbtIdent = "courseUsers" :: Text
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
dbtSQLQuery = userTableQuery cid
|
||||
dbtSQLQuery q = userTableQuery cid q <* E.where_ (restrict q)
|
||||
dbtRowKey = queryUser >>> (E.^. UserId)
|
||||
dbtProj = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms))
|
||||
dbtColonnade = colChoices
|
||||
@ -917,14 +994,22 @@ makeCourseUserTable cid colChoices psValidator = do
|
||||
, E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey)
|
||||
] )
|
||||
, ("semesternr" , FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
|
||||
, ("tutorial" , FilterColumn $ E.mkExistsFilter $ \row criterion ->
|
||||
E.from $ \(tutorial `E.InnerJoin` tutorialParticipant) -> do
|
||||
E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
|
||||
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
|
||||
E.&&. E.hasInfix (tutorial E.^. TutorialName) criterion
|
||||
E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. (queryUser row) E.^. UserId
|
||||
)
|
||||
-- , ("course-registration", error "TODO") -- TODO
|
||||
-- , ("course-user-note", error "TODO") -- TODO
|
||||
]
|
||||
dbtFilterUI mPrev = mconcat
|
||||
[ fltrUserNameEmailUI mPrev
|
||||
, fltrUserMatriclenrUI mPrev
|
||||
, prismAForm (singletonFilter "degree") mPrev $ aopt (searchField False) (fslI MsgStudyFeatureDegree)
|
||||
, prismAForm (singletonFilter "field") mPrev $ aopt (searchField False) (fslI MsgCourseStudyFeature)
|
||||
, prismAForm (singletonFilter "degree") mPrev $ aopt (searchField False) (fslI MsgStudyFeatureDegree)
|
||||
, prismAForm (singletonFilter "field") mPrev $ aopt (searchField False) (fslI MsgCourseStudyFeature)
|
||||
, prismAForm (singletonFilter "tutorial") mPrev $ aopt (searchField False) (fslI MsgCourseTutorial)
|
||||
]
|
||||
dbtParams = DBParamsForm
|
||||
{ dbParamsFormMethod = POST
|
||||
@ -942,7 +1027,7 @@ makeCourseUserTable cid colChoices psValidator = do
|
||||
}
|
||||
over _1 postprocess <$> dbTable psValidator DBTable{..}
|
||||
where
|
||||
postprocess :: FormResult (First CourseUserAction, DBFormResult UserId Bool UserTableData) -> FormResult (CourseUserAction, Set UserId)
|
||||
postprocess :: FormResult (First act, DBFormResult UserId Bool UserTableData) -> FormResult (act, Set UserId)
|
||||
postprocess inp = do
|
||||
(First (Just act), usrMap) <- inp
|
||||
let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
|
||||
@ -966,7 +1051,7 @@ postCUsersR tid ssh csh = do
|
||||
psValidator = def & defaultSortingByName
|
||||
ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
numParticipants <- count [CourseParticipantCourse ==. cid]
|
||||
table <- makeCourseUserTable cid colChoices psValidator
|
||||
table <- makeCourseUserTable cid (const $ E.true) colChoices psValidator
|
||||
return (ent, numParticipants, table)
|
||||
formResult participantRes $ \case
|
||||
(CourseUserSendMail, selectedUsers) -> do
|
||||
@ -986,6 +1071,49 @@ postCUsersR tid ssh csh = do
|
||||
$(widgetFile "course-participants")
|
||||
|
||||
|
||||
|
||||
getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
|
||||
getTUsersR = postTUsersR
|
||||
postTUsersR tid ssh csh tutn = do
|
||||
(Entity tutid Tutorial{..}, (participantRes, participantTable)) <- runDB $ do
|
||||
tut@(Entity tutid _) <- fetchTutorial tid ssh csh tutn
|
||||
let colChoices = mconcat
|
||||
[ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
|
||||
, colUserName
|
||||
, colUserEmail
|
||||
, colUserMatriclenr
|
||||
, colUserDegreeShort
|
||||
, colUserField
|
||||
, colUserSemester
|
||||
]
|
||||
psValidator = def
|
||||
& defaultSortingByName
|
||||
& restrictSorting (\name _ -> none (== name) ["note"]) -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
|
||||
isInTut q = E.exists . E.from $ \tutorialParticipant -> do
|
||||
E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. (queryUser q) E.^. UserId
|
||||
E.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid
|
||||
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
table <- makeCourseUserTable cid isInTut colChoices psValidator
|
||||
return (tut, table)
|
||||
|
||||
formResult participantRes $ \case
|
||||
(TutorialUserSendMail, selectedUsers) -> do
|
||||
cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser]
|
||||
redirect (CTutorialR tid ssh csh tutn TCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids])
|
||||
(TutorialUserDeregister,selectedUsers) -> do
|
||||
nrDel <- runDB $ deleteWhereCount
|
||||
[ TutorialParticipantTutorial ==. tutid
|
||||
, TutorialParticipantUser <-. Set.toList selectedUsers
|
||||
]
|
||||
addMessageI Success $ MsgTutorialUsersDeregistered nrDel
|
||||
redirect $ CTutorialR tid ssh csh tutn TUsersR
|
||||
|
||||
let heading = prependCourseTitle tid ssh csh $ CI.original tutorialName
|
||||
siteLayoutMsg heading $ do
|
||||
setTitleI heading
|
||||
$(widgetFile "tutorial-participants")
|
||||
|
||||
|
||||
getCUserR, postCUserR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDUser -> Handler Html
|
||||
getCUserR = postCUserR
|
||||
postCUserR tid ssh csh uCId = do
|
||||
@ -1125,6 +1253,13 @@ postCCommR tid ssh csh = do
|
||||
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
||||
return user
|
||||
)
|
||||
, ( RGCourseTutors
|
||||
, E.from $ \user -> do
|
||||
E.where_ $ E.exists $ E.from $ \(tutorial `E.InnerJoin` tutor) -> do
|
||||
E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial
|
||||
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
|
||||
return user
|
||||
)
|
||||
]
|
||||
, crRecipientAuth = Just $ \uid -> do
|
||||
cID <- encrypt uid
|
||||
|
||||
376
src/Handler/Tutorial.hs
Normal file
376
src/Handler/Tutorial.hs
Normal file
@ -0,0 +1,376 @@
|
||||
module Handler.Tutorial where
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Tutorial
|
||||
import Handler.Utils.Table.Cells
|
||||
import Handler.Utils.Delete
|
||||
import Handler.Utils.Communication
|
||||
import Handler.Utils.Form.MassInput
|
||||
import Handler.Utils.Form.Occurences
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import Database.Esqueleto.Utils.TH
|
||||
|
||||
import Data.Map ((!))
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
|
||||
getCTutorialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCTutorialListR tid ssh csh = do
|
||||
Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
|
||||
let
|
||||
tutorialDBTable = DBTable{..}
|
||||
where
|
||||
dbtSQLQuery tutorial = do
|
||||
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
|
||||
let participants = E.sub_select . E.from $ \tutorialParticipant -> do
|
||||
E.where_ $ tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId
|
||||
return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int))
|
||||
return (tutorial, participants)
|
||||
dbtRowKey = (E.^. TutorialId)
|
||||
dbtProj = return . over (_dbrOutput . _2) E.unValue
|
||||
dbtColonnade = dbColonnade $ mconcat
|
||||
[ sortable (Just "type") (i18nCell MsgTutorialType) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> textCell $ CI.original tutorialType
|
||||
, sortable (Just "name") (i18nCell MsgTutorialName) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> textCell $ CI.original tutorialName
|
||||
, sortable Nothing (i18nCell MsgTutorialTutors) $ \DBRow{ dbrOutput = (Entity tutid _, _) } -> sqlCell $ do
|
||||
tutors <- fmap (map $(unValueN 3)) . E.select . E.from $ \(tutor `E.InnerJoin` user) -> do
|
||||
E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
|
||||
E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
|
||||
return (user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname)
|
||||
return [whamlet|
|
||||
<ul .list--iconless .list--inline .list--comma-separated>
|
||||
$forall tutor <- tutors
|
||||
<li>
|
||||
^{nameEmailWidget' tutor}
|
||||
|]
|
||||
, sortable (Just "participants") (i18nCell MsgTutorialParticipants) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, n) } -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) . toWidget $ tshow n
|
||||
, sortable (Just "capacity") (i18nCell MsgTutorialCapacity) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybe mempty (textCell . tshow) tutorialCapacity
|
||||
, sortable (Just "room") (i18nCell MsgTutorialRoom) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> textCell tutorialRoom
|
||||
, sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> occurencesCell tutorialTime
|
||||
, sortable (Just "reg-group") (i18nCell MsgTutorialRegGroup) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybe mempty (textCell . CI.original) tutorialRegGroup
|
||||
, sortable (Just "register-from") (i18nCell MsgTutorialRegisterFrom) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybeDateTimeCell tutorialRegisterFrom
|
||||
, sortable (Just "register-to") (i18nCell MsgTutorialRegisterTo) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybeDateTimeCell tutorialRegisterTo
|
||||
, sortable (Just "deregister-until") (i18nCell MsgTutorialDeregisterUntil) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybeDateTimeCell tutorialDeregisterUntil
|
||||
, sortable Nothing mempty $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> cell $ do
|
||||
linkButton [whamlet|_{MsgTutorialEdit}|] [BCIsButton] . SomeRoute $ CTutorialR tid ssh csh tutorialName TEditR
|
||||
linkButton [whamlet|_{MsgTutorialDelete}|] [BCIsButton, BCDanger] . SomeRoute $ CTutorialR tid ssh csh tutorialName TDeleteR
|
||||
]
|
||||
dbtSorting = Map.fromList
|
||||
[ ("type", SortColumn $ \tutorial -> tutorial E.^. TutorialType )
|
||||
, ("name", SortColumn $ \tutorial -> tutorial E.^. TutorialName )
|
||||
, ("participants", SortColumn $ \tutorial -> E.sub_select . E.from $ \tutorialParticipant -> do
|
||||
E.where_ $ tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId
|
||||
return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int))
|
||||
)
|
||||
, ("capacity", SortColumn $ \tutorial -> tutorial E.^. TutorialCapacity )
|
||||
, ("room", SortColumn $ \tutorial -> tutorial E.^. TutorialRoom )
|
||||
, ("reg-grep", SortColumn $ \tutorial -> tutorial E.^. TutorialRegGroup )
|
||||
, ("register-from", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterFrom )
|
||||
, ("register-to", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterTo )
|
||||
, ("deregister-until", SortColumn $ \tutorial -> tutorial E.^. TutorialDeregisterUntil )
|
||||
]
|
||||
dbtFilter = Map.empty
|
||||
dbtFilterUI = const mempty
|
||||
dbtStyle = def
|
||||
dbtParams = def
|
||||
dbtIdent :: Text
|
||||
dbtIdent = "tutorials"
|
||||
|
||||
tutorialDBTableValidator = def
|
||||
& defaultSorting [SortAscBy "type", SortAscBy "name"]
|
||||
((), tutorialTable) <- runDB $ dbTable tutorialDBTableValidator tutorialDBTable
|
||||
|
||||
siteLayoutMsg (prependCourseTitle tid ssh csh MsgTutorialsHeading) $ do
|
||||
setTitleI $ prependCourseTitle tid ssh csh MsgTutorialsHeading
|
||||
$(widgetFile "tutorial-list")
|
||||
|
||||
postTRegisterR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler ()
|
||||
postTRegisterR tid ssh csh tutn = do
|
||||
uid <- requireAuthId
|
||||
|
||||
Entity tutid Tutorial{..} <- runDB $ fetchTutorial tid ssh csh tutn
|
||||
|
||||
((btnResult, _), _) <- runFormPost buttonForm
|
||||
|
||||
formResult btnResult $ \case
|
||||
BtnRegister -> do
|
||||
runDB . void . insert $ TutorialParticipant tutid uid
|
||||
addMessageI Success $ MsgTutorialRegisteredSuccess tutorialName
|
||||
redirect $ CourseR tid ssh csh CShowR
|
||||
BtnDeregister -> do
|
||||
runDB . deleteBy $ UniqueTutorialParticipant tutid uid
|
||||
addMessageI Success $ MsgTutorialDeregisteredSuccess tutorialName
|
||||
redirect $ CourseR tid ssh csh CShowR
|
||||
|
||||
invalidArgs ["Register/Deregister button required"]
|
||||
|
||||
getTDeleteR, postTDeleteR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
|
||||
getTDeleteR = postTDeleteR
|
||||
postTDeleteR tid ssh csh tutn = do
|
||||
tutid <- runDB $ fetchTutorialId tid ssh csh tutn
|
||||
deleteR DeleteRoute
|
||||
{ drRecords = Set.singleton tutid
|
||||
, drUnjoin = \(_ `E.InnerJoin` tutorial) -> tutorial
|
||||
, drGetInfo = \(course `E.InnerJoin` tutorial) -> do
|
||||
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
|
||||
let participants = E.sub_select . E.from $ \participant -> do
|
||||
E.where_ $ participant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId
|
||||
return E.countRows
|
||||
return (course, tutorial, participants :: E.SqlExpr (E.Value Int))
|
||||
, drRenderRecord = \(Entity _ Course{..}, Entity _ Tutorial{..}, E.Value ps) ->
|
||||
return [whamlet|_{prependCourseTitle courseTerm courseSchool courseShorthand (CI.original tutorialName)} (#{tshow ps} _{MsgParticipantsN ps})|]
|
||||
, drRecordConfirmString = \(Entity _ Course{..}, Entity _ Tutorial{..}, E.Value ps) ->
|
||||
return [st|#{termToText (unTermKey courseTerm)}/#{unSchoolKey courseSchool}/#{courseShorthand}/#{tutorialName}+#{tshow ps}|]
|
||||
, drCaption = SomeMessage MsgTutorialDeleteQuestion
|
||||
, drSuccessMessage = SomeMessage MsgTutorialDeleted
|
||||
, drAbort = SomeRoute $ CTutorialR tid ssh csh tutn TUsersR
|
||||
, drSuccess = SomeRoute $ CourseR tid ssh csh CTutorialListR
|
||||
}
|
||||
|
||||
getTCommR, postTCommR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
|
||||
getTCommR = postTCommR
|
||||
postTCommR tid ssh csh tutn = do
|
||||
jSender <- requireAuthId
|
||||
(cid, tutid) <- runDB $ fetchCourseIdTutorialId tid ssh csh tutn
|
||||
|
||||
commR CommunicationRoute
|
||||
{ crHeading = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommTutorialHeading
|
||||
, crUltDest = SomeRoute $ CTutorialR tid ssh csh tutn TCommR
|
||||
, crJobs = \Communication{..} -> do
|
||||
let jSubject = cSubject
|
||||
jMailContent = cBody
|
||||
jCourse = cid
|
||||
allRecipients = Set.toList $ Set.insert (Right jSender) cRecipients
|
||||
jMailObjectUUID <- liftIO getRandom
|
||||
jAllRecipientAddresses <- lift . fmap Set.fromList . forM allRecipients $ \case
|
||||
Left email -> return . Address Nothing $ CI.original email
|
||||
Right rid -> userAddress <$> getJust rid
|
||||
forM_ allRecipients $ \jRecipientEmail ->
|
||||
yield JobSendCourseCommunication{..}
|
||||
, crRecipients = Map.fromList
|
||||
[ ( RGTutorialParticipants
|
||||
, E.from $ \(user `E.InnerJoin` participant) -> do
|
||||
E.on $ user E.^. UserId E.==. participant E.^. TutorialParticipantUser
|
||||
E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid
|
||||
return user
|
||||
)
|
||||
, ( RGCourseLecturers
|
||||
, E.from $ \(user `E.InnerJoin` lecturer) -> do
|
||||
E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
|
||||
E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
|
||||
return user
|
||||
)
|
||||
, ( RGCourseCorrectors
|
||||
, E.from $ \user -> do
|
||||
E.where_ $ E.exists $ E.from $ \(sheet `E.InnerJoin` corrector) -> do
|
||||
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
|
||||
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
||||
return user
|
||||
)
|
||||
, ( RGCourseTutors
|
||||
, E.from $ \user -> do
|
||||
E.where_ $ E.exists $ E.from $ \(tutorial `E.InnerJoin` tutor) -> do
|
||||
E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial
|
||||
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
|
||||
return user
|
||||
)
|
||||
]
|
||||
, crRecipientAuth = Just $ \uid -> do
|
||||
cID <- encrypt uid
|
||||
evalAccessDB (CourseR tid ssh csh $ CUserR cID) False
|
||||
}
|
||||
|
||||
|
||||
data TutorialForm = TutorialForm
|
||||
{ tfName :: TutorialName
|
||||
, tfType :: CI Text
|
||||
, tfCapacity :: Maybe Int
|
||||
, tfRoom :: Text
|
||||
, tfTime :: Occurences
|
||||
, tfRegGroup :: Maybe (CI Text)
|
||||
, tfRegisterFrom :: Maybe UTCTime
|
||||
, tfRegisterTo :: Maybe UTCTime
|
||||
, tfDeregisterUntil :: Maybe UTCTime
|
||||
, tfTutors :: Set UserId -- awaiting feat/generic-invitations
|
||||
}
|
||||
|
||||
tutorialForm :: CourseId -> Maybe TutorialForm -> Form TutorialForm
|
||||
tutorialForm cid template html = do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
Just cRoute <- getCurrentRoute
|
||||
uid <- liftHandlerT requireAuthId
|
||||
|
||||
let
|
||||
tutorForm = Set.fromList <$> massInputAccumA miAdd' miCell' (\p -> Just . SomeRoute $ cRoute :#: p) miLayout' (fslI MsgTutorialTutors) True (Set.toList . tfTutors <$> template)
|
||||
where
|
||||
miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([UserId] -> FormResult [UserId])
|
||||
miAdd' nudge submitView csrf = do
|
||||
(addRes, addView) <- mpreq (multiUserField False . Just $ tutUserSuggestions uid) ("" & addName (nudge "email")) Nothing
|
||||
let
|
||||
addRes'
|
||||
| unresolved <- toListOf (_FormSuccess . folded . _Left) addRes
|
||||
, (fUnresolved : _) <- unresolved
|
||||
= FormFailure [mr $ MsgEMailUnknown fUnresolved]
|
||||
| otherwise
|
||||
= addRes <&> \newDat oldDat -> if
|
||||
| (_ : _) <- Set.toList $ setOf (folded . _Right) newDat `Set.intersection` Set.fromList oldDat
|
||||
-> FormFailure [mr MsgTutorialTutorAlreadyAdded]
|
||||
| otherwise
|
||||
-> FormSuccess $ toListOf (folded . _Right) newDat
|
||||
return (addRes', $(widgetFile "tutorial/tutorMassInput/add"))
|
||||
|
||||
|
||||
miCell' :: UserId -> Widget
|
||||
miCell' userId = do
|
||||
User{..} <- liftHandlerT . runDB $ get404 userId
|
||||
$(widgetFile "tutorial/tutorMassInput/cellKnown")
|
||||
|
||||
miLayout' :: MassInputLayout ListLength UserId ()
|
||||
miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "tutorial/tutorMassInput/layout")
|
||||
|
||||
flip (renderAForm FormStandard) html $ TutorialForm
|
||||
<$> areq ciField (fslpI MsgTutorialName (mr MsgTutorialName) & setTooltip MsgTutorialNameTip) (tfName <$> template)
|
||||
<*> areq (ciField & addDatalist tutTypeDatalist) (fslpI MsgTutorialType $ mr MsgTutorialType) (tfType <$> template)
|
||||
<*> aopt (natFieldI MsgTutorialCapacityNonPositive) (fslpI MsgTutorialCapacity (mr MsgTutorialCapacity) & setTooltip MsgTutorialCapacityTip) (tfCapacity <$> template)
|
||||
<*> areq textField (fslpI MsgTutorialRoom $ mr MsgTutorialRoomPlaceholder) (tfRoom <$> template)
|
||||
<*> occurencesAForm (tfTime <$> template)
|
||||
<*> aopt ciField (fslI MsgTutorialRegGroup & setTooltip MsgTutorialRegGroupTip) ((tfRegGroup <$> template) <|> Just (Just "tutorial"))
|
||||
<*> aopt utcTimeField (fslpI MsgRegisterFrom (mr MsgDate)
|
||||
& setTooltip MsgCourseRegisterFromTip
|
||||
) (tfRegisterFrom <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgRegisterTo (mr MsgDate)
|
||||
& setTooltip MsgCourseRegisterToTip
|
||||
) (tfRegisterTo <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgDeRegUntil (mr MsgDate)
|
||||
& setTooltip MsgCourseDeregisterUntilTip
|
||||
) (tfDeregisterUntil <$> template)
|
||||
<*> tutorForm
|
||||
where
|
||||
tutTypeDatalist :: WidgetT UniWorX IO (Set (CI Text))
|
||||
tutTypeDatalist = liftHandlerT . runDB $
|
||||
fmap (setOf $ folded . _Value) . E.select . E.from $ \tutorial -> do
|
||||
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
|
||||
return $ tutorial E.^. TutorialType
|
||||
|
||||
tutUserSuggestions :: UserId -> E.SqlQuery (E.SqlExpr (Entity User))
|
||||
tutUserSuggestions uid = E.from $ \(lecturer `E.InnerJoin` course `E.InnerJoin` tutorial `E.InnerJoin` tutor `E.InnerJoin` tutorUser) -> do
|
||||
E.on $ tutorUser E.^. UserId E.==. tutor E.^. TutorUser
|
||||
E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
|
||||
E.on $ tutorial E.^. TutorialCourse E.==. course E.^. CourseId
|
||||
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
|
||||
E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
|
||||
return tutorUser
|
||||
|
||||
|
||||
getCTutorialNewR, postCTutorialNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCTutorialNewR = postCTutorialNewR
|
||||
postCTutorialNewR tid ssh csh = do
|
||||
Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
|
||||
((newTutResult, newTutWidget), newTutEnctype) <- runFormPost $ tutorialForm cid Nothing
|
||||
|
||||
formResult newTutResult $ \TutorialForm{..} -> do
|
||||
insertRes <- runDB $ do
|
||||
insertRes <- insertUnique Tutorial
|
||||
{ tutorialName = tfName
|
||||
, tutorialCourse = cid
|
||||
, tutorialType = tfType
|
||||
, tutorialCapacity = tfCapacity
|
||||
, tutorialRoom = tfRoom
|
||||
, tutorialTime = tfTime
|
||||
, tutorialRegGroup = tfRegGroup
|
||||
, tutorialRegisterFrom = tfRegisterFrom
|
||||
, tutorialRegisterTo = tfRegisterTo
|
||||
, tutorialDeregisterUntil = tfDeregisterUntil
|
||||
}
|
||||
forM_ tfTutors $ \tutor -> case insertRes of
|
||||
Just tutid -> void . insert $ Tutor tutid tutor
|
||||
_other -> return ()
|
||||
return insertRes
|
||||
case insertRes of
|
||||
Nothing -> addMessageI Error $ MsgTutorialNameTaken tfName
|
||||
Just _ -> do
|
||||
addMessageI Success $ MsgTutorialCreated tfName
|
||||
redirect $ CourseR tid ssh csh CTutorialListR
|
||||
|
||||
let heading = prependCourseTitle tid ssh csh MsgTutorialNew
|
||||
|
||||
siteLayoutMsg heading $ do
|
||||
setTitleI heading
|
||||
let
|
||||
newTutForm = wrapForm newTutWidget def
|
||||
{ formMethod = POST
|
||||
, formAction = Just . SomeRoute $ CourseR tid ssh csh CTutorialNewR
|
||||
, formEncoding = newTutEnctype
|
||||
}
|
||||
$(widgetFile "tutorial-new")
|
||||
|
||||
getTEditR, postTEditR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
|
||||
getTEditR = postTEditR
|
||||
postTEditR tid ssh csh tutn = do
|
||||
(cid, tutid, template) <- runDB $ do
|
||||
(cid, Entity tutid Tutorial{..}) <- fetchCourseIdTutorial tid ssh csh tutn
|
||||
|
||||
tutorIds <- fmap (map E.unValue) . E.select . E.from $ \tutor -> do
|
||||
E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
|
||||
return $ tutor E.^. TutorUser
|
||||
|
||||
let
|
||||
template = TutorialForm
|
||||
{ tfName = tutorialName
|
||||
, tfType = tutorialType
|
||||
, tfCapacity = tutorialCapacity
|
||||
, tfRoom = tutorialRoom
|
||||
, tfTime = tutorialTime
|
||||
, tfRegGroup = tutorialRegGroup
|
||||
, tfRegisterFrom = tutorialRegisterFrom
|
||||
, tfRegisterTo = tutorialRegisterTo
|
||||
, tfDeregisterUntil = tutorialDeregisterUntil
|
||||
, tfTutors = Set.fromList tutorIds
|
||||
}
|
||||
|
||||
return (cid, tutid, template)
|
||||
|
||||
((newTutResult, newTutWidget), newTutEnctype) <- runFormPost . tutorialForm cid $ Just template
|
||||
|
||||
formResult newTutResult $ \TutorialForm{..} -> do
|
||||
insertRes <- runDB $ do
|
||||
insertRes <- myReplaceUnique tutid Tutorial
|
||||
{ tutorialName = tfName
|
||||
, tutorialCourse = cid
|
||||
, tutorialType = tfType
|
||||
, tutorialCapacity = tfCapacity
|
||||
, tutorialRoom = tfRoom
|
||||
, tutorialTime = tfTime
|
||||
, tutorialRegGroup = tfRegGroup
|
||||
, tutorialRegisterFrom = tfRegisterFrom
|
||||
, tutorialRegisterTo = tfRegisterTo
|
||||
, tutorialDeregisterUntil = tfDeregisterUntil
|
||||
}
|
||||
deleteWhere [ TutorTutorial ==. tutid ]
|
||||
forM_ tfTutors $ void . insert . Tutor tutid
|
||||
return insertRes
|
||||
case insertRes of
|
||||
Just _ -> addMessageI Error $ MsgTutorialNameTaken tfName
|
||||
Nothing -> do
|
||||
addMessageI Success $ MsgTutorialCreated tfName
|
||||
redirect $ CourseR tid ssh csh CTutorialListR
|
||||
|
||||
let heading = prependCourseTitle tid ssh csh . MsgTutorialEditHeading $ tfName template
|
||||
|
||||
siteLayoutMsg heading $ do
|
||||
setTitleI heading
|
||||
let
|
||||
newTutForm = wrapForm newTutWidget def
|
||||
{ formMethod = POST
|
||||
, formAction = Just . SomeRoute $ CTutorialR tid ssh csh tutn TEditR
|
||||
, formEncoding = newTutEnctype
|
||||
}
|
||||
$(widgetFile "tutorial-edit")
|
||||
@ -25,7 +25,8 @@ import Data.Aeson.TH
|
||||
import Data.Aeson.Types (ToJSONKey(..), FromJSONKey(..), toJSONKeyText, FromJSONKeyFunction(..))
|
||||
|
||||
|
||||
data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrectors
|
||||
data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrectors | RGCourseTutors
|
||||
| RGTutorialParticipants
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
||||
|
||||
instance Universe RecipientGroup
|
||||
|
||||
@ -25,6 +25,8 @@ import qualified Data.Time.Format as Time
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Data.Time.Clock.System (systemEpochDay)
|
||||
|
||||
|
||||
utcToLocalTime :: UTCTime -> LocalTime
|
||||
utcToLocalTime = TZ.utcToLocalTimeTZ appTZ
|
||||
@ -62,6 +64,9 @@ instance HasLocalTime Day where
|
||||
instance HasLocalTime UTCTime where
|
||||
toLocalTime = utcToLocalTime
|
||||
|
||||
instance HasLocalTime TimeOfDay where
|
||||
toLocalTime = LocalTime systemEpochDay
|
||||
|
||||
formatTime' :: (HasLocalTime t, MonadHandler m, HandlerSite m ~ UniWorX) => String -> t -> m Text
|
||||
formatTime' fmtStr t = fmap fromString $ Time.formatTime <$> getTimeLocale <*> pure fmtStr <*> pure (toLocalTime t)
|
||||
|
||||
|
||||
@ -33,8 +33,8 @@ import qualified Database.Esqueleto.Internal.Language as E (From)
|
||||
|
||||
data DeleteRoute record = forall tables infoExpr info. (E.SqlSelect infoExpr info, E.From E.SqlQuery E.SqlExpr SqlBackend tables) => DeleteRoute
|
||||
{ drRecords :: Set (Key record)
|
||||
, drUnjoin :: tables -> E.SqlExpr (Entity record)
|
||||
, drGetInfo :: tables -> E.SqlQuery infoExpr
|
||||
, drUnjoin :: tables -> E.SqlExpr (Entity record)
|
||||
, drRenderRecord :: info -> ReaderT SqlBackend (HandlerT UniWorX IO) Widget
|
||||
, drRecordConfirmString :: info -> ReaderT SqlBackend (HandlerT UniWorX IO) Text
|
||||
, drCaption
|
||||
|
||||
@ -173,6 +173,13 @@ multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq
|
||||
-> AForm Handler a
|
||||
multiActionA acts fSettings defAction = formToAForm $ multiAction acts fSettings defAction mempty
|
||||
|
||||
multiActionW :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
|
||||
=> Map action (AForm Handler a)
|
||||
-> FieldSettings UniWorX
|
||||
-> Maybe action
|
||||
-> WForm Handler (FormResult a)
|
||||
multiActionW acts fSettings defAction = aFormToWForm $ multiActionA acts fSettings defAction
|
||||
|
||||
multiActionM :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
|
||||
=> Map action (AForm (HandlerT UniWorX IO) a)
|
||||
-> FieldSettings UniWorX
|
||||
@ -509,11 +516,8 @@ dayTimeField fs mutc = do
|
||||
| otherwise = (Nothing,Nothing)
|
||||
-}
|
||||
|
||||
|
||||
utcTimeField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m UTCTime
|
||||
-- StackOverflow: dayToUTC <$> (areq (jqueryDayField def {...}) settings Nothing)
|
||||
-- Browser returns LocalTime
|
||||
utcTimeField = Field
|
||||
localTimeField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m LocalTime
|
||||
localTimeField = Field
|
||||
{ fieldParse = parseHelperGen readTime
|
||||
, fieldView = \theId name attrs val isReq -> do
|
||||
val' <- either id id <$> traverse (formatTime' fieldTimeFormat) val
|
||||
@ -529,13 +533,20 @@ utcTimeField = Field
|
||||
fieldTimeFormat = "%Y-%m-%dT%H:%M"
|
||||
|
||||
-- `defaultTimeLocale` is okay here, since `fieldTimeFormat` does not contain any
|
||||
readTime :: Text -> Either UniWorXMessage UTCTime
|
||||
readTime :: Text -> Either UniWorXMessage LocalTime
|
||||
readTime t =
|
||||
case localTimeToUTC <$> parseTimeM True defaultTimeLocale fieldTimeFormat (T.unpack t) of
|
||||
Just LTUUnique{_ltuResult} -> Right _ltuResult
|
||||
Just LTUNone{} -> Left MsgIllDefinedUTCTime
|
||||
Just LTUAmbiguous{} -> Left MsgAmbiguousUTCTime
|
||||
Nothing -> Left MsgInvalidDateTimeFormat
|
||||
case parseTimeM True defaultTimeLocale fieldTimeFormat (T.unpack t) of
|
||||
Just lTime -> Right lTime
|
||||
Nothing -> Left MsgInvalidDateTimeFormat
|
||||
|
||||
utcTimeField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m UTCTime
|
||||
utcTimeField = checkMMap (return . localTimeToUTC') utcToLocalTime localTimeField
|
||||
where
|
||||
localTimeToUTC' l = case localTimeToUTC l of
|
||||
LTUUnique{_ltuResult} -> Right _ltuResult
|
||||
LTUNone{} -> Left MsgIllDefinedUTCTime
|
||||
LTUAmbiguous{} -> Left MsgAmbiguousUTCTime
|
||||
|
||||
|
||||
langField :: Bool -- ^ Only allow values from `appLanguages`
|
||||
-> Field (HandlerT UniWorX IO) Lang
|
||||
|
||||
@ -2,12 +2,13 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
|
||||
module Handler.Utils.Form.MassInput
|
||||
( MassInput(..)
|
||||
, defaultMiLayout
|
||||
( MassInput(..), MassInputLayout
|
||||
, defaultMiLayout, listMiLayout
|
||||
, massInput
|
||||
, module Handler.Utils.Form.MassInput.Liveliness
|
||||
, massInputA, massInputW
|
||||
, massInputList
|
||||
, massInputAccum, massInputAccumA
|
||||
, ListLength(..), ListPosition(..), miDeleteList
|
||||
, EnumLiveliness(..), EnumPosition(..)
|
||||
, MapLiveliness(..)
|
||||
@ -254,14 +255,17 @@ data MassInput handler liveliness cellData cellResult = MassInput
|
||||
-> liveliness
|
||||
-> Set (BoxCoord liveliness) -- ^ Usually addition widgets are only provided for dimension 0 and all _lines_ that have at least one live coordinate. `miAddEmpty` allows specifying when to provide additional widgets
|
||||
, miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) -- ^ Override form-tag route for `massInput`-Buttons to keep the user closer to the Widget, the `PathPiece` Argument is to be used for constructiong a `Fragment`
|
||||
, miLayout :: liveliness
|
||||
-> Map (BoxCoord liveliness) (cellData, FormResult cellResult)
|
||||
-> Map (BoxCoord liveliness) Widget -- Cell Widgets
|
||||
-> Map (BoxCoord liveliness) (FieldView UniWorX) -- Delete buttons
|
||||
-> Map (Natural, BoxCoord liveliness) Widget -- Addition forms
|
||||
-> Widget
|
||||
, miLayout :: MassInputLayout liveliness cellData cellResult
|
||||
}
|
||||
|
||||
type MassInputLayout liveliness cellData cellResult
|
||||
= liveliness
|
||||
-> Map (BoxCoord liveliness) (cellData, FormResult cellResult)
|
||||
-> Map (BoxCoord liveliness) Widget -- Cell Widgets
|
||||
-> Map (BoxCoord liveliness) (FieldView UniWorX) -- Delete buttons
|
||||
-> Map (Natural, BoxCoord liveliness) Widget -- Addition forms
|
||||
-> Widget
|
||||
|
||||
massInput :: forall handler cellData cellResult liveliness.
|
||||
( MonadHandler handler, HandlerSite handler ~ UniWorX
|
||||
, ToJSON cellData, FromJSON cellData
|
||||
@ -418,12 +422,7 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
|
||||
|
||||
defaultMiLayout :: forall liveliness cellData cellResult.
|
||||
Liveliness liveliness
|
||||
=> liveliness
|
||||
-> Map (BoxCoord liveliness) (cellData, FormResult cellResult)
|
||||
-> Map (BoxCoord liveliness) Widget
|
||||
-> Map (BoxCoord liveliness) (FieldView UniWorX)
|
||||
-> Map (Natural, BoxCoord liveliness) Widget
|
||||
-> Widget
|
||||
=> MassInputLayout liveliness cellData cellResult
|
||||
-- | Generic `miLayout` using recursively nested lists
|
||||
defaultMiLayout liveliness _ cellResults delResults addResults = miWidget' boxOrigin [] $ zip [0..] boxDimensions
|
||||
where
|
||||
@ -442,6 +441,9 @@ defaultMiLayout liveliness _ cellResults delResults addResults = miWidget' boxOr
|
||||
addWidget = Map.lookup (dimIx, miCoord) addResults
|
||||
in $(widgetFile "widgets/massinput/row")
|
||||
|
||||
listMiLayout :: MassInputLayout ListLength cellData cellResult
|
||||
listMiLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/list/layout")
|
||||
|
||||
|
||||
-- | Wrapper around `massInput` for the common case, that we just want an arbitrary list of single fields without any constraints
|
||||
massInputList :: forall handler cellResult.
|
||||
@ -464,13 +466,67 @@ massInputList field fieldSettings miButtonAction miSettings miRequired miPrevRes
|
||||
, miAllowAdd = \_ _ _ -> True
|
||||
, miAddEmpty = \_ _ _ -> Set.empty
|
||||
, miButtonAction
|
||||
, miLayout = \lLength _ cellWdgts delButtons addWdgts
|
||||
-> $(widgetFile "widgets/massinput/list/layout")
|
||||
, miLayout = listMiLayout
|
||||
}
|
||||
miSettings
|
||||
miRequired
|
||||
(Map.fromList . zip [0..] . map ((), ) <$> miPrevResult)
|
||||
|
||||
-- | Wrapper around `massInput` for the common case, that we just want a list of data with no option to modify it except deletion and addition
|
||||
massInputAccum :: forall handler cellData.
|
||||
( MonadHandler handler, HandlerSite handler ~ UniWorX
|
||||
, MonadLogger handler
|
||||
, ToJSON cellData, FromJSON cellData
|
||||
)
|
||||
=> ((Text -> Text) -> FieldView UniWorX -> (Markup -> MForm handler (FormResult ([cellData] -> FormResult [cellData]), Widget)))
|
||||
-> (cellData -> Widget)
|
||||
-> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
|
||||
-> MassInputLayout ListLength cellData ()
|
||||
-> FieldSettings UniWorX
|
||||
-> Bool
|
||||
-> Maybe [cellData]
|
||||
-> (Markup -> MForm handler (FormResult [cellData], FieldView UniWorX))
|
||||
massInputAccum miAdd' miCell' miButtonAction miLayout fSettings fRequired mPrev csrf
|
||||
= over (_1 . mapped) (map fst . Map.elems) <$> massInput MassInput{..} fSettings fRequired (Map.fromList . zip [0..] . map (, ()) <$> mPrev) csrf
|
||||
where
|
||||
miAdd :: ListPosition -> Natural
|
||||
-> (Text -> Text) -> FieldView UniWorX
|
||||
-> Maybe (Markup -> MForm handler (FormResult (Map ListPosition cellData -> FormResult (Map ListPosition cellData)), Widget))
|
||||
miAdd _pos _dim nudge submitView = Just $ \csrf' -> over (_1 . mapped) doAdd <$> miAdd' nudge submitView csrf'
|
||||
|
||||
doAdd :: ([cellData] -> FormResult [cellData]) -> (Map ListPosition cellData -> FormResult (Map ListPosition cellData))
|
||||
doAdd f prevData = Map.fromList . zip [startKey..] <$> f prevElems
|
||||
where
|
||||
prevElems = Map.elems prevData
|
||||
startKey = maybe 0 succ $ fst <$> Map.lookupMax prevData
|
||||
|
||||
miCell :: ListPosition -> cellData -> Maybe () -> (Text -> Text)
|
||||
-> (Markup -> MForm handler (FormResult (), Widget))
|
||||
miCell _pos dat _mPrev _nudge csrf' = return (FormSuccess (), toWidget csrf' <> miCell' dat)
|
||||
|
||||
miDelete = miDeleteList
|
||||
|
||||
miAllowAdd _ _ _ = True
|
||||
|
||||
miAddEmpty _ _ _ = Set.empty
|
||||
|
||||
massInputAccumA :: forall handler cellData.
|
||||
( MonadHandler handler, HandlerSite handler ~ UniWorX
|
||||
, MonadLogger handler
|
||||
, ToJSON cellData, FromJSON cellData
|
||||
)
|
||||
=> ((Text -> Text) -> FieldView UniWorX -> (Markup -> MForm handler (FormResult ([cellData] -> FormResult [cellData]), Widget)))
|
||||
-> (cellData -> Widget)
|
||||
-> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
|
||||
-> MassInputLayout ListLength cellData ()
|
||||
-> FieldSettings UniWorX
|
||||
-> Bool
|
||||
-> Maybe [cellData]
|
||||
-> AForm handler [cellData]
|
||||
massInputAccumA miAdd' miCell' miButtonAction' miLayout' fSettings fRequired mPrev
|
||||
= formToAForm $ over _2 pure <$> massInputAccum miAdd' miCell' miButtonAction' miLayout' fSettings fRequired mPrev mempty
|
||||
|
||||
|
||||
massInputA :: forall handler cellData cellResult liveliness.
|
||||
( MonadHandler handler, HandlerSite handler ~ UniWorX
|
||||
, ToJSON cellData, FromJSON cellData
|
||||
|
||||
122
src/Handler/Utils/Form/Occurences.hs
Normal file
122
src/Handler/Utils/Form/Occurences.hs
Normal file
@ -0,0 +1,122 @@
|
||||
module Handler.Utils.Form.Occurences
|
||||
( occurencesAForm
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Handler.Utils.Form
|
||||
import Handler.Utils.Form.MassInput
|
||||
import Handler.Utils.DateTime
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import Data.Map ((!))
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
|
||||
data OccurenceScheduleKind = ScheduleKindWeekly
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
||||
|
||||
instance Universe OccurenceScheduleKind
|
||||
instance Finite OccurenceScheduleKind
|
||||
|
||||
nullaryPathPiece ''OccurenceScheduleKind $ camelToPathPiece' 2
|
||||
embedRenderMessage ''UniWorX ''OccurenceScheduleKind id
|
||||
|
||||
data OccurenceExceptionKind = ExceptionKindOccur
|
||||
| ExceptionKindNoOccur
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
||||
|
||||
instance Universe OccurenceExceptionKind
|
||||
instance Finite OccurenceExceptionKind
|
||||
|
||||
nullaryPathPiece ''OccurenceExceptionKind $ camelToPathPiece' 2
|
||||
embedRenderMessage ''UniWorX ''OccurenceExceptionKind id
|
||||
|
||||
|
||||
occurencesAForm :: Maybe Occurences -> AForm Handler Occurences
|
||||
occurencesAForm mPrev = wFormToAForm $ do
|
||||
Just cRoute <- getCurrentRoute
|
||||
|
||||
let
|
||||
scheduled :: AForm Handler (Set OccurenceSchedule)
|
||||
scheduled = Set.fromList <$> massInputAccumA
|
||||
miAdd'
|
||||
miCell'
|
||||
(\p -> Just . SomeRoute $ cRoute :#: p)
|
||||
miLayout'
|
||||
(fslI MsgScheduleRegular)
|
||||
False
|
||||
(Set.toList . occurencesScheduled <$> mPrev)
|
||||
where
|
||||
miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([OccurenceSchedule] -> FormResult [OccurenceSchedule])
|
||||
miAdd' nudge submitView = over (mapped . mapped . _2) (\addWidget -> $(widgetFile "widgets/occurence/form/scheduled-add")) . renderAForm FormStandard . wFormToAForm $ do
|
||||
newSched <- multiActionW
|
||||
(Map.fromList [ ( ScheduleKindWeekly
|
||||
, ScheduleWeekly
|
||||
<$> apreq (selectField optionsFinite) (fslI MsgWeekDay & addName (nudge "occur-week-day")) Nothing
|
||||
<*> apreq timeFieldTypeTime (fslI MsgOccurenceStart & addName (nudge "occur-start")) Nothing
|
||||
<*> apreq timeFieldTypeTime (fslI MsgOccurenceEnd & addName (nudge "occur-end")) Nothing
|
||||
)
|
||||
]
|
||||
) (fslI MsgScheduleRegularKind & addName (nudge "kind")) Nothing
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
return $ newSched <&> \newSched' oldScheds -> if
|
||||
| newSched' `elem` oldScheds -> FormFailure [mr MsgScheduleExists]
|
||||
| otherwise -> FormSuccess $ pure newSched'
|
||||
|
||||
miCell' :: OccurenceSchedule -> Widget
|
||||
miCell' ScheduleWeekly{..} = do
|
||||
scheduleStart' <- formatTime SelFormatTime scheduleStart
|
||||
scheduleEnd' <- formatTime SelFormatTime scheduleEnd
|
||||
$(widgetFile "widgets/occurence/form/weekly")
|
||||
|
||||
miLayout' :: MassInputLayout ListLength OccurenceSchedule ()
|
||||
miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/occurence/form/scheduled-layout")
|
||||
|
||||
exceptions :: AForm Handler (Set OccurenceException)
|
||||
exceptions = Set.fromList <$> massInputAccumA
|
||||
miAdd'
|
||||
miCell'
|
||||
(\p -> Just . SomeRoute $ cRoute :#: p)
|
||||
miLayout'
|
||||
(fslI MsgScheduleExceptions & setTooltip MsgScheduleExceptionsTip)
|
||||
False
|
||||
(Set.toList . occurencesExceptions <$> mPrev)
|
||||
where
|
||||
miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([OccurenceException] -> FormResult [OccurenceException])
|
||||
miAdd' nudge submitView = over (mapped . mapped . _2) (\addWidget -> $(widgetFile "widgets/occurence/form/except-add")) . renderAForm FormStandard . wFormToAForm $ do
|
||||
newExc <- multiActionW
|
||||
(Map.fromList [ ( ExceptionKindOccur
|
||||
, ExceptOccur
|
||||
<$> apreq dayField (fslI MsgDay & addName (nudge "occur-day")) Nothing
|
||||
<*> apreq timeFieldTypeTime (fslI MsgOccurenceStart & addName (nudge "occur-start")) Nothing
|
||||
<*> apreq timeFieldTypeTime (fslI MsgOccurenceEnd & addName (nudge "occur-end")) Nothing
|
||||
)
|
||||
, ( ExceptionKindNoOccur
|
||||
, ExceptNoOccur
|
||||
<$> apreq localTimeField (fslI MsgExceptionNoOccurAt & addName (nudge "no-occur-time")) Nothing
|
||||
)
|
||||
]
|
||||
) (fslI MsgExceptionKind & addName (nudge "kind")) Nothing
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
return $ newExc <&> \newExc' oldExcs -> if
|
||||
| newExc' `elem` oldExcs -> FormFailure [mr MsgExceptionExists]
|
||||
| otherwise -> FormSuccess $ pure newExc'
|
||||
|
||||
|
||||
miCell' :: OccurenceException -> Widget
|
||||
miCell' ExceptOccur{..} = do
|
||||
exceptStart' <- formatTime SelFormatDateTime (LocalTime exceptDay exceptStart)
|
||||
exceptEnd' <- formatTime SelFormatTime exceptStart
|
||||
$(widgetFile "widgets/occurence/form/except-occur")
|
||||
miCell' ExceptNoOccur{..} = do
|
||||
exceptTime' <- formatTime SelFormatDateTime exceptTime
|
||||
$(widgetFile "widgets/occurence/form/except-no-occur")
|
||||
|
||||
miLayout' :: MassInputLayout ListLength OccurenceException ()
|
||||
miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/occurence/form/except-layout")
|
||||
|
||||
aFormToWForm $ Occurences
|
||||
<$> scheduled
|
||||
<*> exceptions
|
||||
@ -15,7 +15,7 @@ fetchSheetAux :: ( BaseBackend backend ~ SqlBackend
|
||||
=> (E.SqlExpr (Entity Sheet) -> E.SqlExpr (Entity Course) -> b)
|
||||
-> TermId -> SchoolId -> CourseShorthand -> SheetName -> ReaderT backend m a
|
||||
fetchSheetAux prj tid ssh csh shn =
|
||||
let cachId = encodeUtf8 $ tshow (tid,ssh,csh,shn)
|
||||
let cachId = encodeUtf8 $ tshow (tid, ssh, csh, shn)
|
||||
in cachedBy cachId $ do
|
||||
-- Mit Yesod:
|
||||
-- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
|
||||
@ -79,32 +79,33 @@ assignSubmissions sid restriction = do
|
||||
loadMap :: Map UserId Bool
|
||||
loadMap = Map.fromList [(sheetCorrectorUser,b) | Entity _ SheetCorrector{ sheetCorrectorLoad = (Load {byTutorial = Just b}), .. } <- corrsTutorial]
|
||||
|
||||
currentSubs <- E.select . E.from $ \(submission `E.LeftOuterJoin` tutor) -> do
|
||||
let tutors = E.subList_select . E.from $ \(submissionUser `E.InnerJoin` tutorialUser `E.InnerJoin` tutorial) -> do
|
||||
currentSubs <- E.select . E.from $ \(submission `E.LeftOuterJoin` tutor') -> do
|
||||
let tutors = E.subList_select . E.from $ \(submissionUser `E.InnerJoin` tutorialUser `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do
|
||||
-- Uncomment next line for equal chance between tutors, irrespective of the number of students per tutor per submission group
|
||||
-- E.distinctOn [E.don $ tutorial E.^. TutorialTutor] $ do
|
||||
E.on (tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialUserTutorial)
|
||||
E.on (submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialUserUser)
|
||||
E.where_ (tutorial E.^. TutorialTutor `E.in_` E.valList (map (sheetCorrectorUser . entityVal) corrsTutorial))
|
||||
return $ tutorial E.^. TutorialTutor
|
||||
E.on $ tutor E.?. UserId `E.in_` E.justList tutors
|
||||
E.on (tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial)
|
||||
E.on (tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial)
|
||||
E.on (submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialParticipantUser)
|
||||
E.where_ (tutor E.^. TutorUser `E.in_` E.valList (map (sheetCorrectorUser . entityVal) corrsTutorial))
|
||||
return $ tutor E.^. TutorUser
|
||||
E.on $ tutor' E.?. UserId `E.in_` E.justList tutors
|
||||
E.where_ $ submission E.^. SubmissionSheet E.==. E.val sid
|
||||
E.&&. maybe (E.val True) (submission E.^. SubmissionId `E.in_`) (E.valList . Set.toList <$> restriction)
|
||||
return (submission E.^. SubmissionId, tutor)
|
||||
return (submission E.^. SubmissionId, tutor' E.?. UserId)
|
||||
|
||||
let subTutor' :: Map SubmissionId (Set UserId)
|
||||
subTutor' = Map.fromListWith Set.union $ currentSubs
|
||||
& mapped._2 %~ maybe Set.empty Set.singleton
|
||||
& mapped._2 %~ Set.mapMonotonic entityKey
|
||||
& mapped._2 %~ (maybe Set.empty Set.singleton . E.unValue)
|
||||
& mapped._1 %~ E.unValue
|
||||
|
||||
prevSubs <- E.select . E.from $ \((sheet `E.InnerJoin` sheetCorrector) `E.LeftOuterJoin` submission) -> do
|
||||
E.on $ E.joinV (submission E.?. SubmissionRatingBy) E.==. E.just (sheetCorrector E.^. SheetCorrectorUser)
|
||||
E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
|
||||
let isByTutorial = E.exists . E.from $ \(submissionUser `E.InnerJoin` tutorialUser `E.InnerJoin` tutorial) -> do
|
||||
E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialUserTutorial
|
||||
E.on $ submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialUserUser
|
||||
E.where_ $ tutorial E.^. TutorialTutor E.==. sheetCorrector E.^. SheetCorrectorUser
|
||||
let isByTutorial = E.exists . E.from $ \(submissionUser `E.InnerJoin` tutorialUser `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do
|
||||
E.on (tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial)
|
||||
E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial
|
||||
E.on $ submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialParticipantUser
|
||||
E.where_ $ tutor E.^. TutorUser E.==. sheetCorrector E.^. SheetCorrectorUser
|
||||
E.&&. submission E.?. SubmissionId E.==. E.just (submissionUser E.^. SubmissionUserSubmission)
|
||||
E.where_ $ sheet E.^. SheetCourse E.==. E.val sheetCourse
|
||||
E.&&. sheetCorrector E.^. SheetCorrectorUser `E.in_` E.valList (map (sheetCorrectorUser . entityVal) correctors)
|
||||
|
||||
@ -14,6 +14,10 @@ import Text.Blaze (ToMarkup(..))
|
||||
import Utils.Lens
|
||||
import Handler.Utils
|
||||
|
||||
import Utils.Occurences
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
|
||||
type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with WithHoles !
|
||||
|
||||
@ -189,3 +193,19 @@ correctorLoadCell :: IsDBTable m a => SheetCorrector -> DBCell m a
|
||||
correctorLoadCell sc =
|
||||
i18nCell $ sheetCorrectorLoad sc
|
||||
|
||||
occurencesCell :: IsDBTable m a => Occurences -> DBCell m a
|
||||
occurencesCell (normalizeOccurences -> Occurences{..}) = cell $ do
|
||||
let occurencesScheduled' = flip map (Set.toList occurencesScheduled) $ \case
|
||||
ScheduleWeekly{..} -> do
|
||||
scheduleStart' <- formatTime SelFormatTime scheduleStart
|
||||
scheduleEnd' <- formatTime SelFormatTime scheduleEnd
|
||||
$(widgetFile "widgets/occurence/cell/weekly")
|
||||
occurencesExceptions' = flip map (Set.toList occurencesExceptions) $ \case
|
||||
ExceptOccur{..} -> do
|
||||
exceptStart' <- formatTime SelFormatDateTime (LocalTime exceptDay exceptStart)
|
||||
exceptEnd' <- formatTime SelFormatTime exceptStart
|
||||
$(widgetFile "widgets/occurence/cell/except-occur")
|
||||
ExceptNoOccur{..} -> do
|
||||
exceptTime' <- formatTime SelFormatDateTime exceptTime
|
||||
$(widgetFile "widgets/occurence/cell/except-no-occur")
|
||||
$(widgetFile "widgets/occurence/cell")
|
||||
|
||||
@ -87,6 +87,15 @@ import Crypto.Hash.Algorithms (SHAKE256)
|
||||
import qualified Data.ByteString.Base64.URL as Base64 (encode)
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
|
||||
import Data.Semigroup as Sem (Semigroup(..))
|
||||
|
||||
|
||||
#if MIN_VERSION_base(4,11,0)
|
||||
type Monoid' = Monoid
|
||||
#else
|
||||
type Monoid' x = (Sem.Semigroup x, Monoid x)
|
||||
#endif
|
||||
|
||||
|
||||
data SortColumn t = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) }
|
||||
|
||||
@ -404,7 +413,7 @@ data DBTable m x = forall a r r' h i t k k'.
|
||||
, dbtIdent :: i
|
||||
}
|
||||
|
||||
class (MonadHandler m, HandlerSite m ~ UniWorX, Monoid x, Monoid (DBCell m x), Default (DBParams m x)) => IsDBTable (m :: * -> *) (x :: *) where
|
||||
class (MonadHandler m, HandlerSite m ~ UniWorX, Monoid' x, Monoid' (DBCell m x), Default (DBParams m x)) => IsDBTable (m :: * -> *) (x :: *) where
|
||||
data DBParams m x :: *
|
||||
type DBResult m x :: *
|
||||
-- type DBResult' m x :: *
|
||||
@ -428,7 +437,7 @@ cellAttrs = dbCell . _1
|
||||
cellContents :: IsDBTable m x => Lens' (DBCell m x) (WriterT x m Widget)
|
||||
cellContents = dbCell . _2
|
||||
|
||||
instance Monoid x => IsDBTable (HandlerT UniWorX IO) x where
|
||||
instance Monoid' x => IsDBTable (HandlerT UniWorX IO) x where
|
||||
data DBParams (HandlerT UniWorX IO) x = DBParamsWidget
|
||||
type DBResult (HandlerT UniWorX IO) x = (x, Widget)
|
||||
-- type DBResult' (WidgetT UniWorX IO) () = ()
|
||||
@ -447,14 +456,17 @@ instance Monoid x => IsDBTable (HandlerT UniWorX IO) x where
|
||||
dbHandler _ _ f = return . over _2 f
|
||||
runDBTable _ _ _ = liftHandlerT
|
||||
|
||||
instance Monoid x => Monoid (DBCell (HandlerT UniWorX IO) x) where
|
||||
instance Monoid' x => Sem.Semigroup (DBCell (HandlerT UniWorX IO) x) where
|
||||
(WidgetCell a c) <> (WidgetCell a' c') = WidgetCell (a <> a') ((<>) <$> c <*> c')
|
||||
|
||||
instance Monoid' x => Monoid (DBCell (HandlerT UniWorX IO) x) where
|
||||
mempty = WidgetCell mempty $ return mempty
|
||||
(WidgetCell a c) `mappend` (WidgetCell a' c') = WidgetCell (mappend a a') (mappend <$> c <*> c')
|
||||
mappend = (<>)
|
||||
|
||||
instance Default (DBParams (HandlerT UniWorX IO) x) where
|
||||
def = DBParamsWidget
|
||||
|
||||
instance Monoid x => IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) x where
|
||||
instance Monoid' x => IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) x where
|
||||
data DBParams (ReaderT SqlBackend (HandlerT UniWorX IO)) x = DBParamsDB
|
||||
type DBResult (ReaderT SqlBackend (HandlerT UniWorX IO)) x = (x, Widget)
|
||||
|
||||
@ -472,9 +484,12 @@ instance Monoid x => IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) x wher
|
||||
-- runDBTable :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT SqlBackend (HandlerT UniWorX IO) ((), Widget) -> m (Widget)
|
||||
runDBTable _ _ _ = mapReaderT liftHandlerT
|
||||
|
||||
instance Monoid x => Monoid (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
|
||||
instance Monoid' x => Sem.Semigroup (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
|
||||
(DBCell a c) <> (DBCell a' c') = DBCell (a <> a') ((<>) <$> c <*> c')
|
||||
|
||||
instance Monoid' x => Monoid (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
|
||||
mempty = DBCell mempty $ return mempty
|
||||
(DBCell a c) `mappend` (DBCell a' c') = DBCell (mappend a a') (mappend <$> c <*> c')
|
||||
mappend = (<>)
|
||||
|
||||
instance Default (DBParams (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
|
||||
def = DBParamsDB
|
||||
@ -492,7 +507,7 @@ unDBParamsFormIdent DBTable{dbtIdent} DBParamsFormTableIdent = Just $ toP
|
||||
unDBParamsFormIdent _ (DBParamsFormOverrideIdent x) = Just $ toPathPiece x
|
||||
unDBParamsFormIdent _ DBParamsFormNoIdent = Nothing
|
||||
|
||||
instance Monoid x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x where
|
||||
instance Monoid' x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x where
|
||||
data DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x = forall a. DBParamsForm
|
||||
{ dbParamsFormMethod :: StdMethod
|
||||
, dbParamsFormAction :: Maybe (SomeRoute UniWorX)
|
||||
@ -541,7 +556,7 @@ instance Monoid x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc
|
||||
adjResult _ = FormFailure $ pure reasonTxt
|
||||
return $ over (_1 . dbParamsFormResult) adjResult result
|
||||
|
||||
instance Monoid x => Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x) where
|
||||
instance Monoid' x => Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x) where
|
||||
def = DBParamsForm
|
||||
{ dbParamsFormMethod = POST
|
||||
, dbParamsFormAction = Nothing
|
||||
@ -553,7 +568,7 @@ instance Monoid x => Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [La
|
||||
, dbParamsFormIdent = def
|
||||
}
|
||||
|
||||
dbParamsFormWrap :: Monoid x => DBTable (MForm (HandlerT UniWorX IO)) x -> DBParams (MForm (HandlerT UniWorX IO)) x -> (Html -> MForm (HandlerT UniWorX IO) (x, Widget)) -> (Html -> MForm (HandlerT UniWorX IO) (x, Widget))
|
||||
dbParamsFormWrap :: Monoid' x => DBTable (MForm (HandlerT UniWorX IO)) x -> DBParams (MForm (HandlerT UniWorX IO)) x -> (Html -> MForm (HandlerT UniWorX IO) (x, Widget)) -> (Html -> MForm (HandlerT UniWorX IO) (x, Widget))
|
||||
dbParamsFormWrap DBTable{ dbtIdent } DBParamsForm{..} tableForm frag = do
|
||||
let form = mappend <$> tableForm frag <*> (fmap (over _1 $ (flip $ set dbParamsFormResult) mempty) $ dbParamsFormAdditional mempty)
|
||||
((res, fWidget), enctype) <- listen form
|
||||
@ -588,9 +603,12 @@ addPreviousHiddenField DBTable{ dbtIdent } pKeys form fragment = do
|
||||
wIdent :: Text -> Text
|
||||
wIdent = toPathPiece . WithIdent dbtIdent
|
||||
|
||||
instance Monoid x => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x) where
|
||||
instance Monoid' x => Sem.Semigroup (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x) where
|
||||
(FormCell attrs c l) <> (FormCell attrs' c' l') = FormCell (attrs <> attrs') ((\(a, w) (a', w') -> ((,) <$> a <*> a', w <> w')) <$> c <*> c') (lens (liftA2 (,) <$> view l <*> view l') (\s as -> s & l .~ (fst <$> as) & l' .~ (snd <$> as)))
|
||||
|
||||
instance Monoid' x => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x) where
|
||||
mempty = FormCell mempty (return mempty) $ lens (\_ -> pure ()) (\s _ -> s)
|
||||
(FormCell attrs c l) `mappend` (FormCell attrs' c' l') = FormCell (mappend attrs attrs') ((\(a, w) (a', w') -> ((,) <$> a <*> a', mappend w w')) <$> c <*> c') (lens (liftA2 (,) <$> view l <*> view l') (\s as -> s & l .~ (fst <$> as) & l' .~ (snd <$> as)))
|
||||
mappend = (<>)
|
||||
|
||||
instance IsDBTable m a => IsString (DBCell m a) where
|
||||
fromString = cell . fromString
|
||||
@ -779,24 +797,24 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
setParam :: Text -> Maybe Text -> QueryText -> QueryText
|
||||
setParam key = setParams key . maybeToList
|
||||
|
||||
dbTableWidget :: Monoid x => PSValidator (HandlerT UniWorX IO) x -> DBTable (HandlerT UniWorX IO) x
|
||||
dbTableWidget :: Monoid' x => PSValidator (HandlerT UniWorX IO) x -> DBTable (HandlerT UniWorX IO) x
|
||||
-> DB (DBResult (HandlerT UniWorX IO) x)
|
||||
dbTableWidget = dbTable
|
||||
|
||||
dbTableWidget' :: PSValidator (HandlerT UniWorX IO) () -> DBTable (HandlerT UniWorX IO) () -> DB Widget
|
||||
dbTableWidget' = fmap (fmap snd) . dbTable
|
||||
|
||||
widgetColonnade :: (Headedness h, Monoid x)
|
||||
widgetColonnade :: (Headedness h, Monoid' x)
|
||||
=> Colonnade h r (DBCell (HandlerT UniWorX IO) x)
|
||||
-> Colonnade h r (DBCell (HandlerT UniWorX IO) x)
|
||||
widgetColonnade = id
|
||||
|
||||
formColonnade :: (Headedness h, Monoid a)
|
||||
formColonnade :: (Headedness h, Monoid' a)
|
||||
=> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a))
|
||||
-> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a))
|
||||
formColonnade = id
|
||||
|
||||
dbColonnade :: (Headedness h, Monoid x)
|
||||
dbColonnade :: (Headedness h, Monoid' x)
|
||||
=> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x)
|
||||
-> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x)
|
||||
dbColonnade = id
|
||||
@ -880,9 +898,12 @@ newtype DBFormResult i a r = DBFormResult (Map i (r, a -> a))
|
||||
instance Functor (DBFormResult i a) where
|
||||
f `fmap` (DBFormResult resMap) = DBFormResult $ fmap (over _1 f) resMap
|
||||
|
||||
instance Ord i => Sem.Semigroup (DBFormResult i a r) where
|
||||
(DBFormResult m1) <> (DBFormResult m2) = DBFormResult $ Map.unionWith (\(r, f1) (_, f2) -> (r, f2 . f1)) m1 m2
|
||||
|
||||
instance Ord i => Monoid (DBFormResult i a r) where
|
||||
mempty = DBFormResult Map.empty
|
||||
(DBFormResult m1) `mappend` (DBFormResult m2) = DBFormResult $ Map.unionWith (\(r, f1) (_, f2) -> (r, f2 . f1)) m1 m2
|
||||
mappend = (<>)
|
||||
|
||||
getDBFormResult :: forall r i a. Ord i => (r -> a) -> DBFormResult i a r -> Map i a
|
||||
getDBFormResult initial (DBFormResult m) = Map.map (\(r, f) -> f $ initial r) m
|
||||
@ -914,7 +935,7 @@ formCell formCellLens genIndex genForm input@(DBRow{dbrKey}) = FormCell
|
||||
dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r) (DBCell m a)
|
||||
dbRow = Colonnade.singleton (headednessPure $ i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex
|
||||
|
||||
dbSelect :: forall x h r i a. (Headedness h, Ord i, PathPiece i, Monoid x)
|
||||
dbSelect :: forall x h r i a. (Headedness h, Ord i, PathPiece i, Monoid' x)
|
||||
=> Lens' x (FormResult (DBFormResult i a (DBRow r)))
|
||||
-> Setter' a Bool
|
||||
-> (DBRow r -> MForm (HandlerT UniWorX IO) i)
|
||||
|
||||
47
src/Handler/Utils/Tutorial.hs
Normal file
47
src/Handler/Utils/Tutorial.hs
Normal file
@ -0,0 +1,47 @@
|
||||
module Handler.Utils.Tutorial
|
||||
( fetchTutorialAux
|
||||
, fetchTutorial, fetchTutorialId, fetchCourseIdTutorialId, fetchCourseIdTutorial
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Database.Persist.Sql (SqlBackendCanRead)
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Internal.Sql as E
|
||||
import Database.Esqueleto.Utils.TH
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
|
||||
fetchTutorialAux :: ( SqlBackendCanRead backend
|
||||
, E.SqlSelect b a
|
||||
, MonadHandler m
|
||||
, Typeable a
|
||||
)
|
||||
=> (E.SqlExpr (Entity Tutorial) -> E.SqlExpr (Entity Course) -> b)
|
||||
-> TermId -> SchoolId -> CourseShorthand -> TutorialName -> ReaderT backend m a
|
||||
fetchTutorialAux prj tid ssh csh tutn =
|
||||
let cachId = encodeUtf8 $ tshow (tid, ssh, csh, tutn)
|
||||
in cachedBy cachId $ do
|
||||
tutList <- E.select . E.from $ \(course `E.InnerJoin` tut) -> do
|
||||
E.on $ course E.^. CourseId E.==. tut E.^. TutorialCourse
|
||||
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
E.&&. tut E.^. TutorialName E.==. E.val tutn
|
||||
return $ prj tut course
|
||||
case tutList of
|
||||
[tut] -> return tut
|
||||
_other -> notFound
|
||||
|
||||
fetchTutorial :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> DB (Entity Tutorial)
|
||||
fetchTutorial = fetchTutorialAux const
|
||||
|
||||
fetchTutorialId :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> YesodDB UniWorX (Key Tutorial)
|
||||
fetchTutorialId tid ssh cid tutn = E.unValue <$> fetchTutorialAux (\tutorial _ -> tutorial E.^. TutorialId) tid ssh cid tutn
|
||||
|
||||
fetchCourseIdTutorialId :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> YesodDB UniWorX (Key Course, Key Tutorial)
|
||||
fetchCourseIdTutorialId tid ssh cid tutn = $(unValueN 2) <$> fetchTutorialAux (\tutorial course -> (course E.^. CourseId, tutorial E.^. TutorialId)) tid ssh cid tutn
|
||||
|
||||
fetchCourseIdTutorial :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> YesodDB UniWorX (Key Course, Entity Tutorial)
|
||||
fetchCourseIdTutorial tid ssh cid tutn = over _1 E.unValue <$> fetchTutorialAux (\tutorial course -> (course E.^. CourseId, tutorial)) tid ssh cid tutn
|
||||
@ -23,7 +23,7 @@ import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as ByteString
|
||||
|
||||
import System.FilePath
|
||||
import Data.Time
|
||||
import Data.Time.LocalTime (localTimeToUTC, utcToLocalTime)
|
||||
|
||||
import Data.List (dropWhileEnd)
|
||||
|
||||
|
||||
@ -53,7 +53,7 @@ import Data.List.NonEmpty.Instances as Import ()
|
||||
import Data.NonNull.Instances as Import ()
|
||||
import Data.Text.Encoding.Error as Import(UnicodeException(..))
|
||||
import Data.Semigroup as Import (Semigroup)
|
||||
import Data.Monoid as Import (Last(..), First(..))
|
||||
import Data.Monoid as Import (Last(..), First(..), Any(..), All(..))
|
||||
import Data.Monoid.Instances as Import ()
|
||||
import Data.Set.Instances as Import ()
|
||||
import Data.HashMap.Strict.Instances as Import ()
|
||||
@ -86,6 +86,15 @@ import Text.Blaze.Instances as Import ()
|
||||
import Jose.Jwt.Instances as Import ()
|
||||
import Web.PathPieces.Instances as Import ()
|
||||
|
||||
import Data.Time.Calendar as Import
|
||||
import Data.Time.Clock as Import
|
||||
import Data.Time.LocalTime as Import hiding (utcToLocalTime, localTimeToUTC)
|
||||
import Time.Types as Import (WeekDay(..))
|
||||
|
||||
import Time.Types.Instances as Import ()
|
||||
|
||||
import Data.CaseInsensitive as Import (CI, FoldCase(..), foldedCase)
|
||||
|
||||
|
||||
import Control.Monad.Trans.RWS (RWST)
|
||||
|
||||
|
||||
@ -47,7 +47,6 @@ import Control.Monad.Trans.Resource (MonadResourceBase, runResourceT, allocate,
|
||||
import Control.Monad.Trans.Maybe (MaybeT(..))
|
||||
import Control.Monad.Logger
|
||||
|
||||
import Data.Time.Clock
|
||||
import Data.Time.Zones
|
||||
|
||||
import Control.Concurrent.STM (retry)
|
||||
|
||||
@ -11,7 +11,6 @@ import Data.Maybe (fromJust)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Semigroup (Max(..))
|
||||
|
||||
import Data.Time
|
||||
import Data.Time.Zones
|
||||
|
||||
import Control.Monad.Trans.Writer (execWriterT)
|
||||
|
||||
@ -6,7 +6,7 @@ module Jobs.Queue
|
||||
, module Jobs.Types
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Import hiding ((<>))
|
||||
|
||||
import Utils.Sql
|
||||
import Jobs.Types
|
||||
@ -23,6 +23,8 @@ import Control.Monad.Random (evalRand, mkStdGen, uniform)
|
||||
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
import Data.Semigroup ((<>))
|
||||
|
||||
|
||||
data JobQueueException = JobQueuePoolEmpty
|
||||
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
|
||||
|
||||
@ -35,6 +35,7 @@ share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll
|
||||
-- (Eq Course) is impossible so we derive it for the Uniqueness Constraint only
|
||||
deriving instance Eq (Unique Course)
|
||||
deriving instance Eq (Unique Sheet)
|
||||
deriving instance Eq (Unique Tutorial)
|
||||
|
||||
-- Primary keys mentioned in dbtable row-keys must be Binary
|
||||
-- Automatically generated (i.e. numeric) ids are already taken care of
|
||||
|
||||
@ -247,6 +247,11 @@ customMigrations = Map.fromListWith (>>)
|
||||
( Legacy.UserSubmissions , Legacy.Upload False ) -> SubmissionMode False (Just $ Upload False)
|
||||
[executeQQ| UPDATE "sheet" SET "submission_mode" = #{submissionMode'} WHERE "id" = #{shid}; |]
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|11.0.0|] [version|12.0.0|]
|
||||
, whenM ((&&) <$> tableExists "tutorial" <*> tableExists "tutorial_user") $ do -- Tutorials were an unused stub before
|
||||
tableDropEmpty "tutorial"
|
||||
tableDropEmpty "tutorial_user"
|
||||
)
|
||||
]
|
||||
|
||||
|
||||
@ -258,6 +263,18 @@ tableExists table = do
|
||||
[Just _] -> return True
|
||||
_other -> return False
|
||||
|
||||
tableIsEmpty :: MonadIO m => Text -> ReaderT SqlBackend m Bool
|
||||
tableIsEmpty table = do
|
||||
[rows] <- rawSql [st|SELECT COUNT(*) FROM "#{table}"|] []
|
||||
return $ unSingle rows == (0 :: Int64)
|
||||
|
||||
tableDropEmpty :: MonadIO m => Text -> ReaderT SqlBackend m ()
|
||||
tableDropEmpty table = do
|
||||
isEmpty <- tableIsEmpty table
|
||||
if
|
||||
| isEmpty -> rawExecute [st|DROP TABLE "#{table}" CASCADE|] []
|
||||
| otherwise -> fail $ "Table " <> unpack table <> " is not empty"
|
||||
|
||||
columnExists :: MonadIO m
|
||||
=> Text -- ^ Table
|
||||
-> Text -- ^ Column
|
||||
|
||||
@ -83,6 +83,9 @@ import Data.Text.Metrics (damerauLevenshtein)
|
||||
|
||||
import Data.Binary (Binary)
|
||||
import qualified Data.Binary as Binary
|
||||
|
||||
import Time.Types (WeekDay(..))
|
||||
import Data.Time.LocalTime (LocalTime, TimeOfDay)
|
||||
|
||||
|
||||
instance PathPiece UUID where
|
||||
@ -752,10 +755,11 @@ pseudonymFragments = folding
|
||||
|
||||
data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prädikate sind sortier nach Relevanz für Benutzer
|
||||
= AuthAdmin
|
||||
| AuthToken
|
||||
| AuthLecturer
|
||||
| AuthCorrector
|
||||
| AuthRegistered
|
||||
| AuthTutor
|
||||
| AuthCourseRegistered
|
||||
| AuthTutorialRegistered
|
||||
| AuthParticipant
|
||||
| AuthTime
|
||||
| AuthMaterials
|
||||
@ -764,12 +768,14 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
|
||||
| AuthUserSubmissions
|
||||
| AuthCorrectorSubmissions
|
||||
| AuthCapacity
|
||||
| AuthRegisterGroup
|
||||
| AuthEmpty
|
||||
| AuthSelf
|
||||
| AuthAuthentication
|
||||
| AuthNoEscalation
|
||||
| AuthRead
|
||||
| AuthWrite
|
||||
| AuthToken
|
||||
| AuthDeprecated
|
||||
| AuthDevelopment
|
||||
| AuthFree
|
||||
@ -870,6 +876,51 @@ derivePersistFieldJSON ''LecturerType
|
||||
|
||||
instance Hashable LecturerType
|
||||
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece
|
||||
} ''WeekDay
|
||||
|
||||
data OccurenceSchedule = ScheduleWeekly
|
||||
{ scheduleDayOfWeek :: WeekDay
|
||||
, scheduleStart :: TimeOfDay
|
||||
, scheduleEnd :: TimeOfDay
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = camelToPathPiece' 1
|
||||
, constructorTagModifier = camelToPathPiece' 1
|
||||
, tagSingleConstructors = True
|
||||
, sumEncoding = TaggedObject "repeat" "schedule"
|
||||
} ''OccurenceSchedule
|
||||
|
||||
data OccurenceException = ExceptOccur
|
||||
{ exceptDay :: Day
|
||||
, exceptStart :: TimeOfDay
|
||||
, exceptEnd :: TimeOfDay
|
||||
}
|
||||
| ExceptNoOccur
|
||||
{ exceptTime :: LocalTime
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = camelToPathPiece' 1
|
||||
, constructorTagModifier = camelToPathPiece' 1
|
||||
, sumEncoding = TaggedObject "exception" "for"
|
||||
} ''OccurenceException
|
||||
|
||||
data Occurences = Occurences
|
||||
{ occurencesScheduled :: Set OccurenceSchedule
|
||||
, occurencesExceptions :: Set OccurenceException
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = camelToPathPiece' 1
|
||||
} ''Occurences
|
||||
derivePersistFieldJSON ''Occurences
|
||||
|
||||
|
||||
-- Type synonyms
|
||||
|
||||
@ -881,6 +932,7 @@ type CourseName = CI Text
|
||||
type CourseShorthand = CI Text
|
||||
type SheetName = CI Text
|
||||
type UserEmail = CI Email
|
||||
type TutorialName = CI Text
|
||||
|
||||
type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString
|
||||
type InstanceId = UUID
|
||||
|
||||
19
src/Time/Types/Instances.hs
Normal file
19
src/Time/Types/Instances.hs
Normal file
@ -0,0 +1,19 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Time.Types.Instances
|
||||
(
|
||||
) where
|
||||
|
||||
-- import ClassyPrelude
|
||||
|
||||
import Time.Types
|
||||
|
||||
import Data.Universe
|
||||
|
||||
import Utils.PathPiece
|
||||
|
||||
|
||||
instance Universe WeekDay
|
||||
instance Finite WeekDay
|
||||
|
||||
nullaryPathPiece ''WeekDay camelToPathPiece
|
||||
@ -23,6 +23,7 @@ import qualified Data.Set as Set
|
||||
import Control.Monad.Trans.Maybe (MaybeT(..))
|
||||
import Control.Monad.Reader.Class (MonadReader(..))
|
||||
import Control.Monad.Writer.Class (MonadWriter(..))
|
||||
import Control.Monad.Trans.RWS (mapRWST)
|
||||
|
||||
import Data.List ((!!))
|
||||
|
||||
@ -357,8 +358,11 @@ submitButtonView = do
|
||||
|
||||
|
||||
buttonForm :: (Button site a, Finite a) => Html -> MForm (HandlerT site IO) (FormResult a, WidgetT site IO ())
|
||||
buttonForm csrf = do
|
||||
(res, ($ []) -> fViews) <- aFormToForm . disambiguateButtons $ combinedButtonFieldF ""
|
||||
buttonForm = buttonForm' universeF
|
||||
|
||||
buttonForm' :: Button site a => [a] -> Html -> MForm (HandlerT site IO) (FormResult a, WidgetT site IO ())
|
||||
buttonForm' btns csrf = do
|
||||
(res, ($ []) -> fViews) <- aFormToForm . disambiguateButtons $ combinedButtonField btns ""
|
||||
return (res, [whamlet|
|
||||
$newline never
|
||||
#{csrf}
|
||||
@ -366,7 +370,6 @@ buttonForm csrf = do
|
||||
^{fvInput bView}
|
||||
|])
|
||||
|
||||
|
||||
-------------------
|
||||
-- Custom Fields --
|
||||
-------------------
|
||||
@ -614,6 +617,18 @@ prismAForm p outer form = review p <$> form inner
|
||||
where
|
||||
inner = outer >>= preview p
|
||||
|
||||
-----------------------
|
||||
-- Form Manipulation --
|
||||
-----------------------
|
||||
|
||||
aFormToWForm :: MonadHandler m => AForm m a -> WForm m (FormResult a)
|
||||
aFormToWForm = mapRWST mFormToWForm' . over (mapped . _2) ($ []) . aFormToForm
|
||||
where
|
||||
mFormToWForm' f = do
|
||||
((a, vs), ints, enctype) <- lift f
|
||||
writer ((a, ints, enctype), vs)
|
||||
|
||||
|
||||
---------------------------------------------
|
||||
-- Special variants of @mopt@, @mreq@, ... --
|
||||
---------------------------------------------
|
||||
|
||||
@ -5,6 +5,7 @@ import Model
|
||||
import Control.Lens as Utils.Lens hiding ((<.>), universe, snoc)
|
||||
import Control.Lens.Extras as Utils.Lens (is)
|
||||
import Utils.Lens.TH as Utils.Lens (makeLenses_, makeClassyFor_)
|
||||
import Data.Set.Lens as Utils.Lens
|
||||
|
||||
import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
|
||||
|
||||
@ -103,6 +104,16 @@ makeLenses_ ''SubmissionMode
|
||||
|
||||
makePrisms ''E.Value
|
||||
|
||||
makeLenses_ ''OccurenceSchedule
|
||||
|
||||
makePrisms ''OccurenceSchedule
|
||||
|
||||
makeLenses_ ''OccurenceException
|
||||
|
||||
makePrisms ''OccurenceException
|
||||
|
||||
makeLenses_ ''Occurences
|
||||
|
||||
|
||||
-- makeClassy_ ''Load
|
||||
|
||||
|
||||
84
src/Utils/Occurences.hs
Normal file
84
src/Utils/Occurences.hs
Normal file
@ -0,0 +1,84 @@
|
||||
{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}
|
||||
|
||||
module Utils.Occurences
|
||||
( normalizeOccurences
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
|
||||
import Model.Types
|
||||
import Utils
|
||||
import Utils.Lens
|
||||
|
||||
import Control.Monad.Trans.Reader (runReader, Reader)
|
||||
|
||||
import Control.Monad.Trans.Except (ExceptT, throwE, runExceptT)
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Data.Time
|
||||
import Data.Time.Calendar.WeekDate
|
||||
|
||||
|
||||
normalizeOccurences :: Occurences -> Occurences
|
||||
-- ^
|
||||
--
|
||||
-- - Removes unnecessary exceptions
|
||||
-- - Merges overlapping schedules
|
||||
normalizeOccurences initial
|
||||
| Left new <- runReader (runExceptT go) initial
|
||||
= normalizeOccurences new
|
||||
| otherwise
|
||||
= initial
|
||||
where
|
||||
go :: ExceptT Occurences (Reader Occurences) ()
|
||||
-- Find some inconsistency and `throwE` a version without it
|
||||
go = do
|
||||
scheduled <- view _occurencesScheduled
|
||||
forM_ scheduled $ \case
|
||||
a@ScheduleWeekly{} -> do
|
||||
let
|
||||
merge b@ScheduleWeekly{}
|
||||
| scheduleDayOfWeek a == scheduleDayOfWeek b -- b starts during a
|
||||
, scheduleStart a <= scheduleStart b
|
||||
, scheduleEnd a >= scheduleStart b
|
||||
= Just $ ScheduleWeekly (scheduleDayOfWeek a) (scheduleStart a) ((max `on` scheduleEnd) a b)
|
||||
| scheduleDayOfWeek a == scheduleDayOfWeek b -- b ends during a
|
||||
, scheduleStart a <= scheduleEnd b
|
||||
, scheduleEnd a >= scheduleEnd b
|
||||
= Just $ ScheduleWeekly (scheduleDayOfWeek a) ((min `on` scheduleStart) a b) (scheduleEnd a)
|
||||
| otherwise
|
||||
= Nothing
|
||||
merge _ = Nothing
|
||||
merges <- views _occurencesScheduled $ mapMaybe (\b -> (,) <$> pure b <*> merge b) . Set.toList . Set.delete a
|
||||
case merges of
|
||||
[] -> return ()
|
||||
((b, merged) : _) -> throwE =<< asks (over _occurencesScheduled $ Set.insert merged . Set.delete b . Set.delete a)
|
||||
|
||||
exceptions <- view _occurencesExceptions
|
||||
forM_ exceptions $ \case
|
||||
needle@ExceptNoOccur{..} -> do
|
||||
let LocalTime{..} = exceptTime
|
||||
(_, _, toEnum . (`mod` 7) -> localWeekDay) = toWeekDate localDay
|
||||
needed <- views _occurencesScheduled . any $ \case
|
||||
ScheduleWeekly{..} -> and
|
||||
[ scheduleDayOfWeek == localWeekDay
|
||||
, scheduleStart <= localTimeOfDay
|
||||
, localTimeOfDay <= scheduleEnd
|
||||
]
|
||||
unless needed $
|
||||
throwE =<< asks (over _occurencesExceptions $ Set.delete needle)
|
||||
needle@ExceptOccur{..} -> do
|
||||
let (_, _, toEnum . (`mod` 7) -> localWeekDay) = toWeekDate exceptDay
|
||||
-- | Does this ExceptNoOccur target within needle?
|
||||
withinNeedle ExceptNoOccur{..} = LocalTime exceptDay exceptStart <= exceptTime
|
||||
&& exceptTime <= LocalTime exceptDay exceptEnd
|
||||
withinNeedle _ = False
|
||||
needed <- views _occurencesScheduled . none $ \case
|
||||
ScheduleWeekly{..} -> and
|
||||
[ scheduleDayOfWeek == localWeekDay
|
||||
, scheduleStart == exceptStart
|
||||
, scheduleEnd == exceptEnd
|
||||
]
|
||||
unless needed $
|
||||
throwE =<< asks (over _occurencesExceptions $ Set.filter (not . withinNeedle) . Set.delete needle)
|
||||
@ -35,6 +35,14 @@
|
||||
font-size: 15px;
|
||||
}
|
||||
|
||||
&.tooltip__handle--danger::before {
|
||||
content: '\f12a';
|
||||
}
|
||||
|
||||
&.tooltip__handle--danger {
|
||||
background-color: var(--color-warning);
|
||||
}
|
||||
|
||||
&:hover {
|
||||
background-color: var(--color-light);
|
||||
}
|
||||
|
||||
@ -216,6 +216,10 @@
|
||||
|
||||
childInputs.forEach(function(el) {
|
||||
el.disabled = !active;
|
||||
if (el._flatpickr) {
|
||||
console.log("Flatpickr in childInputs", el, el._flatpickr.altInput);
|
||||
el._flatpickr.altInput.disabled = !active;
|
||||
}
|
||||
});
|
||||
}
|
||||
|
||||
|
||||
@ -12,25 +12,43 @@
|
||||
#{descr}
|
||||
|
||||
$with numlecs <- length lecturers
|
||||
$if numlecs > 1
|
||||
<dt .deflist__dt>_{MsgLecturersFor}
|
||||
$else
|
||||
<dt .deflist__dt>_{MsgLecturerFor}
|
||||
<dd .deflist__dd>
|
||||
<div>
|
||||
<ul .list--inline .list--comma-separated>
|
||||
$forall lect <- lecturers
|
||||
<li>^{nameEmailWidget' lect}
|
||||
$if numlecs /= 0
|
||||
$if numlecs > 1
|
||||
<dt .deflist__dt>_{MsgLecturersFor}
|
||||
$else
|
||||
<dt .deflist__dt>_{MsgLecturerFor}
|
||||
<dd .deflist__dd>
|
||||
<div>
|
||||
<ul .list--inline .list--comma-separated>
|
||||
$forall lect <- lecturers
|
||||
<li>^{nameEmailWidget' lect}
|
||||
$with numassi <- length assistants
|
||||
$if numassi > 1
|
||||
<dt .deflist__dt>_{MsgAssistantsFor}
|
||||
$else
|
||||
<dt .deflist__dt>_{MsgAssistantFor}
|
||||
<dd .deflist__dd>
|
||||
<div>
|
||||
<ul .list--inline .list--comma-separated>
|
||||
$forall assi <- assistants
|
||||
<li>^{nameEmailWidget' assi}
|
||||
$if numassi /= 0
|
||||
$if numassi > 1
|
||||
<dt .deflist__dt>_{MsgAssistantsFor}
|
||||
$else
|
||||
<dt .deflist__dt>_{MsgAssistantFor}
|
||||
<dd .deflist__dd>
|
||||
<div>
|
||||
<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}
|
||||
$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}
|
||||
|
||||
$maybe link <- courseLinkExternal course
|
||||
<dt .deflist__dt>Website
|
||||
@ -73,6 +91,11 @@ $# $if NTop (Just 0) < NTop (courseCapacity course)
|
||||
$else
|
||||
Eine Anmeldung zum Kurs ist Voraussetzung zum Zugang zu Kursmaterial
|
||||
(z.B. Übungsblätter).
|
||||
$if hasTutorials
|
||||
<dt .deflist__dt>_{MsgCourseTutorials}
|
||||
<dd .deflist__dd>
|
||||
^{tutorialTable}
|
||||
|
||||
|
||||
$# <div .container>
|
||||
$# <div .tab-group>
|
||||
|
||||
2
templates/tutorial-edit.hamlet
Normal file
2
templates/tutorial-edit.hamlet
Normal file
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
^{newTutForm}
|
||||
2
templates/tutorial-list.hamlet
Normal file
2
templates/tutorial-list.hamlet
Normal file
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
^{tutorialTable}
|
||||
2
templates/tutorial-new.hamlet
Normal file
2
templates/tutorial-new.hamlet
Normal file
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
^{newTutForm}
|
||||
2
templates/tutorial-participants.hamlet
Normal file
2
templates/tutorial-participants.hamlet
Normal file
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
^{participantTable}
|
||||
6
templates/tutorial/tutorMassInput/add.hamlet
Normal file
6
templates/tutorial/tutorMassInput/add.hamlet
Normal file
@ -0,0 +1,6 @@
|
||||
$newline never
|
||||
<td>
|
||||
#{csrf}
|
||||
^{fvInput addView}
|
||||
<td>
|
||||
^{fvInput submitView}
|
||||
3
templates/tutorial/tutorMassInput/cellKnown.hamlet
Normal file
3
templates/tutorial/tutorMassInput/cellKnown.hamlet
Normal file
@ -0,0 +1,3 @@
|
||||
$newline never
|
||||
<td>
|
||||
^{nameEmailWidget userEmail userDisplayName userSurname}
|
||||
11
templates/tutorial/tutorMassInput/layout.hamlet
Normal file
11
templates/tutorial/tutorMassInput/layout.hamlet
Normal file
@ -0,0 +1,11 @@
|
||||
$newline never
|
||||
<table>
|
||||
<tbody>
|
||||
$forall coord <- review liveCoords lLength
|
||||
<tr .massinput--cell>
|
||||
^{cellWdgts ! coord}
|
||||
<td>
|
||||
^{fvInput (delButtons ! coord)}
|
||||
<tfoot>
|
||||
<tr .massinput--add>
|
||||
^{addWdgts ! (0, 0)}
|
||||
12
templates/widgets/occurence/cell.hamlet
Normal file
12
templates/widgets/occurence/cell.hamlet
Normal file
@ -0,0 +1,12 @@
|
||||
$newline never
|
||||
<ul .list--inline .list--iconless .list--comma-separated>
|
||||
$forall sched <- occurencesScheduled'
|
||||
<li>^{sched}
|
||||
|
||||
$if not (null occurencesExceptions)
|
||||
$# <div .tooltip>
|
||||
$# <div .tooltip__handle .tooltip__handle--danger>
|
||||
$# <div .tooltip__content>
|
||||
<ul>
|
||||
$forall exc <- occurencesExceptions'
|
||||
<li>^{exc}
|
||||
2
templates/widgets/occurence/cell/except-no-occur.hamlet
Normal file
2
templates/widgets/occurence/cell/except-no-occur.hamlet
Normal file
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
_{MsgExceptionKindNoOccur}: #{exceptTime'}
|
||||
2
templates/widgets/occurence/cell/except-occur.hamlet
Normal file
2
templates/widgets/occurence/cell/except-occur.hamlet
Normal file
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
_{MsgExceptionKindOccur}: #{exceptStart'}–#{exceptEnd'}
|
||||
2
templates/widgets/occurence/cell/weekly.hamlet
Normal file
2
templates/widgets/occurence/cell/weekly.hamlet
Normal file
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
_{ShortWeekDay scheduleDayOfWeek} #{scheduleStart'}–#{scheduleEnd'}
|
||||
5
templates/widgets/occurence/form/except-add.hamlet
Normal file
5
templates/widgets/occurence/form/except-add.hamlet
Normal file
@ -0,0 +1,5 @@
|
||||
$newline never
|
||||
<td colspan=2>
|
||||
^{addWidget}
|
||||
<td>
|
||||
^{fvInput submitView}
|
||||
11
templates/widgets/occurence/form/except-layout.hamlet
Normal file
11
templates/widgets/occurence/form/except-layout.hamlet
Normal file
@ -0,0 +1,11 @@
|
||||
$newline never
|
||||
<table>
|
||||
<tbody>
|
||||
$forall coord <- review liveCoords lLength
|
||||
<tr .massinput--cell>
|
||||
^{cellWdgts ! coord}
|
||||
<td>
|
||||
^{fvInput (delButtons ! coord)}
|
||||
<tfoot>
|
||||
<tr .massinput--add>
|
||||
^{addWdgts ! (0, 0)}
|
||||
5
templates/widgets/occurence/form/except-no-occur.hamlet
Normal file
5
templates/widgets/occurence/form/except-no-occur.hamlet
Normal file
@ -0,0 +1,5 @@
|
||||
$newline never
|
||||
<td>
|
||||
_{ExceptionKindNoOccur}
|
||||
<td>
|
||||
#{exceptTime'}
|
||||
5
templates/widgets/occurence/form/except-occur.hamlet
Normal file
5
templates/widgets/occurence/form/except-occur.hamlet
Normal file
@ -0,0 +1,5 @@
|
||||
$newline never
|
||||
<td>
|
||||
_{ExceptionKindOccur}
|
||||
<td>
|
||||
#{exceptStart'}–#{exceptEnd'}
|
||||
5
templates/widgets/occurence/form/scheduled-add.hamlet
Normal file
5
templates/widgets/occurence/form/scheduled-add.hamlet
Normal file
@ -0,0 +1,5 @@
|
||||
$newline never
|
||||
<td colspan=2>
|
||||
^{addWidget}
|
||||
<td>
|
||||
^{fvInput submitView}
|
||||
11
templates/widgets/occurence/form/scheduled-layout.hamlet
Normal file
11
templates/widgets/occurence/form/scheduled-layout.hamlet
Normal file
@ -0,0 +1,11 @@
|
||||
$newline never
|
||||
<table>
|
||||
<tbody>
|
||||
$forall coord <- review liveCoords lLength
|
||||
<tr .massinput--cell>
|
||||
^{cellWdgts ! coord}
|
||||
<td>
|
||||
^{fvInput (delButtons ! coord)}
|
||||
<tfoot>
|
||||
<tr .massinput--add>
|
||||
^{addWdgts ! (0, 0)}
|
||||
5
templates/widgets/occurence/form/weekly.hamlet
Normal file
5
templates/widgets/occurence/form/weekly.hamlet
Normal file
@ -0,0 +1,5 @@
|
||||
$newline never
|
||||
<td>
|
||||
_{ScheduleKindWeekly}
|
||||
<td>
|
||||
_{scheduleDayOfWeek}, #{scheduleStart'}–#{scheduleEnd'}
|
||||
@ -22,11 +22,11 @@ import System.FilePath ((</>))
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
|
||||
import Data.Time
|
||||
|
||||
import Utils.Lens (review, view)
|
||||
import Control.Monad.Random.Class (MonadRandom(..))
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
|
||||
data DBAction = DBClear
|
||||
| DBTruncate
|
||||
@ -520,6 +520,39 @@ fillDb = do
|
||||
void . insert $ SubmissionUser maxMuster sub1
|
||||
sub1fid1 <- insertFile "AbgabeH10-1.hs"
|
||||
void . insert $ SubmissionFile sub1 sub1fid1 False False
|
||||
tut1 <- insert Tutorial
|
||||
{ tutorialName = "Di08"
|
||||
, tutorialCourse = pmo
|
||||
, tutorialType = "Tutorium"
|
||||
, tutorialCapacity = Just 30
|
||||
, tutorialRoom = "Hilbert-Raum"
|
||||
, tutorialTime = Occurences
|
||||
{ occurencesScheduled = Set.singleton $ ScheduleWeekly Tuesday (TimeOfDay 08 15 00) (TimeOfDay 10 00 00)
|
||||
, occurencesExceptions = Set.empty
|
||||
}
|
||||
, tutorialRegGroup = Just "tutorium"
|
||||
, tutorialRegisterFrom = Just now
|
||||
, tutorialRegisterTo = Nothing
|
||||
, tutorialDeregisterUntil = Nothing
|
||||
}
|
||||
void . insert $ Tutor tut1 gkleen
|
||||
void . insert $ TutorialParticipant tut1 fhamann
|
||||
tut2 <- insert Tutorial
|
||||
{ tutorialName = "Di10"
|
||||
, tutorialCourse = pmo
|
||||
, tutorialType = "Tutorium"
|
||||
, tutorialCapacity = Just 30
|
||||
, tutorialRoom = "Hilbert-Raum"
|
||||
, tutorialTime = Occurences
|
||||
{ occurencesScheduled = Set.singleton $ ScheduleWeekly Tuesday (TimeOfDay 10 15 00) (TimeOfDay 12 00 00)
|
||||
, occurencesExceptions = Set.empty
|
||||
}
|
||||
, tutorialRegGroup = Just "tutorium"
|
||||
, tutorialRegisterFrom = Just now
|
||||
, tutorialRegisterTo = Nothing
|
||||
, tutorialDeregisterUntil = Nothing
|
||||
}
|
||||
void . insert $ Tutor tut2 gkleen
|
||||
-- datenbanksysteme
|
||||
dbs <- insert' Course
|
||||
{ courseName = "Datenbanksysteme"
|
||||
|
||||
Loading…
Reference in New Issue
Block a user