diff --git a/frontend/src/utils/inputs/inputs.sass b/frontend/src/utils/inputs/inputs.sass index c40e74d6e..a42071863 100644 --- a/frontend/src/utils/inputs/inputs.sass +++ b/frontend/src/utils/inputs/inputs.sass @@ -255,3 +255,13 @@ option .checkbox margin-left: 12px + +.form--vertical .form-group__input + grid-column: unset + grid-row: 2 + +.form-group.form--vertical + grid-template: auto auto / auto + +.form--vertical__cell + vertical-align: top diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index d86ee64dd..086d37695 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -1694,10 +1694,14 @@ TutorialParticipants: Teilnehmer TutorialCapacity: Kapazität TutorialFreeCapacity: Freie Plätze TutorialRoom: Regulärer Raum +TutorialRoomHidden: Raum nur für Teilnehmer +TutorialRoomHiddenTip: Soll der Raum nur den Teilnehmern des Tutoriums angezeigt werden? +TutorialRoomIsUnset: — +TutorialRoomIsHidden: Raum wird nur Teilnehmern angezeigt TutorialTime: Zeit TutorialRegistered: Angemeldet TutorialRegGroup: Registrierungs-Gruppe -TutorialRegisterFrom: Anmeldungen ab +TutorialRegisterFrom: Anmeldungen a TutorialRegisterTo: Anmeldungen bis TutorialDeregisterUntil: Abmeldungen bis TutorialsHeading: Tutorien @@ -1843,6 +1847,8 @@ ExamRoomSurname': Nach Nachname ExamRoomMatriculation': Nach Matrikelnummer ExamRoomRandom': Zufällig pro Teilnehmer ExamRoomFifo': Auswahl durch Teilnehmer bei Anmeldung +ExamOccurrenceRoomIsUnset: — +ExamOccurrenceRoomIsHidden: Raum wird nur Teilnehmern angezeigt ExamOccurrence: Termin/Raum ExamNoOccurrence: Kein Termin/Raum @@ -1851,6 +1857,8 @@ ExamOccurrences: Termine ExamRooms: Räume ExamTimes: Termine ExamRoomRoom: Raum +ExamRoomRoomHidden: Raum nur für Angemeldete +ExamRoomRoomHiddenTip: Soll der Raum nur zu diesem Termin/Raum angemeldeten Prüfungsteilnehmern angezeigt werden? ExamRoomAlreadyExists: Prüfung ist bereits eingetragen ExamRoomName: Interne Bezeichnung ExamRoomCapacity: Kapazität @@ -2579,6 +2587,10 @@ CourseEventType: Art CourseEventTypePlaceholder: Vorlesung, Zentralübung, ... CourseEventTime: Zeit CourseEventRoom: Regulärer Raum +CourseEventRoomHidden: Raum nur für Teilnehmer +CourseEventRoomHiddenTip: Soll der Raum nur angemeldeten Kursteilnehmern angezeigt werden? +CourseEventRoomIsUnset: — +CourseEventRoomIsHidden: Raum wird nur Kurs-assoziierten Personen (Teilnehmer, Tutoren, Korrektoren, etc.) angezeigt CourseEventNote: Notiz CourseEventActions: Aktionen CourseEventsActionEdit: Bearbeiten @@ -2934,4 +2946,16 @@ InvalidCredentialsADAccountLockedOut: Benutzereintrag wurde durch Eindringlingse ExamCloseModeSeparate: Separat ExamCloseModeOnFinished: Mit Veröffentlichung ExamCloseModeOnFinishedHidden: Mit Veröffentlichung (versteckt) -ExamCloseMode: Prüfungs-Abschluss \ No newline at end of file +ExamCloseMode: Prüfungs-Abschluss + +RoomReferenceSimple: Text +RoomReferenceLink: Link & Anweisungen +RoomReferenceSimpleText: Raum +RoomReferenceSimpleTextPlaceholder: Raum +RoomReferenceLinkLink: Link +RoomReferenceLinkLinkPlaceholder: URL +RoomReferenceLinkInstructions: Anweisungen +RoomReferenceLinkInstructionsPlaceholder: Anweisungen +RoomReferenceNone: — + +UrlFieldCouldNotParseAbsolute: Konnte nicht als absolute URL interpretiert werden \ No newline at end of file diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index f0f4df032..3b3a87b2a 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -1693,6 +1693,10 @@ TutorialParticipants: Participants TutorialCapacity: Capacity TutorialFreeCapacity: Free capacity TutorialRoom: Regular room +TutorialRoomHidden: Room only for participants +TutorialRoomHiddenTip: Should the room only be displayed to tutorial participants? +TutorialRoomIsUnset: — +TutorialRoomIsHidden: Room is only displayed to participants TutorialTime: Time TutorialRegistered: Registered TutorialRegGroup: Registration group @@ -1842,6 +1846,8 @@ ExamRoomSurname': By surname ExamRoomMatriculation': By matriculation ExamRoomRandom': Randomly ExamRoomFifo': Selected by the participants when registering +ExamOccurrenceRoomIsUnset: — +ExamOccurrenceRoomIsHidden: Room is only displayed to participants registered for this occurrence/room ExamOccurrence: Occurrence/room ExamNoOccurrence: No occurrence/room @@ -1850,6 +1856,8 @@ ExamOccurrences: Exams ExamRooms: Rooms ExamTimes: Times ExamRoomRoom: Room +ExamRoomRoomHidden: Room only for participants +ExamRoomRoomHiddenTip: Should the room only be displayed to participants registered for this occurrence/room? ExamRoomAlreadyExists: Occurrence already configured ExamRoomName: Internal name ExamRoomCapacity: Capacity @@ -2579,6 +2587,10 @@ CourseEventType: Type CourseEventTypePlaceholder: Lecture, Exercise discussion, ... CourseEventTime: Time CourseEventRoom: Regular room +CourseEventRoomHidden: Room only for participants +CourseEventRoomHiddenTip: Should the room only be displayde to course participants? +CourseEventRoomIsUnset: — +CourseEventRoomIsHidden: Room is only displayed to course associated persons (participants, tutor, correctors, etc.) CourseEventNote: Note CourseEventActions: Actions CourseEventsActionEdit: Edit @@ -2936,3 +2948,15 @@ ExamCloseModeSeparate: Seperately ExamCloseModeOnFinished: With publication of achievements ExamCloseModeOnFinishedHidden: With publication of achievements (hidden) ExamCloseMode: Exam closure + +RoomReferenceSimple: Text +RoomReferenceLink: Link & Instructions +RoomReferenceSimpleText: Room +RoomReferenceSimpleTextPlaceholder: Room +RoomReferenceLinkLink: Link +RoomReferenceLinkLinkPlaceholder: URL +RoomReferenceLinkInstructions: Instructions +RoomReferenceLinkInstructionsPlaceholder: Instructions +RoomReferenceNone: — + +UrlFieldCouldNotParseAbsolute: Could not parse as an absolute URL diff --git a/models/courses.model b/models/courses.model index f9b4a0526..d64ec14ac 100644 --- a/models/courses.model +++ b/models/courses.model @@ -6,7 +6,7 @@ DegreeCourse json -- for which degree programmes this course is appropriate fo Course -- Information about a single course; contained info is always visible to all users name (CI Text) description StoredMarkup Maybe -- user-defined large Html, ought to contain module description - linkExternal Text Maybe -- arbitrary user-defined url for external course page + linkExternal URI Maybe -- arbitrary user-defined url for external course page shorthand (CI Text) -- practical shorthand of course name, used for identification term TermId -- semester this course is taught school SchoolId @@ -31,7 +31,8 @@ Course -- Information about a single course; contained info is always visible CourseEvent type (CI Text) course CourseId - room Text + room RoomReference Maybe + roomHidden Bool default=false time Occurrences note StoredMarkup Maybe lastChanged UTCTime default=now() diff --git a/models/exams.model b/models/exams.model index 295f2e768..1f496f43a 100644 --- a/models/exams.model +++ b/models/exams.model @@ -31,7 +31,8 @@ ExamPart ExamOccurrence exam ExamId name ExamOccurrenceName - room Text + room RoomReference Maybe + roomHidden Bool default=false capacity Natural start UTCTime end UTCTime Maybe diff --git a/models/tutorials.model b/models/tutorials.model index 90066fcb1..d193ff5d5 100644 --- a/models/tutorials.model +++ b/models/tutorials.model @@ -3,7 +3,8 @@ Tutorial json course CourseId type (CI Text) -- "Tutorium", "Zentralübung", ... capacity Int Maybe -- limit for enrolment in this tutorial - room Text Maybe + room RoomReference Maybe + roomHidden Bool default=false time Occurrences regGroup (CI Text) Maybe -- each participant may register for one tutorial per regGroup registerFrom UTCTime Maybe diff --git a/package.yaml b/package.yaml index 57d7d20fc..8449149a7 100644 --- a/package.yaml +++ b/package.yaml @@ -154,6 +154,7 @@ dependencies: - network-ip - data-textual - fastcdc + - network-uri other-extensions: - GeneralizedNewtypeDeriving @@ -315,6 +316,7 @@ tests: - http-types - yesod-persistent - quickcheck-io + - network-arbitrary ghc-options: - -fno-warn-orphans - -threaded -rtsopts "-with-rtsopts=-N -T" diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 81ec606cf..9a5412cfa 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -364,17 +364,20 @@ unsafeCoalesce :: E.PersistField a => [E.SqlExpr (E.Value (Maybe a))] -> E.SqlEx unsafeCoalesce = E.veryUnsafeCoerceSqlExprValue . E.coalesce -class (PersistEntity entity, PersistField value) => SqlProject entity value entity' value' | entity value entity' -> value', entity value value' -> entity' where +class (PersistEntity entity, PersistField value, PersistField value') => SqlProject entity value entity' value' | entity value entity' -> value', entity value value' -> entity' where sqlProject :: E.SqlExpr entity' -> EntityField entity value -> E.SqlExpr (E.Value value') unSqlProject :: forall p1 p2. p1 entity -> p2 entity' -> value -> value' + unSqlProjectExpr :: forall p1 p2. p1 entity -> p2 entity' -> E.SqlExpr (E.Value value) -> E.SqlExpr (E.Value value') instance (PersistEntity val, PersistField typ) => SqlProject val typ (E.Entity val) typ where sqlProject = (E.^.) unSqlProject _ _ = id + unSqlProjectExpr _ _ = id instance (PersistEntity val, PersistField typ) => SqlProject val typ (Maybe (E.Entity val)) (Maybe typ) where sqlProject = (E.?.) unSqlProject _ _ = Just + unSqlProjectExpr _ _ = E.just infixl 8 ->. diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index 78578b9ed..5beab5f26 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -226,11 +226,14 @@ embedRenderMessage ''UniWorX ''ExamOnlinePreset id embedRenderMessage ''UniWorX ''ExamSynchronicityPreset id embedRenderMessage ''UniWorX ''ExamRequiredEquipmentPreset id embedRenderMessage ''UniWorX ''ChangelogItemKind id +embedRenderMessage ''UniWorX ''RoomReference' $ dropSuffix "'" embedRenderMessage ''UniWorX ''AuthenticationMode id embedRenderMessage ''UniWorX ''RatingValidityException id +embedRenderMessage ''UniWorX ''UrlFieldMessage id + embedRenderMessageVariant ''UniWorX ''ADInvalidCredentials ("InvalidCredentials" <>) newtype ShortSex = ShortSex Sex diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 54590756e..5c58a0385 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -35,7 +35,7 @@ data CourseForm = CourseForm , cfSchool :: SchoolId , cfTerm :: TermId , cfDesc :: Maybe StoredMarkup - , cfLink :: Maybe Text + , cfLink :: Maybe URI , cfVisFrom :: Maybe UTCTime , cfVisTo :: Maybe UTCTime , cfMatFree :: Bool @@ -292,7 +292,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB <*> areq termsField (fslI MsgCourseSemester) (cfTerm <$> template) <*> aopt htmlField (fslpI MsgCourseDescription (mr MsgCourseDescriptionPlaceholder)) (cfDesc <$> template) - <*> aopt (urlField & cfStrip) (fslpI MsgCourseHomepageExternal (mr MsgCourseHomepageExternalPlaceholder)) + <*> aopt urlField (fslpI MsgCourseHomepageExternal (mr MsgCourseHomepageExternalPlaceholder)) (cfLink <$> template) <*> aopt utcTimeField (fslpI MsgCourseVisibleFrom (mr MsgDate) & setTooltip MsgCourseVisibleFromTip) (deepAlt (cfVisFrom <$> template) newVisFrom) diff --git a/src/Handler/Course/Events/Delete.hs b/src/Handler/Course/Events/Delete.hs index 3dd5d06fb..65c742bbf 100644 --- a/src/Handler/Course/Events/Delete.hs +++ b/src/Handler/Course/Events/Delete.hs @@ -27,7 +27,8 @@ postCEvDeleteR tid ssh csh cID = do [whamlet| $newline never #{courseEventType} - , #{courseEventRoom} + $maybe room <- courseEventRoom + , #{roomReferenceText room} : ^{occurrencesWidget courseEventTime} |] diff --git a/src/Handler/Course/Events/Edit.hs b/src/Handler/Course/Events/Edit.hs index 0dcfaa30a..19390889d 100644 --- a/src/Handler/Course/Events/Edit.hs +++ b/src/Handler/Course/Events/Edit.hs @@ -23,6 +23,7 @@ postCEvEditR tid ssh csh cID = do { courseEventCourse , courseEventType = cefType , courseEventRoom = cefRoom + , courseEventRoomHidden = cefRoomHidden , courseEventTime = cefTime , courseEventNote = cefNote , courseEventLastChanged = now diff --git a/src/Handler/Course/Events/Form.hs b/src/Handler/Course/Events/Form.hs index be55771dd..1f3eb88bc 100644 --- a/src/Handler/Course/Events/Form.hs +++ b/src/Handler/Course/Events/Form.hs @@ -13,7 +13,8 @@ import qualified Database.Esqueleto as E data CourseEventForm = CourseEventForm { cefType :: CI Text - , cefRoom :: Text + , cefRoom :: Maybe RoomReference + , cefRoomHidden :: Bool , cefTime :: Occurrences , cefNote :: Maybe StoredMarkup } @@ -30,16 +31,17 @@ courseEventForm template = identifyForm FIDCourseEvent . renderWForm FormStandar return event ) let courseEventTypes = optionsPairs [ (courseEventType, courseEventType) | Entity _ CourseEvent{..} <- existingEvents ] - courseEventRooms = optionsPairs [ (courseEventRoom, courseEventRoom) | Entity _ CourseEvent{..} <- existingEvents ] cefType' <- wreq (textField & cfStrip & cfCI & addDatalist courseEventTypes) (fslI MsgCourseEventType & addPlaceholder (mr MsgCourseEventTypePlaceholder)) (cefType <$> template) - cefRoom' <- wreq (textField & cfStrip & addDatalist courseEventRooms) (fslI MsgCourseEventRoom) (cefRoom <$> template) + cefRoom' <- aFormToWForm $ roomReferenceFormOpt (fslI MsgCourseEventRoom) (cefRoom <$> template) + cefRoomHidden' <- wpopt checkBoxField (fslI MsgCourseEventRoomHidden & setTooltip MsgCourseEventRoomHiddenTip) (cefRoomHidden <$> template) cefTime' <- aFormToWForm $ occurrencesAForm ("time" :: Text) (cefTime <$> template) cefNote' <- wopt htmlField (fslI MsgCourseEventNote) (cefNote <$> template) return $ CourseEventForm <$> cefType' <*> cefRoom' + <*> cefRoomHidden' <*> cefTime' <*> cefNote' @@ -47,6 +49,7 @@ courseEventToForm :: CourseEvent -> CourseEventForm courseEventToForm CourseEvent{..} = CourseEventForm { cefType = courseEventType , cefRoom = courseEventRoom + , cefRoomHidden = courseEventRoomHidden , cefTime = courseEventTime , cefNote = courseEventNote } diff --git a/src/Handler/Course/Events/New.hs b/src/Handler/Course/Events/New.hs index b389de9de..d2800db1e 100644 --- a/src/Handler/Course/Events/New.hs +++ b/src/Handler/Course/Events/New.hs @@ -21,6 +21,7 @@ postCEventsNewR tid ssh csh = do { courseEventCourse = cid , courseEventType = cefType , courseEventRoom = cefRoom + , courseEventRoomHidden = cefRoomHidden , courseEventTime = cefTime , courseEventNote = cefNote , courseEventLastChanged = now diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index 67fe5e06a..022a35559 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -8,14 +8,16 @@ import Import import Utils.Course import Utils.Form import Handler.Utils -import qualified Database.Esqueleto.Utils as E -import Database.Esqueleto.Utils.TH +import Handler.Utils.Course +import Handler.Utils.Tutorial import qualified Data.CaseInsensitive as CI import qualified Data.Map as Map import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E +import Database.Esqueleto.Utils.TH import Handler.Course.Register @@ -93,8 +95,10 @@ getCShowR tid ssh csh = do return (cID, n, visible, files, lastEditText, mayEditNews, mayDelete) - events' <- fmap (sortOn $ courseEventTime . entityVal) . lift $ selectList [ CourseEventCourse ==. cid ] [] - events <- mapM (\(Entity evId ev) -> (, ev) <$> encrypt evId) events' + events' <- fmap (sortOn $ courseEventTime . entityVal . view _1) . lift . E.select . E.from $ \courseEvent -> do + E.where_ $ courseEvent E.^. CourseEventCourse E.==. E.val cid + return (courseEvent, maybe E.false (flip showCourseEventRoom courseEvent . E.val) mbAid) + events <- mapM (\(Entity evId ev, E.Value showRoom) -> (, ev, showRoom) <$> encrypt evId) events' hasSubmissionGroups <- lift . E.selectExists . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup) -> do E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId @@ -147,15 +151,19 @@ getCShowR tid ssh csh = do let tutorialDBTable = DBTable{..} where + resultTutorial :: Lens' (DBRow (Entity Tutorial, Bool)) (Entity Tutorial) + resultTutorial = _dbrOutput . _1 + resultShowRoom = _dbrOutput . _2 + dbtSQLQuery tutorial = do E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid - return tutorial + return (tutorial, maybe E.false (flip showTutorialRoom tutorial . E.val) mbAid) dbtRowKey = (E.^. TutorialId) - dbtProj = return + dbtProj = traverse $ return . over _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{..} } -> indicatorCell <> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|] - , sortable (Just "tutors") (i18nCell MsgTutorialTutors) $ \DBRow{ dbrOutput = Entity tutid _ } -> sqlCell $ do + [ sortable (Just "type") (i18nCell MsgTutorialType) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> textCell $ CI.original tutorialType + , sortable (Just "name") (i18nCell MsgTutorialName) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> indicatorCell <> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|] + , sortable (Just "tutors") (i18nCell MsgTutorialTutors) $ \(view $ resultTutorial . _entityKey -> tutid) -> sqlCell $ do tutTutors <- 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 @@ -167,12 +175,14 @@ getCShowR tid ssh csh = do
  • ^{nameEmailWidget' tutor} |] - , sortable (Just "room") (i18nCell MsgTutorialRoom) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> maybe mempty textCell tutorialRoom - , sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> occurrencesCell 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 (i18nCell MsgTutorialFreeCapacity) $ \DBRow{ dbrOutput = Entity tutid Tutorial{..} } -> case tutorialCapacity of + , sortable (Just "room") (i18nCell MsgTutorialRoom) $ \res -> if + | res ^. resultShowRoom -> maybe (i18nCell MsgTutorialRoomIsUnset) roomReferenceCell $ views (resultTutorial . _entityVal) tutorialRoom res + | otherwise -> i18nCell MsgTutorialRoomIsHidden & addCellClass ("explanation" :: Text) + , sortable Nothing (i18nCell MsgTutorialTime) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> occurrencesCell tutorialTime + , sortable (Just "register-from") (i18nCell MsgTutorialRegisterFrom) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialRegisterFrom + , sortable (Just "register-to") (i18nCell MsgTutorialRegisterTo) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialRegisterTo + , sortable (Just "deregister-until") (i18nCell MsgTutorialDeregisterUntil) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialDeregisterUntil + , sortable Nothing (i18nCell MsgTutorialFreeCapacity) $ \(view resultTutorial -> Entity tutid Tutorial{..}) -> case tutorialCapacity of Nothing -> mempty Just tutorialCapacity' -> sqlCell $ do freeCapacity <- fmap (maybe 0 (max 0 . E.unValue) . listToMaybe) @@ -181,7 +191,7 @@ getCShowR tid ssh csh = do E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid in return $ E.val tutorialCapacity' E.-. numParticipants return . toWidget $ tshow freeCapacity - , sortable Nothing (mempty & cellAttrs <>~ pure ("uw-hide-columns--hider-label", mr MsgActionsHead)) $ \DBRow{ dbrOutput = Entity tutId Tutorial{..} } -> sqlCell $ do + , sortable Nothing (mempty & cellAttrs <>~ pure ("uw-hide-columns--hider-label", mr MsgActionsHead)) $ \(view resultTutorial -> Entity tutId Tutorial{..}) -> sqlCell $ do mayRegister <- (== Authorized) <$> evalAccessDB (CTutorialR tid ssh csh tutorialName TRegisterR) True isRegistered <- case mbAid of Nothing -> return False @@ -232,7 +242,7 @@ getCShowR tid ssh csh = do , length fs <= 3 , all (notElem pathSeparator . view _2) fs ] - hiddenEventNotes = all (\(_,CourseEvent{..}) -> is _Nothing courseEventNote) events + hiddenEventNotes = all (\(_,CourseEvent{..},_) -> is _Nothing courseEventNote) events Course{courseVisibleFrom,courseVisibleTo} = course mayCreateNews <- hasWriteAccessTo $ CourseR tid ssh csh CNewsNewR mayCreateEvents <- hasWriteAccessTo $ CourseR tid ssh csh CEventsNewR diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index f8147faf4..c9a5e2217 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -460,7 +460,7 @@ courseUserTutorialsSection (Entity cid Course{..}) (Entity uid _) = do
  • ^{nameEmailWidget userEmail userDisplayName userSurname} |] - , sortable (Just "room") (i18nCell MsgTutorialRoom) $ maybe mempty textCell . view (_dbrOutput . _1 . _entityVal . _tutorialRoom) + , sortable (Just "room") (i18nCell MsgTutorialRoom) $ maybe (i18nCell MsgTutorialRoomIsUnset) roomReferenceCell . view (_dbrOutput . _1 . _entityVal . _tutorialRoom) , sortable Nothing (i18nCell MsgTutorialTime) $ occurrencesCell . view (_dbrOutput . _1 . _entityVal . _tutorialTime) ] dbtSorting = mconcat diff --git a/src/Handler/Exam/Edit.hs b/src/Handler/Exam/Edit.hs index 8a6e43a91..7f46d7a58 100644 --- a/src/Handler/Exam/Edit.hs +++ b/src/Handler/Exam/Edit.hs @@ -59,6 +59,7 @@ postEEditR tid ssh csh examn = do { examOccurrenceExam = eId , examOccurrenceName = eofName , examOccurrenceRoom = eofRoom + , examOccurrenceRoomHidden = eofRoomHidden , examOccurrenceCapacity = eofCapacity , examOccurrenceStart = eofStart , examOccurrenceEnd = eofEnd @@ -73,6 +74,7 @@ postEEditR tid ssh csh examn = do { examOccurrenceExam = eId , examOccurrenceName = eofName , examOccurrenceRoom = eofRoom + , examOccurrenceRoomHidden = eofRoomHidden , examOccurrenceCapacity = eofCapacity , examOccurrenceStart = eofStart , examOccurrenceEnd = eofEnd diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs index 5b909d779..ffa654531 100644 --- a/src/Handler/Exam/Form.hs +++ b/src/Handler/Exam/Form.hs @@ -54,12 +54,13 @@ data ExamForm = ExamForm data ExamOccurrenceForm = ExamOccurrenceForm { eofId :: Maybe CryptoUUIDExamOccurrence , eofName :: ExamOccurrenceName - , eofRoom :: Text + , eofRoom :: Maybe RoomReference + , eofRoomHidden :: Bool , eofCapacity :: Natural , eofStart :: UTCTime , eofEnd :: Maybe UTCTime , eofDescription :: Maybe StoredMarkup - } deriving (Read, Show, Eq, Generic, Typeable) + } deriving (Show, Eq, Generic, Typeable) instance Ord ExamOccurrenceForm where compare = mconcat @@ -69,6 +70,7 @@ instance Ord ExamOccurrenceForm where , comparing eofEnd , comparing eofCapacity , comparing eofDescription + , comparing eofRoomHidden , comparing eofId ] @@ -221,7 +223,11 @@ examOccurrenceForm prev = wFormToAForm $ do examOccurrenceForm' nudge mPrev csrf = do (eofIdRes, eofIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ eofId =<< mPrev) (eofNameRes, eofNameView) <- mpreq (textField & cfStrip & cfCI) (fslI MsgExamRoomName & addName (nudge "name")) (eofName <$> mPrev) - (eofRoomRes, eofRoomView) <- mpreq (textField & cfStrip) (fslI MsgExamRoomRoom & addName (nudge "room")) (eofRoom <$> mPrev) + (eofRoomRes', eofRoomView) <- ($ mempty) . renderAForm FormVertical $ (,) + <$> roomReferenceFormOpt (fslI MsgExamRoomRoom & addName (nudge "room")) (eofRoom <$> mPrev) + <*> apopt checkBoxField (fslI MsgExamRoomRoomHidden & setTooltip MsgExamRoomRoomHiddenTip & addName (nudge "room-hidden")) (eofRoomHidden <$> mPrev) + let eofRoomRes = view _1 <$> eofRoomRes' + eofRoomHiddenRes = view _2 <$> eofRoomRes' (eofCapacityRes, eofCapacityView) <- mpreq (natFieldI MsgExamRoomCapacityNegative) (fslI MsgExamRoomCapacity & addName (nudge "capacity")) (eofCapacity <$> mPrev) (eofStartRes, eofStartView) <- mpreq utcTimeField (fslI MsgExamRoomStart & addName (nudge "start")) (eofStart <$> mPrev) (eofEndRes, eofEndView) <- mopt utcTimeField (fslI MsgExamRoomEnd & addName (nudge "end")) (eofEnd <$> mPrev) @@ -231,6 +237,7 @@ examOccurrenceForm prev = wFormToAForm $ do <$> eofIdRes <*> eofNameRes <*> eofRoomRes + <*> eofRoomHiddenRes <*> eofCapacityRes <*> eofStartRes <*> eofEndRes @@ -327,6 +334,7 @@ examFormTemplate (Entity eId Exam{..}) = do { eofId , eofName = examOccurrenceName , eofRoom = examOccurrenceRoom + , eofRoomHidden = examOccurrenceRoomHidden , eofCapacity = examOccurrenceCapacity , eofStart = examOccurrenceStart , eofEnd = examOccurrenceEnd @@ -429,7 +437,8 @@ validateExam cId oldExam = do forM_ [ (a, b) | a <- Set.toAscList efOccurrences, b <- Set.toAscList efOccurrences, b > a ] $ \(a, b) -> do eofRange' <- formatTimeRange SelFormatDateTime (eofStart a) (eofEnd a) - guardValidation (MsgExamOccurrenceDuplicate (eofRoom a) eofRange') $ any (\f -> f a b) + MsgRenderer mr <- getMsgRenderer + guardValidation (MsgExamOccurrenceDuplicate (maybe (mr MsgExamOccurrenceRoomIsUnset) roomReferenceText $ eofRoom a) eofRange') $ any (\f -> f a b) [ (/=) `on` eofRoom , (/=) `on` eofStart , (/=) `on` eofEnd diff --git a/src/Handler/Exam/New.hs b/src/Handler/Exam/New.hs index f4f313fef..5961f0187 100644 --- a/src/Handler/Exam/New.hs +++ b/src/Handler/Exam/New.hs @@ -68,6 +68,7 @@ postCExamNewR tid ssh csh = do , let examOccurrenceExam = examid examOccurrenceName = eofName examOccurrenceRoom = eofRoom + examOccurrenceRoomHidden = eofRoomHidden examOccurrenceCapacity = eofCapacity examOccurrenceStart = eofStart examOccurrenceEnd = eofEnd diff --git a/src/Handler/Exam/Show.hs b/src/Handler/Exam/Show.hs index 65439d72d..0540e10ce 100644 --- a/src/Handler/Exam/Show.hs +++ b/src/Handler/Exam/Show.hs @@ -66,20 +66,20 @@ getEShowR tid ssh csh examn = do E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eId E.&&. examRegistration E.^. ExamRegistrationOccurrence E.==. E.just (examOccurrence E.^. ExamOccurrenceId) E.orderBy [E.desc registered, E.asc $ examOccurrence E.^. ExamOccurrenceStart, E.asc $ examOccurrence E.^. ExamOccurrenceRoom] - return (examOccurrence, registered, registeredCount) + return (examOccurrence, registered, registeredCount, maybe E.false (flip showExamOccurrenceRoom examOccurrence . E.val) mUid) registeredCount <- fromIntegral <$> count [ ExamRegistrationExam ==. eId ] registered <- for mUid $ getBy . UniqueExamRegistration eId mayRegister <- if - | examOccurrenceRule == ExamRoomFifo -> anyM occurrencesRaw $ \(Entity _ ExamOccurrence{..}, _, _) -> + | examOccurrenceRule == ExamRoomFifo -> anyM occurrencesRaw $ \(Entity _ ExamOccurrence{..}, _, _, _) -> hasWriteAccessTo . CExamR tid ssh csh examName $ ERegisterOccR examOccurrenceName | otherwise -> hasWriteAccessTo $ CExamR tid ssh csh examName ERegisterR - let occurrences = sortOn sortPred $ map (over _3 E.unValue . over _2 E.unValue) occurrencesRaw + let occurrences = sortOn sortPred $ map (over _4 E.unValue . over _3 E.unValue . over _2 E.unValue) occurrencesRaw where - sortPred (Entity _ ExamOccurrence{..}, registered', _) - = (Down $ registered' && not mayRegister, examOccurrenceStart, examOccurrenceRoom) + sortPred (Entity _ ExamOccurrence{..}, registered', _, showRoom) + = (Down $ registered' && not mayRegister, examOccurrenceStart, guardOn @Maybe showRoom examOccurrenceRoom) lecturerInfoShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR @@ -118,14 +118,15 @@ getEShowR tid ssh csh examn = do mayRegister' <- fmap ((Map.!) . Map.fromList) . for (Nothing : map Just occurrences) $ \case Nothing -> fmap (Nothing, ) . hasWriteAccessTo $ CExamR tid ssh csh examName ERegisterR - Just (Entity occId ExamOccurrence{..}, _, _) -> + Just (Entity occId ExamOccurrence{..}, _, _, _) -> fmap (Just occId, ) . hasWriteAccessTo . CExamR tid ssh csh examName $ ERegisterOccR examOccurrenceName - let examTimes = all (\(Entity _ ExamOccurrence{..}, _, _) -> Just examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences + let examTimes = all (\(Entity _ ExamOccurrence{..}, _, _, _) -> Just examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences examRoom = do - Entity _ primeOcc <- occurrences ^? _head . _1 - guard $ all (\(Entity _ occ, _, _) -> examOccurrenceRoom occ == examOccurrenceRoom primeOcc) occurrences - return $ examOccurrenceRoom primeOcc + (Entity _ primeOcc, _, _, _) <- occurrences ^? _head + guard $ all (\(Entity _ occ, _, _, _) -> examOccurrenceRoom occ == examOccurrenceRoom primeOcc) occurrences + guard $ andOf (folded . _4) occurrences + examOccurrenceRoom primeOcc registerWidget mOcc | isRegistered <- is _Just $ join registered , examOccurrenceRule /= ExamRoomFifo || (isRegistered && not (orOf (folded . _2) occurrences)) diff --git a/src/Handler/News.hs b/src/Handler/News.hs index f21875ab3..805f46e0c 100644 --- a/src/Handler/News.hs +++ b/src/Handler/News.hs @@ -18,6 +18,8 @@ import qualified Data.Conduit.Lift as C import qualified Data.HashMap.Strict as HashMap +import Handler.Utils.Exam (showExamOccurrenceRoom) + getNewsR :: Handler Html getNewsR = do @@ -217,6 +219,7 @@ newsUpcomingExams uid = do lensExam = _2 lensRegister = _3 . _Just lensOccurrence = _4 . _Just + lensShowRoom = _5 . _Value dbtSQLQuery ((course `E.InnerJoin` exam) `E.LeftOuterJoin` register `E.LeftOuterJoin` occurrence) = do E.on $ register E.?. ExamRegistrationOccurrence E.==. E.just (occurrence E.?. ExamOccurrenceId) @@ -244,7 +247,7 @@ newsUpcomingExams uid = do E.&&. earliestOccurrence E.<=. E.just (E.val fortnight) -- E.&&. earliestOccurrence E.>=. E.just (E.val now) E.where_ $ regToWithinFortnight E.||. startExamFortnight E.||. startOccurFortnight E.||. startEarliest - return (course, exam, register, occurrence) + return (course, exam, register, occurrence, showExamOccurrenceRoom (E.val uid) occurrence) dbtRowKey = queryExam >>> (E.^. ExamId) dbtProj = return dbtColonnade = dbColonnade $ mconcat @@ -296,7 +299,8 @@ newsUpcomingExams uid = do | otherwise -> return [whamlet|_{label}|] , sortable (toNothingS "occurrence") (i18nCell MsgExamOccurrence) $ \DBRow{ dbrOutput } -> if | Just (Entity _ ExamOccurrence{..}) <- preview lensOccurrence dbrOutput - -> textCell examOccurrenceRoom + -> if | view lensShowRoom dbrOutput -> maybe (i18nCell MsgExamOccurrenceRoomIsUnset) roomReferenceCell examOccurrenceRoom + | otherwise -> i18nCell MsgExamOccurrenceRoomIsHidden & addCellClass ("explanation" :: Text) | otherwise -> mempty ] dbtSorting = Map.fromList diff --git a/src/Handler/Tutorial/Edit.hs b/src/Handler/Tutorial/Edit.hs index d15dc1c76..753685c26 100644 --- a/src/Handler/Tutorial/Edit.hs +++ b/src/Handler/Tutorial/Edit.hs @@ -35,6 +35,7 @@ postTEditR tid ssh csh tutn = do , tfType = tutorialType , tfCapacity = tutorialCapacity , tfRoom = tutorialRoom + , tfRoomHidden = tutorialRoomHidden , tfTime = tutorialTime , tfRegGroup = tutorialRegGroup , tfRegisterFrom = tutorialRegisterFrom @@ -58,6 +59,7 @@ postTEditR tid ssh csh tutn = do , tutorialType = tfType , tutorialCapacity = tfCapacity , tutorialRoom = tfRoom + , tutorialRoomHidden = tfRoomHidden , tutorialTime = tfTime , tutorialRegGroup = tfRegGroup , tutorialRegisterFrom = tfRegisterFrom diff --git a/src/Handler/Tutorial/Form.hs b/src/Handler/Tutorial/Form.hs index 4b7aed8a2..c9596da7b 100644 --- a/src/Handler/Tutorial/Form.hs +++ b/src/Handler/Tutorial/Form.hs @@ -21,7 +21,8 @@ data TutorialForm = TutorialForm , tfRegGroup :: Maybe (CI Text) , tfTutorControlled :: Bool , tfCapacity :: Maybe Int - , tfRoom :: Maybe Text + , tfRoom :: Maybe RoomReference + , tfRoomHidden :: Bool , tfTime :: Occurrences , tfRegisterFrom :: Maybe UTCTime , tfRegisterTo :: Maybe UTCTime @@ -70,7 +71,8 @@ tutorialForm cid template html = do <*> aopt (textField & cfStrip & cfCI) (fslI MsgTutorialRegGroup & setTooltip MsgTutorialRegGroupTip) ((tfRegGroup <$> template) <|> Just (Just "tutorial")) <*> apopt checkBoxField (fslI MsgTutorialTutorControlled & setTooltip MsgTutorialTutorControlledTip) (tfTutorControlled <$> template) <*> aopt (natFieldI MsgTutorialCapacityNonPositive) (fslpI MsgTutorialCapacity (mr MsgTutorialCapacity) & setTooltip MsgTutorialCapacityTip) (tfCapacity <$> template) - <*> (assertM (not . null) <$> aopt (textField & cfStrip) (fslpI MsgTutorialRoom $ mr MsgTutorialRoomPlaceholder) (tfRoom <$> template)) + <*> roomReferenceFormOpt (fslI MsgTutorialRoom) (tfRoom <$> template) + <*> apopt checkBoxField (fslI MsgTutorialRoomHidden & setTooltip MsgTutorialRoomHiddenTip) (tfRoomHidden <$> template <|> Just False) <*> occurrencesAForm ("occurrences" :: Text) (tfTime <$> template) <*> aopt utcTimeField (fslpI MsgRegisterFrom (mr MsgDate) & setTooltip MsgCourseRegisterFromTip diff --git a/src/Handler/Tutorial/List.hs b/src/Handler/Tutorial/List.hs index 1a2a3ffb8..aea23a3a9 100644 --- a/src/Handler/Tutorial/List.hs +++ b/src/Handler/Tutorial/List.hs @@ -4,8 +4,10 @@ module Handler.Tutorial.List import Import import Handler.Utils +import Handler.Utils.Tutorial import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH import qualified Data.Map as Map @@ -15,24 +17,30 @@ import qualified Data.CaseInsensitive as CI getCTutorialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCTutorialListR tid ssh csh = do + muid <- maybeAuthId cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh MsgRenderer mr <- getMsgRenderer let tutorialDBTable = DBTable{..} where + resultTutorial :: Lens' (DBRow (Entity Tutorial, Int, Bool)) (Entity Tutorial) + resultTutorial = _dbrOutput . _1 + resultParticipants = _dbrOutput . _2 + resultShowRoom = _dbrOutput . _3 + dbtSQLQuery tutorial = do E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid let participants :: E.SqlExpr (E.Value Int) participants = E.subSelectCount . E.from $ \tutorialParticipant -> E.where_ $ tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId - return (tutorial, participants) + return (tutorial, participants, maybe E.false (flip showTutorialRoom tutorial . E.val) muid) dbtRowKey = (E.^. TutorialId) - dbtProj = return . over (_dbrOutput . _2) E.unValue + dbtProj = return . over (_dbrOutput . _2) E.unValue . over (_dbrOutput . _3) 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{..}, _) } -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|] - , sortable Nothing (i18nCell MsgTutorialTutors) $ \DBRow{ dbrOutput = (Entity tutid _, _) } -> sqlCell $ do + [ sortable (Just "type") (i18nCell MsgTutorialType) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> textCell $ CI.original tutorialType + , sortable (Just "name") (i18nCell MsgTutorialName) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|] + , sortable Nothing (i18nCell MsgTutorialTutors) $ \(view $ resultTutorial . _entityKey -> 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 @@ -44,15 +52,17 @@ getCTutorialListR tid ssh csh = do
  • ^{nameEmailWidget' tutor} |] - , sortable (Just "participants") (i18nCell MsgTutorialParticipants) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, n) } -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) $ 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{..}, _) } -> maybe mempty textCell tutorialRoom - , sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> occurrencesCell tutorialTime - , sortable (Just "register-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 & cellAttrs <>~ pure ("uw-hide-columns--hider-label", mr MsgActionsHead)) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> cell $ do + , sortable (Just "participants") (i18nCell MsgTutorialParticipants) $ \(view $ $(multifocusL 2) (resultTutorial . _entityVal) resultParticipants -> (Tutorial{..}, n)) -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) $ tshow n + , sortable (Just "capacity") (i18nCell MsgTutorialCapacity) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybe mempty (textCell . tshow) tutorialCapacity + , sortable (Just "room") (i18nCell MsgTutorialRoom) $ \res -> if + | res ^. resultShowRoom -> maybe (i18nCell MsgTutorialRoomIsUnset) roomReferenceCell $ views (resultTutorial . _entityVal) tutorialRoom res + | otherwise -> i18nCell MsgTutorialRoomIsHidden & addCellClass ("explanation" :: Text) + , sortable Nothing (i18nCell MsgTutorialTime) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> occurrencesCell tutorialTime + , sortable (Just "register-group") (i18nCell MsgTutorialRegGroup) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybe mempty (textCell . CI.original) tutorialRegGroup + , sortable (Just "register-from") (i18nCell MsgTutorialRegisterFrom) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialRegisterFrom + , sortable (Just "register-to") (i18nCell MsgTutorialRegisterTo) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialRegisterTo + , sortable (Just "deregister-until") (i18nCell MsgTutorialDeregisterUntil) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> maybeDateTimeCell tutorialDeregisterUntil + , sortable Nothing (mempty & cellAttrs <>~ pure ("uw-hide-columns--hider-label", mr MsgActionsHead)) $ \(view $ resultTutorial . _entityVal -> Tutorial{..}) -> cell $ do linkButton mempty [whamlet|_{MsgTutorialEdit}|] [BCIsButton] . SomeRoute $ CTutorialR tid ssh csh tutorialName TEditR linkButton mempty [whamlet|_{MsgTutorialDelete}|] [BCIsButton, BCDanger] . SomeRoute $ CTutorialR tid ssh csh tutorialName TDeleteR ] diff --git a/src/Handler/Tutorial/New.hs b/src/Handler/Tutorial/New.hs index da9ca7f16..728e264ec 100644 --- a/src/Handler/Tutorial/New.hs +++ b/src/Handler/Tutorial/New.hs @@ -29,6 +29,7 @@ postCTutorialNewR tid ssh csh = do , tutorialType = tfType , tutorialCapacity = tfCapacity , tutorialRoom = tfRoom + , tutorialRoomHidden = tfRoomHidden , tutorialTime = tfTime , tutorialRegGroup = tfRegGroup , tutorialRegisterFrom = tfRegisterFrom diff --git a/src/Handler/Utils/Course.hs b/src/Handler/Utils/Course.hs index c3f39056e..bc4e3ce48 100644 --- a/src/Handler/Utils/Course.hs +++ b/src/Handler/Utils/Course.hs @@ -4,6 +4,7 @@ import Import import Handler.Utils.Delete import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E import qualified Data.Set as Set @@ -70,3 +71,28 @@ setUsersSubmissionGroup cid uids (Just grp) = do when didSet $ audit $ TransactionSubmissionGroupSet cid uid grp return $ bool mempty (Sum 1) didSet + +showCourseEventRoom :: forall courseEvent courseId. + E.SqlProject CourseEvent CourseId courseEvent courseId + => E.SqlExpr (E.Value UserId) -> E.SqlExpr courseEvent -> E.SqlExpr (E.Value Bool) +showCourseEventRoom uid courseEvent = E.or + [ E.exists . E.from $ \(tutor `E.InnerJoin` tutorial) -> do + E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial + E.where_ $ tutor E.^. TutorUser E.==. uid + E.&&. E.unSqlProjectExpr (Proxy @CourseEvent) (Proxy @courseEvent) (tutorial E.^. TutorialCourse) E.==. courseEvent `E.sqlProject` CourseEventCourse + , E.exists . E.from $ \(sheetCorrector `E.InnerJoin` sheet) -> do + E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet + E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. uid + E.&&. E.unSqlProjectExpr (Proxy @CourseEvent) (Proxy @courseEvent) (sheet E.^. SheetCourse) E.==. courseEvent `E.sqlProject` CourseEventCourse + , E.exists . E.from $ \(examCorrector `E.InnerJoin` exam) -> do + E.on $ exam E.^. ExamId E.==. examCorrector E.^. ExamCorrectorExam + E.where_ $ examCorrector E.^. ExamCorrectorUser E.==. uid + E.&&. E.unSqlProjectExpr (Proxy @CourseEvent) (Proxy @courseEvent) (exam E.^. ExamCourse) E.==. courseEvent `E.sqlProject` CourseEventCourse + , E.exists . E.from $ \courseParticipant -> + E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive + E.&&. courseParticipant E.^. CourseParticipantUser E.==. uid + E.&&. E.unSqlProjectExpr (Proxy @CourseEvent) (Proxy @courseEvent) (courseParticipant E.^. CourseParticipantCourse) E.==. courseEvent `E.sqlProject` CourseEventCourse + , E.exists . E.from $ \lecturer -> + E.where_ $ lecturer E.^. LecturerUser E.==. uid + E.&&. E.unSqlProjectExpr (Proxy @CourseEvent) (Proxy @courseEvent) (lecturer E.^. LecturerCourse) E.==. courseEvent `E.sqlProject` CourseEventCourse + ] diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index 1071cc435..e8e4590ff 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -13,6 +13,7 @@ module Handler.Utils.Exam , deregisterExamUsersCount, deregisterExamUsers , examAidsPresetWidget, examOnlinePresetWidget, examSynchronicityPresetWidget, examRequiredEquipmentPresetWidget , evalExamModeDNF + , showExamOccurrenceRoom ) where import Import @@ -680,3 +681,22 @@ evalExamModeDNF (ExamModeDNF PredDNF{..}) ExamMode{..} -> examSynchronicity == Just (ExamSynchronicityPreset p) ExamModePredRequiredEquipment p -> examRequiredEquipment == Just (ExamRequiredEquipmentPreset p) + +showExamOccurrenceRoom :: forall examOccurrence examOccurrenceId examId. + ( E.SqlProject ExamOccurrence ExamOccurrenceId examOccurrence examOccurrenceId + , E.SqlProject ExamOccurrence ExamId examOccurrence examId + ) + => E.SqlExpr (E.Value UserId) -> E.SqlExpr examOccurrence -> E.SqlExpr (E.Value Bool) +showExamOccurrenceRoom uid occurrence = E.or + [ E.exists . E.from $ \register -> + E.where_ $ register E.^. ExamRegistrationUser E.==. uid + E.&&. E.maybe E.false (\occId -> E.unSqlProjectExpr (Proxy @ExamOccurrence) (Proxy @examOccurrence) occId E.==. occurrence `E.sqlProject` ExamOccurrenceId) (register E.^. ExamRegistrationOccurrence) + , E.exists . E.from $ \(lecturer `E.InnerJoin` course `E.InnerJoin` exam) -> do + E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse + E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId + E.where_ $ lecturer E.^. LecturerUser E.==. uid + E.&&. E.unSqlProjectExpr (Proxy @ExamOccurrence) (Proxy @examOccurrence) (exam E.^. ExamId) E.==. occurrence `E.sqlProject` ExamOccurrenceExam + , E.exists . E.from $ \examCorrector -> + E.where_ $ examCorrector E.^. ExamCorrectorUser E.==. uid + E.&&. E.unSqlProjectExpr (Proxy @ExamOccurrence) (Proxy @examOccurrence) (examCorrector E.^. ExamCorrectorExam) E.==. occurrence `E.sqlProject` ExamOccurrenceExam + ] diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 4a7f6ec8b..7f2e2f3ba 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -2175,3 +2175,50 @@ allocationPriorityForm fs mPrev = multiActionA opts fs $ classifyAllocationPrior whenExceptT (null ts) MsgAllocationPriorityNumericNoValues forM ts $ \t' -> maybeExceptT (MsgAllocationPriorityNumericNoParse t') . return $ readMay t' fromInts = Text.intercalate ", " . map tshow . Vector.toList + + +roomReferenceFormOpt :: FieldSettings UniWorX + -> Maybe (Maybe RoomReference) + -> AForm Handler (Maybe RoomReference) +roomReferenceFormOpt = roomReferenceForm' . Just $ SomeMessage MsgRoomReferenceNone + +roomReferenceForm :: FieldSettings UniWorX + -> Maybe RoomReference + -> AForm Handler RoomReference +roomReferenceForm fs mPrev = fmapAForm (maybe FormMissing return =<<) . roomReferenceForm' Nothing fs $ Just <$> mPrev + +roomReferenceForm' :: Maybe (SomeMessage UniWorX) + -> FieldSettings UniWorX + -> Maybe (Maybe RoomReference) + -> AForm Handler (Maybe RoomReference) +roomReferenceForm' noneOpt fs mPrev = multiActionAOpts opts opts' fs $ fmap classifyRoomReference <$> mPrev + where + opts' = do + MsgRenderer mr <- getMsgRenderer + let olOptions = map mkOption . maybe id ((:) . Left) noneOpt $ map Right universeF + where mkOption (Left noneLbl) = Option + { optionDisplay = mr noneLbl + , optionInternalValue = Nothing + , optionExternalValue = "room-none" + } + mkOption (Right v) = Option + { optionDisplay = mr v + , optionInternalValue = Just v + , optionExternalValue = toPathPiece v + } + olReadExternal t | t == "room-none" = Just Nothing + | otherwise = Just <$> fromPathPiece t + return OptionList{..} + opts = mapF $ \case + Nothing -> pure Nothing + Just RoomReferenceSimple' -> wFormToAForm $ do + MsgRenderer mr <- getMsgRenderer + fmap (Just . RoomReferenceSimple) <$> wpreq (textField & cfStrip) (fslI MsgRoomReferenceSimpleText & addPlaceholder (mr MsgRoomReferenceSimpleTextPlaceholder) & maybe id (\n -> addName $ n <> "__text") (fsName fs)) (mPrev ^? _Just . _Just . _roomRefText) + Just RoomReferenceLink' -> wFormToAForm $ do + MsgRenderer mr <- getMsgRenderer + roomRefLink' <- wpreq urlField (fslI MsgRoomReferenceLinkLink & addPlaceholder (mr MsgRoomReferenceLinkLinkPlaceholder) & maybe id (\n -> addName $ n <> "__link") (fsName fs)) (mPrev ^? _Just . _Just . _roomRefLink) + roomRefInstructions' <- wopt htmlField (fslI MsgRoomReferenceLinkInstructions & addPlaceholder (mr MsgRoomReferenceLinkInstructionsPlaceholder) & maybe id (\n -> addName $ n <> "__instructions") (fsName fs)) (mPrev ^? _Just . _Just . _roomRefInstructions) + let res = RoomReferenceLink + <$> roomRefLink' + <*> roomRefInstructions' + return $ Just <$> res diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index dd80f7605..342a7bd18 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -262,3 +262,6 @@ correctorLoadCell sc = occurrencesCell :: IsDBTable m a => Occurrences -> DBCell m a occurrencesCell = cell . occurrencesWidget + +roomReferenceCell :: IsDBTable m a => RoomReference -> DBCell m a +roomReferenceCell = cell . roomReferenceWidget diff --git a/src/Handler/Utils/Tutorial.hs b/src/Handler/Utils/Tutorial.hs index b9c78dd8f..997988914 100644 --- a/src/Handler/Utils/Tutorial.hs +++ b/src/Handler/Utils/Tutorial.hs @@ -1,12 +1,14 @@ module Handler.Utils.Tutorial ( fetchTutorialAux , fetchTutorial, fetchTutorialId, fetchCourseIdTutorialId, fetchCourseIdTutorial + , showTutorialRoom ) where import Import import Database.Persist.Sql (SqlBackendCanRead) import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Internal.Sql as E import Database.Esqueleto.Utils.TH @@ -43,3 +45,21 @@ fetchCourseIdTutorialId tid ssh cid tutn = $(unValueN 2) <$> fetchTutorialAux (\ 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 + +showTutorialRoom :: forall tutorial tutorialId courseId. + ( E.SqlProject Tutorial TutorialId tutorial tutorialId + , E.SqlProject Tutorial CourseId tutorial courseId + ) + => E.SqlExpr (E.Value UserId) -> E.SqlExpr tutorial -> E.SqlExpr (E.Value Bool) +showTutorialRoom uid tutorial = E.or + [ E.exists . E.from $ \tutor -> + E.where_ $ tutor E.^. TutorUser E.==. uid + E.&&. E.unSqlProjectExpr (Proxy @Tutorial) (Proxy @tutorial) (tutor E.^. TutorTutorial) E.==. tutorial `E.sqlProject` TutorialId + , E.exists . E.from $ \(lecturer `E.InnerJoin` course) -> do + E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId + E.where_ $ lecturer E.^. LecturerUser E.==. uid + E.&&. E.unSqlProjectExpr (Proxy @Tutorial) (Proxy @tutorial) (course E.^. CourseId) E.==. tutorial `E.sqlProject` TutorialCourse + , E.exists . E.from $ \tutorialParticipant -> + E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. uid + E.&&. E.unSqlProjectExpr (Proxy @Tutorial) (Proxy @tutorial) (tutorialParticipant E.^. TutorialParticipantTutorial) E.==. tutorial `E.sqlProject` TutorialId + ] diff --git a/src/Handler/Utils/Widgets.hs b/src/Handler/Utils/Widgets.hs index 58da76826..5a5f305dd 100644 --- a/src/Handler/Utils/Widgets.hs +++ b/src/Handler/Utils/Widgets.hs @@ -159,3 +159,11 @@ examOccurrenceMappingDescriptionWidget rule descriptions = $(widgetFile "widgets = False | otherwise = True + + +roomReferenceWidget :: RoomReference -> Widget +roomReferenceWidget RoomReferenceSimple{..} = toWidget roomRefText +roomReferenceWidget RoomReferenceLink{..} = $(widgetFile "widgets/room-reference/link") + where + linkText = uriToString id roomRefLink mempty + instrModal = modal (i18n MsgRoomReferenceLinkInstructions) $ Right $(widgetFile "widgets/room-reference/link-instructions-modal") diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index b86de7350..e4c5c341f 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -12,6 +12,7 @@ import Utils.Frontend.Modal as Import import Utils.Frontend.Notification as Import import Utils.Lens as Import import Utils.Failover as Import +import Utils.Room as Import import Settings as Import import Settings.StaticFiles as Import diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index c9ca60853..764416c1e 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -18,7 +18,7 @@ import ClassyPrelude.Yesod as Import , HasHttpManager(..) , embed , try, embed, catches, handle, catch, bracket, bracketOnError, bracket_, catchJust, finally, handleJust, mask, mask_, onException, tryJust, uninterruptibleMask, uninterruptibleMask_ - , htmlField, fileField + , htmlField, fileField, urlField , mreq, areq, wreq -- Use `mreqMsg`, `areqMsg`, `wreqMsg` , sinkFile, sourceFile ) @@ -133,6 +133,8 @@ import Data.List.PointedList as Import (PointedList) import Language.Haskell.TH.Syntax as Import (Lift(liftTyped)) +import Network.URI as Import (URI, parseURI, uriToString) + import Language.Haskell.TH.Instances as Import () import Data.NonNull.Instances as Import () import Data.Monoid.Instances as Import () @@ -179,6 +181,7 @@ import Control.Monad.Trans.Memo.StateCache.Instances as Import (hoistStateCache) import Database.Persist.Sql.Types.Instances as Import () import Control.Monad.Catch.Instances as Import () import Ldap.Client.Instances as Import () +import Network.URI.Instances as Import () import Crypto.Hash as Import (Digest, SHA3_256, SHA3_512) import Crypto.Random as Import (ChaChaDRG, Seed) diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index c85065220..a0463da74 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -992,6 +992,7 @@ customMigrations = Map.fromListWith (>>) ) , ( AppliedMigrationKey [migrationVersion|43.0.0|] [version|44.0.0|] , [executeQQ| + SET client_min_messages TO WARNING; ALTER TABLE IF EXISTS ^{Allocation} ALTER COLUMN @{AllocationDescription} TYPE jsonb USING (CASE WHEN @{AllocationDescription} IS NOT NULL THEN to_json(@{AllocationDescription}) ELSE NULL END); ALTER TABLE IF EXISTS ^{Allocation} ALTER COLUMN @{AllocationStaffDescription} TYPE jsonb USING (CASE WHEN @{AllocationStaffDescription} IS NOT NULL THEN to_json(@{AllocationStaffDescription}) ELSE NULL END); ALTER TABLE IF EXISTS ^{Course} ALTER COLUMN @{CourseDescription} TYPE jsonb USING (CASE WHEN @{CourseDescription} IS NOT NULL THEN to_json(@{CourseDescription}) ELSE NULL END); @@ -1009,8 +1010,49 @@ customMigrations = Map.fromListWith (>>) ALTER TABLE IF EXISTS ^{SystemMessage} ALTER COLUMN @{SystemMessageSummary} TYPE jsonb USING (CASE WHEN @{SystemMessageSummary} IS NOT NULL THEN to_json(@{SystemMessageSummary}) ELSE NULL END); ALTER TABLE IF EXISTS ^{SystemMessageTranslation} ALTER COLUMN @{SystemMessageTranslationContent} TYPE jsonb USING (CASE WHEN @{SystemMessageTranslationContent} IS NOT NULL THEN to_json(@{SystemMessageTranslationContent}) ELSE NULL END); ALTER TABLE IF EXISTS ^{SystemMessageTranslation} ALTER COLUMN @{SystemMessageTranslationSummary} TYPE jsonb USING (CASE WHEN @{SystemMessageTranslationSummary} IS NOT NULL THEN to_json(@{SystemMessageTranslationSummary}) ELSE NULL END); + SET client_min_messages TO NOTICE; |] ) + , ( AppliedMigrationKey [migrationVersion|44.0.0|] [version|45.0.0|] + , do + whenM (tableExists "exam_occurrence") $ do + [executeQQ|ALTER TABLE "exam_occurrence" ADD COLUMN "room_json" jsonb|] + let getExamOccurrences = [queryQQ|SELECT "id", "room" FROM "exam_occurrence"|] + migrateExamOccurrence [ fromPersistValue -> Right (eoId :: ExamOccurrenceId), fromPersistValue -> Right roomText ] = [executeQQ|UPDATE "exam_occurrence" SET "room_json" = #{RoomReferenceSimple roomText} WHERE "id" = #{eoId}|] + migrateExamOccurrence _ = return () + in runConduit $ getExamOccurrences .| C.mapM_ migrateExamOccurrence + [executeQQ| + ALTER TABLE "exam_occurrence" DROP COLUMN "room"; + ALTER TABLE "exam_occurrence" RENAME COLUMN "room_json" TO "room"; + |] + whenM (tableExists "tutorial") $ do + [executeQQ|ALTER TABLE "tutorial" ADD COLUMN "room_json" jsonb|] + let getTutorials = [queryQQ|SELECT "id", "room" FROM "tutorial"|] + migrateTutorial [ fromPersistValue -> Right (tutId :: TutorialId), fromPersistValue -> Right roomText ] = [executeQQ|UPDATE "tutorial" SET "room_json" = #{RoomReferenceSimple roomText} WHERE "id" = #{tutId}|] + migrateTutorial _ = return () + in runConduit $ getTutorials .| C.mapM_ migrateTutorial + [executeQQ| + ALTER TABLE "tutorial" DROP COLUMN "room"; + ALTER TABLE "tutorial" RENAME COLUMN "room_json" TO "room"; + |] + whenM (tableExists "course_event") $ do + [executeQQ|ALTER TABLE "course_event" ADD COLUMN "room_json" jsonb|] + let getCourseEvents = [queryQQ|SELECT "id", "room" FROM "course_event"|] + migrateCourseEvent [ fromPersistValue -> Right (ceId :: CourseEventId), fromPersistValue -> Right roomText ] = [executeQQ|UPDATE "course_event" SET "room_json" = #{RoomReferenceSimple roomText} WHERE "id" = #{ceId}|] + migrateCourseEvent _ = return () + in runConduit $ getCourseEvents .| C.mapM_ migrateCourseEvent + [executeQQ| + ALTER TABLE "course_event" DROP COLUMN "room"; + ALTER TABLE "course_event" RENAME COLUMN "room_json" TO "room"; + |] + whenM (tableExists "course") $ do + let getCourses = [queryQQ|SELECT "id", "link_external" FROM "course"|] + migrateCourse [ fromPersistValue -> Right (cId :: CourseId), fromPersistValue -> Right (uriText :: Maybe Text) ] + | Just uri <- parseURI . unpack =<< uriText = [executeQQ|UPDATE "course" SET "link_external" = #{uri} WHERE "id" = #{cId}|] + | otherwise = [executeQQ|UPDATE "course" SET "link_external" = NULL WHERE "id" = #{cId}|] + migrateCourse _ = return () + in runConduit $ getCourses .| C.mapM_ migrateCourse + ) ] diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 5c140edbd..92ea6b0ca 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -19,3 +19,4 @@ import Model.Types.File as Types import Model.Types.User as Types import Model.Types.Changelog as Types import Model.Types.Markup as Types +import Model.Types.Room as Types diff --git a/src/Model/Types/Room.hs b/src/Model/Types/Room.hs new file mode 100644 index 000000000..54ec3eda9 --- /dev/null +++ b/src/Model/Types/Room.hs @@ -0,0 +1,40 @@ +module Model.Types.Room + ( RoomReference(..) + , RoomReference'(..), classifyRoomReference + ) where + +import Import.NoModel +import Model.Types.Markup + +import Data.Text.Lens (unpacked) + + +data RoomReference + = RoomReferenceSimple { roomRefText :: Text } + | RoomReferenceLink + { roomRefLink :: URI + , roomRefInstructions :: Maybe StoredMarkup + } + deriving (Eq, Ord, Show, Generic, Typeable) + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 2 + , fieldLabelModifier = camelToPathPiece' 2 + , omitNothingFields = True + } ''RoomReference +derivePersistFieldJSON ''RoomReference + +instance IsString RoomReference where + fromString = RoomReferenceSimple . pack + + +data RoomReference' = RoomReferenceSimple' | RoomReferenceLink' + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) + +nullaryPathPiece ''RoomReference' $ camelToPathPiece' 2 . over unpacked (dropSuffix "'") + +classifyRoomReference :: RoomReference -> RoomReference' +classifyRoomReference = \case + RoomReferenceSimple{} -> RoomReferenceSimple' + RoomReferenceLink{} -> RoomReferenceLink' diff --git a/src/Network/URI/Instances.hs b/src/Network/URI/Instances.hs new file mode 100644 index 000000000..9bd4edbe5 --- /dev/null +++ b/src/Network/URI/Instances.hs @@ -0,0 +1,27 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Network.URI.Instances + ( + ) where + +import ClassyPrelude +import Network.URI +import qualified Data.Aeson as Aeson + +import Control.Monad.Fail (MonadFail(..)) + +import Database.Persist +import Database.Persist.Sql + + +instance Aeson.ToJSON URI where + toJSON = Aeson.String . pack . ($ mempty) . uriToString id +instance Aeson.FromJSON URI where + parseJSON = Aeson.withText "URI" $ maybe (fail "Could not parse URI") return . parseURIReference . unpack + +instance PersistField URI where + toPersistValue = PersistText . pack . ($ mempty) . uriToString id + fromPersistValue (PersistText t) = maybe (Left "Could not parse URI") return . parseURIReference $ unpack t + fromPersistValue v = Left $ "Failed to parse Haskell type `URI`; expected text from database but received: " <> tshow v <> "." +instance PersistFieldSql URI where + sqlType _ = SqlString diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 2fcde1ad3..32d30bd6e 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -4,9 +4,9 @@ module Utils.Form where -import ClassyPrelude.Yesod hiding (addMessage, addMessageI, cons, Proxy(..), identifyForm, addClass, mreq, areq, wreq) +import ClassyPrelude.Yesod hiding (addMessage, addMessageI, cons, Proxy(..), identifyForm, addClass, mreq, areq, wreq, urlField) import Data.Kind (Type) -import qualified Yesod.Form.Functions as Yesod +import qualified Yesod.Form as Yesod import Yesod.Core.Instances () import Settings @@ -55,7 +55,7 @@ import Data.Proxy import Data.Monoid (Endo(..)) - +import Network.URI (URI, parseURI, uriToString) -------------------- @@ -824,6 +824,16 @@ radioGroupField optMsg mkOpts = Field{..} #{optionDisplay opt} |] +data UrlFieldMessage = UrlFieldCouldNotParseAbsolute + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) + +urlField :: ( Monad m + , RenderMessage (HandlerSite m) UrlFieldMessage + , RenderMessage (HandlerSite m) FormMessage + ) + => Field m URI +urlField = checkMap (maybe (Left UrlFieldCouldNotParseAbsolute) Right . parseURI . unpack) (pack . ($ mempty) . uriToString id) Yesod.urlField ----------- -- Forms -- @@ -869,9 +879,14 @@ wrapForm' btn formWidget FormSettings{..} = do ------------------- -- | Use this type to pass information to the form template -data FormLayout = FormStandard | FormDBTableFilter | FormDBTablePagesize | FormDBTableCsvImport | FormDBTableCsvExport +data FormLayout = FormStandard + | FormDBTableFilter | FormDBTablePagesize | FormDBTableCsvImport | FormDBTableCsvExport + | FormVertical + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) data AFormMessage = MsgAFormFieldRequiredTip + deriving (Eq, Ord, Read, Show, Generic, Typeable) renderAForm :: (RenderMessage (HandlerSite m) AFormMessage, Monad m) => FormLayout -> FormRender m a renderAForm formLayout aform fragment = do @@ -879,6 +894,7 @@ renderAForm formLayout aform fragment = do let formHasRequiredFields = any fvRequired fieldViews widget = $(widgetFile "widgets/aform/aform") return (res, widget) + where isFormVertical = formLayout == FormVertical renderWForm :: (RenderMessage (HandlerSite m) AFormMessage, MonadHandler m) => FormLayout -> WForm m (FormResult a) -> -- Form a -- (Synonym unavailable here) (Markup -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ())) diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 3fe3ea604..e6d345884 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -237,6 +237,9 @@ makeLenses_ ''SentMail makePrisms ''AllocationPriority +makePrisms ''RoomReference +makeLenses_ ''RoomReference + -- makeClassy_ ''Load -------------------------- diff --git a/src/Utils/Room.hs b/src/Utils/Room.hs new file mode 100644 index 000000000..1d9076fb1 --- /dev/null +++ b/src/Utils/Room.hs @@ -0,0 +1,11 @@ +module Utils.Room + ( roomReferenceText + ) where + +import Import.NoModel +import Model.Types.Room + +roomReferenceText :: RoomReference -> Text +roomReferenceText = \case + RoomReferenceSimple{roomRefText} -> roomRefText + RoomReferenceLink{roomRefLink} -> pack $ uriToString id roomRefLink mempty diff --git a/stack.yaml b/stack.yaml index d31829f49..45c23b120 100644 --- a/stack.yaml +++ b/stack.yaml @@ -78,6 +78,7 @@ extra-deps: - aeson-1.5.3.0@sha256:05496710de6ae694e55dc77dbdaf7503f56c24e4aecc06045e42e75a02df8bc4,6906 - data-fix-0.3.0@sha256:058a266d1e658500e0ffb8babe68195b0ce06a081dcfc3814afc784b083fd9a5,1645 - strict-0.4@sha256:1b50c7c9c636c3a1bbc7f8873b9be48f6ca0faca4df6eec6a014de6208fb1c0e,4200 + - network-arbitrary-0.6.0.0@sha256:a7034d63295dfc41cf559ee705fc95cac9a9a01b4715300f590eaa237b5ffd48,2506 resolver: nightly-2020-08-08 compiler: ghc-8.10.2 diff --git a/stack.yaml.lock b/stack.yaml.lock index 81a666051..a4ba805a3 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -380,6 +380,13 @@ packages: sha256: fdf523b8990567d69277b999d68d492ed0b3a98a89b1acdfb3087e3b95eb9908 original: hackage: strict-0.4@sha256:1b50c7c9c636c3a1bbc7f8873b9be48f6ca0faca4df6eec6a014de6208fb1c0e,4200 +- completed: + hackage: network-arbitrary-0.6.0.0@sha256:a7034d63295dfc41cf559ee705fc95cac9a9a01b4715300f590eaa237b5ffd48,2506 + pantry-tree: + size: 915 + sha256: 97b797944cf068eb5fde620e005e253818f03068b2c20e9cfdd3aaa6cafcb678 + original: + hackage: network-arbitrary-0.6.0.0@sha256:a7034d63295dfc41cf559ee705fc95cac9a9a01b4715300f590eaa237b5ffd48,2506 snapshots: - completed: size: 524392 diff --git a/templates/course.hamlet b/templates/course.hamlet index c01b249d4..6dd36f2f1 100644 --- a/templates/course.hamlet +++ b/templates/course.hamlet @@ -113,9 +113,9 @@ $# #{summary} $maybe link <- courseLinkExternal course
    _{MsgCourseHomepageExternal}
    - + #{iconLink} - \ #{link} + \ #{uriToString id link mempty} $# $if NTop (Just 0) < NTop (courseCapacity course)
    _{MsgCourseParticipantsHeading} @@ -282,7 +282,7 @@ $# $if NTop (Just 0) < NTop (courseCapacity course) _{MsgCourseEventActions} \ #{iconInvisible} - $forall (cID, CourseEvent{courseEventType, courseEventTime, courseEventRoom, courseEventNote}) <- events + $forall (cID, CourseEvent{courseEventType, courseEventTime, courseEventRoom, courseEventNote}, showRoom) <- events toPathPiece cID}>
    @@ -291,8 +291,15 @@ $# $if NTop (Just 0) < NTop (courseCapacity course)
    ^{occurrencesWidget courseEventTime} -
    - #{courseEventRoom} + $if showRoom +
    + $maybe room <- courseEventRoom + ^{roomReferenceWidget room} + $nothing + _{MsgCourseEventRoomIsUnset} + $else +
    + _{MsgCourseEventRoomIsHidden}
    #{courseEventNote} diff --git a/templates/exam-show.hamlet b/templates/exam-show.hamlet index 8438a1835..4c99a4a83 100644 --- a/templates/exam-show.hamlet +++ b/templates/exam-show.hamlet @@ -81,7 +81,7 @@ $maybe desc <- examDescription ^{notificationPersonalIdentification} $maybe room <- examRoom
    _{MsgExamRoom} -
    #{room} +
    ^{roomReferenceWidget room} $if examTimes
    _{MsgExamTime}
    @@ -204,14 +204,22 @@ $if not (null occurrences) \ ^{isVisible False} _{MsgExamRoomDescription} - $forall (occurrence, registered, rCount) <- occurrences + $forall (occurrence, registered, rCount, showRoom) <- occurrences $with Entity _occId ExamOccurrence{examOccurrenceName, examOccurrenceRoom, examOccurrenceStart, examOccurrenceEnd, examOccurrenceDescription} <- occurrence $with registerWdgt <- registerWidget (Just occurrence) $if occurrenceNamesShown #{examOccurrenceName} $if is _Nothing examRoom - #{examOccurrenceRoom} + $if showRoom + + $maybe room <- examOccurrenceRoom + ^{roomReferenceWidget room} + $nothing + _{MsgExamOccurrenceRoomIsUnset} + $else + + _{MsgExamOccurrenceRoomIsHidden} $if not examTimes ^{formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd} diff --git a/templates/widgets/aform/aform.hamlet b/templates/widgets/aform/aform.hamlet index ad026d02c..cffc289a0 100644 --- a/templates/widgets/aform/aform.hamlet +++ b/templates/widgets/aform/aform.hamlet @@ -9,16 +9,16 @@ $case formLayout $of _ $forall view <- fieldViews $if fvId view == idFormSectionNoinput -

    +

    ^{fvLabel view} $maybe hint <- fvTooltip view -
    +
    ^{hint} $elseif fvId view == idFormMessageNoinput -
    +
    ^{fvInput view} $else -
    +
    $if not (Blaze.null $ fvLabel view)
    #{err} - $if formHasRequiredFields + $if formHasRequiredFields && not isFormVertical
    _{MsgAFormFieldRequiredTip} diff --git a/templates/widgets/exam-occurrence-mapping.hamlet b/templates/widgets/exam-occurrence-mapping.hamlet index a3c8b8ef0..0d0b87940 100644 --- a/templates/widgets/exam-occurrence-mapping.hamlet +++ b/templates/widgets/exam-occurrence-mapping.hamlet @@ -36,7 +36,10 @@ $newline never $maybe mappingWgt <- occMapping occId ^{mappingWgt} - #{examOccurrenceRoom} + $maybe room <- examOccurrenceRoom + ^{roomReferenceWidget room} + $nothing + _{MsgExamOccurrenceRoomIsUnset} ^{formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd} diff --git a/templates/widgets/massinput/examRooms/form.hamlet b/templates/widgets/massinput/examRooms/form.hamlet index 363566059..bddd282aa 100644 --- a/templates/widgets/massinput/examRooms/form.hamlet +++ b/templates/widgets/massinput/examRooms/form.hamlet @@ -1,7 +1,7 @@ $newline never -#{csrf}^{fvInput eofIdView}^{fvWidget eofNameView} -^{fvWidget eofRoomView} -^{fvWidget eofCapacityView} -^{fvWidget eofStartView} -^{fvWidget eofEndView} -^{fvWidget eofDescView} +#{csrf}^{fvInput eofIdView}^{fvWidget eofNameView} +^{eofRoomView} +^{fvWidget eofCapacityView} +^{fvWidget eofStartView} +^{fvWidget eofEndView} +^{fvWidget eofDescView} diff --git a/templates/widgets/massinput/examRooms/layout.hamlet b/templates/widgets/massinput/examRooms/layout.hamlet index bb7cbf94e..54e97b2a8 100644 --- a/templates/widgets/massinput/examRooms/layout.hamlet +++ b/templates/widgets/massinput/examRooms/layout.hamlet @@ -6,8 +6,7 @@ $newline never _{MsgExamRoomName} # - _{MsgExamRoom} # - + _{MsgExamRoom} _{MsgExamRoomCapacity} # diff --git a/templates/widgets/room-reference/link-instructions-modal.hamlet b/templates/widgets/room-reference/link-instructions-modal.hamlet new file mode 100644 index 000000000..1fd7aae88 --- /dev/null +++ b/templates/widgets/room-reference/link-instructions-modal.hamlet @@ -0,0 +1,11 @@ +$newline never +
    +
    + _{MsgRoomReferenceLinkLink} +
    + + #{linkText} +
    + _{MsgRoomReferenceLinkInstructions} +
    + #{roomRefInstructions} diff --git a/templates/widgets/room-reference/link.hamlet b/templates/widgets/room-reference/link.hamlet new file mode 100644 index 000000000..1eb2da00f --- /dev/null +++ b/templates/widgets/room-reference/link.hamlet @@ -0,0 +1,5 @@ +$newline never + + _{MsgRoomReferenceLinkLink} +$if is _Just roomRefInstructions + , ^{instrModal} diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index ec51b7952..b41ebc09e 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -909,6 +909,7 @@ fillDb = do , tutorialType = "Tutorium" , tutorialCapacity = Just 30 , tutorialRoom = Just "Hilbert-Raum" + , tutorialRoomHidden = True , tutorialTime = Occurrences { occurrencesScheduled = Set.singleton $ ScheduleWeekly Tuesday (TimeOfDay 08 15 00) (TimeOfDay 10 00 00) , occurrencesExceptions = Set.empty @@ -928,6 +929,7 @@ fillDb = do , tutorialType = "Tutorium" , tutorialCapacity = Just 30 , tutorialRoom = Just "Hilbert-Raum" + , tutorialRoomHidden = True , tutorialTime = Occurrences { occurrencesScheduled = Set.singleton $ ScheduleWeekly Tuesday (TimeOfDay 10 15 00) (TimeOfDay 12 00 00) , occurrencesExceptions = Set.empty diff --git a/test/Handler/Exam/FormSpec.hs b/test/Handler/Exam/FormSpec.hs index d49dbac6c..100f16aa2 100644 --- a/test/Handler/Exam/FormSpec.hs +++ b/test/Handler/Exam/FormSpec.hs @@ -16,6 +16,7 @@ instance Arbitrary ExamOccurrenceForm where <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary instance Arbitrary ExamPartForm where arbitrary = ExamPartForm @@ -30,6 +31,6 @@ spec :: Spec spec = do parallel $ do lawsCheckHspec (Proxy @ExamOccurrenceForm) - [ eqLaws, ordLaws, showReadLaws ] + [ eqLaws, ordLaws ] lawsCheckHspec (Proxy @ExamPartForm) [ eqLaws, ordLaws ] diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 5c2113656..21c63893d 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -39,6 +39,8 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.CaseInsensitive as CI +import qualified Data.Text.Lazy as LT + instance (Arbitrary a, MonoFoldable a) => Arbitrary (NonNull a) where arbitrary = arbitrary `suchThatMap` fromNullable @@ -218,7 +220,7 @@ instance Arbitrary Html where shrink = map preEscapedToHtml . shrink . renderHtml instance Arbitrary StoredMarkup where - arbitrary = oneof + arbitrary = (`suchThat` (not . null . LT.strip . renderHtml . markupOutput)) $ oneof [ htmlToStoredMarkup <$> arbitrary , plaintextToStoredMarkup . getPrintableString <$> arbitrary ] @@ -305,6 +307,17 @@ instance Arbitrary ExamCloseMode where arbitrary = genericArbitrary shrink = genericShrink +instance Arbitrary RoomReference where + arbitrary = oneof + [ RoomReferenceSimple . pack <$> suchThat (getPrintableString <$> arbitrary) (not . null) + , RoomReferenceLink + <$> arbitrary + <*> arbitrary + ] + +instance Arbitrary RoomReference' where + arbitrary = genericArbitrary + spec :: Spec spec = do @@ -403,6 +416,10 @@ spec = do [ persistFieldLaws, jsonLaws, eqLaws, ordLaws, showReadLaws, monoidLaws, semigroupLaws, semigroupMonoidLaws, csvFieldLaws ] lawsCheckHspec (Proxy @ExamCloseMode) [ persistFieldLaws, jsonLaws, eqLaws, ordLaws, showReadLaws, pathPieceLaws, jsonKeyLaws, finiteLaws, httpApiDataLaws, binaryLaws ] + lawsCheckHspec (Proxy @RoomReference) + [ persistFieldLaws, jsonLaws, eqLaws, ordLaws ] + lawsCheckHspec (Proxy @RoomReference') + [ eqLaws, ordLaws, finiteLaws, showReadLaws, pathPieceLaws, boundedEnumLaws ] describe "TermIdentifier" $ do it "has compatible encoding/decoding to/from Text" . property $ diff --git a/test/ModelSpec.hs b/test/ModelSpec.hs index b4e9c911b..dce83ba01 100644 --- a/test/ModelSpec.hs +++ b/test/ModelSpec.hs @@ -84,7 +84,8 @@ instance Arbitrary Tutorial where <*> arbitrary <*> (CI.mk . pack . getPrintableString <$> arbitrary) <*> (fmap getPositive <$> arbitrary) - <*> (assertM' (not . null) . pack . getPrintableString <$> arbitrary) + <*> arbitrary + <*> arbitrary <*> arbitrary <*> (fmap (CI.mk . pack . getPrintableString) <$> arbitrary) <*> arbitrary diff --git a/test/TestImport.hs b/test/TestImport.hs index 7896ac296..27212218f 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -42,6 +42,7 @@ import Data.UUID as X (UUID) import System.IO as X (hPrint, hPutStrLn) import Jobs (handleJobs) import Numeric.Natural as X +import Network.URI.Arbitrary as X () import Control.Lens as X hiding ((<.), elements)