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

feat(rooms): different room types & hidden rooms

Browse Source
This commit is contained in:
Gregor Kleen 2020-11-19 14:25:38 +01:00
parent 1ce5598207
commit 319c75a85a
55 changed files with 541 additions and 93 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
frontend/src/utils/inputs/inputs.sass
View File

@ -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

28
messages/uniworx/de-de-formal.msg
View File

@ -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
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

24
messages/uniworx/en-eu.msg
View File

@ -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

5
models/courses.model
View File

@ -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()

3
models/exams.model
View File

@ -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

3
models/tutorials.model
View File

@ -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

2
package.yaml
View File

@ -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"

5
src/Database/Esqueleto/Utils.hs
View File

@ -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 ->.

3
src/Foundation/I18n.hs
View File

@ -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

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

@ -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)

3
src/Handler/Course/Events/Delete.hs
View File

@ -27,7 +27,8 @@ postCEvDeleteR tid ssh csh cID = do
[whamlet|
$newline never
#{courseEventType}
, #{courseEventRoom}
$maybe room <- courseEventRoom
, #{roomReferenceText room}
:
^{occurrencesWidget courseEventTime}
|]

1
src/Handler/Course/Events/Edit.hs
View File

@ -23,6 +23,7 @@ postCEvEditR tid ssh csh cID = do
{ courseEventCourse
, courseEventType = cefType
, courseEventRoom = cefRoom
, courseEventRoomHidden = cefRoomHidden
, courseEventTime = cefTime
, courseEventNote = cefNote
, courseEventLastChanged = now

9
src/Handler/Course/Events/Form.hs
View File

@ -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
}

1
src/Handler/Course/Events/New.hs
View File

@ -21,6 +21,7 @@ postCEventsNewR tid ssh csh = do
{ courseEventCourse = cid
, courseEventType = cefType
, courseEventRoom = cefRoom
, courseEventRoomHidden = cefRoomHidden
, courseEventTime = cefTime
, courseEventNote = cefNote
, courseEventLastChanged = now

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

@ -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
<li>
^{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

2
src/Handler/Course/User.hs
View File

@ -460,7 +460,7 @@ courseUserTutorialsSection (Entity cid Course{..}) (Entity uid _) = do
<li>
^{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

2
src/Handler/Exam/Edit.hs
View File

@ -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

17
src/Handler/Exam/Form.hs
View File

@ -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

1
src/Handler/Exam/New.hs
View File

@ -68,6 +68,7 @@ postCExamNewR tid ssh csh = do
, let examOccurrenceExam = examid
examOccurrenceName = eofName
examOccurrenceRoom = eofRoom
examOccurrenceRoomHidden = eofRoomHidden
examOccurrenceCapacity = eofCapacity
examOccurrenceStart = eofStart
examOccurrenceEnd = eofEnd

21
src/Handler/Exam/Show.hs
View File

@ -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))

8
src/Handler/News.hs
View File

@ -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

2
src/Handler/Tutorial/Edit.hs
View File

@ -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

6
src/Handler/Tutorial/Form.hs
View File

@ -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

38
src/Handler/Tutorial/List.hs
View File

@ -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
<li>
^{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
]

1
src/Handler/Tutorial/New.hs
View File

@ -29,6 +29,7 @@ postCTutorialNewR tid ssh csh = do
, tutorialType = tfType
, tutorialCapacity = tfCapacity
, tutorialRoom = tfRoom
, tutorialRoomHidden = tfRoomHidden
, tutorialTime = tfTime
, tutorialRegGroup = tfRegGroup
, tutorialRegisterFrom = tfRegisterFrom

26
src/Handler/Utils/Course.hs
View File

@ -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
]

20
src/Handler/Utils/Exam.hs
View File

@ -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
]

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

@ -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

3
src/Handler/Utils/Table/Cells.hs
View File

@ -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

20
src/Handler/Utils/Tutorial.hs
View File

@ -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
]

8
src/Handler/Utils/Widgets.hs
View File

@ -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")

1
src/Import/NoFoundation.hs
View File

@ -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

5
src/Import/NoModel.hs
View File

@ -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)

42
src/Model/Migration.hs
View File

@ -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
)
]

1
src/Model/Types.hs
View File

@ -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

40
src/Model/Types/Room.hs Normal file
View File

@ -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'

27
src/Network/URI/Instances.hs Normal file
View File

@ -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

24
src/Utils/Form.hs
View File

@ -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 ()))

3
src/Utils/Lens.hs
View File

@ -237,6 +237,9 @@ makeLenses_ ''SentMail
makePrisms ''AllocationPriority
makePrisms ''RoomReference
makeLenses_ ''RoomReference
-- makeClassy_ ''Load
--------------------------

11
src/Utils/Room.hs Normal file
View File

@ -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

1
stack.yaml
View File

@ -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

7
stack.yaml.lock
View File

@ -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

17
templates/course.hamlet
View File

@ -113,9 +113,9 @@ $# #{summary}
$maybe link <- courseLinkExternal course
<dt .deflist__dt>_{MsgCourseHomepageExternal}
<dd .deflist__dd>
<a href=#{link} target="_blank" rel="noopener" title="_{MsgCourseHomepageExternal}">
<a href=#{uriToString id link mempty} target="_blank" rel="noopener" title="_{MsgCourseHomepageExternal}">
#{iconLink}
\ #{link}
\ #{uriToString id link mempty}
$# $if NTop (Just 0) < NTop (courseCapacity course)
<dt .deflist__dt>_{MsgCourseParticipantsHeading}
@ -282,7 +282,7 @@ $# $if NTop (Just 0) < NTop (courseCapacity course)
_{MsgCourseEventActions}
\ #{iconInvisible}
<tbody>
$forall (cID, CourseEvent{courseEventType, courseEventTime, courseEventRoom, courseEventNote}) <- events
$forall (cID, CourseEvent{courseEventType, courseEventTime, courseEventRoom, courseEventNote}, showRoom) <- events
<tr .table__row ##{"event-" <> toPathPiece cID}>
<td .table__td>
<div .table__td-content>
@ -291,8 +291,15 @@ $# $if NTop (Just 0) < NTop (courseCapacity course)
<div .table__td-content>
^{occurrencesWidget courseEventTime}
<td .table__td>
<div .table__td-content>
#{courseEventRoom}
$if showRoom
<div .table__td-content>
$maybe room <- courseEventRoom
^{roomReferenceWidget room}
$nothing
_{MsgCourseEventRoomIsUnset}
$else
<div .table__td-content .explanation>
_{MsgCourseEventRoomIsHidden}
<td .table__td :hiddenEventNotes:.course-event-note--hidden>
<div .table__td-content>
#{courseEventNote}

14
templates/exam-show.hamlet
View File

@ -81,7 +81,7 @@ $maybe desc <- examDescription
^{notificationPersonalIdentification}
$maybe room <- examRoom
<dt .deflist__dt>_{MsgExamRoom}
<dd .deflist__dd>#{room}
<dd .deflist__dd>^{roomReferenceWidget room}
$if examTimes
<dt .deflist__dt>_{MsgExamTime}
<dd .deflist__dd>
@ -204,14 +204,22 @@ $if not (null occurrences)
\ ^{isVisible False}
<th .table__th>_{MsgExamRoomDescription}
<tbody>
$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)
<tr .table__row :markUnregisteredOccurrences (Just occurrence) && not registered:.occurrence--not-registered>
$if occurrenceNamesShown
<td .table__td #exam-occurrence__#{examOccurrenceName}>#{examOccurrenceName}
$if is _Nothing examRoom
<td .table__td>#{examOccurrenceRoom}
$if showRoom
<td .table__td>
$maybe room <- examOccurrenceRoom
^{roomReferenceWidget room}
$nothing
_{MsgExamOccurrenceRoomIsUnset}
$else
<td .table__td .explanation>
_{MsgExamOccurrenceRoomIsHidden}
$if not examTimes
<td .table__td>
^{formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd}

10
templates/widgets/aform/aform.hamlet
View File

@ -9,16 +9,16 @@ $case formLayout
$of _
$forall view <- fieldViews
$if fvId view == idFormSectionNoinput
<h3 .form-section-title>
<h3 .form-section-title :isFormVertical:.form--vertical>
^{fvLabel view}
$maybe hint <- fvTooltip view
<div .form-section-title__hint>
<div .form-section-title__hint :isFormVertical:.form--vertical>
^{hint}
$elseif fvId view == idFormMessageNoinput
<div .form-section-notification>
<div .form-section-notification :isFormVertical:.form--vertical>
^{fvInput view}
$else
<div .form-group .interactive-fieldset__target :fvRequired view:.form-group--required :not $ fvRequired view:.form-group--optional :isJust $ fvErrors view:.form-group--has-error>
<div .form-group .interactive-fieldset__target :fvRequired view:.form-group--required :not $ fvRequired view:.form-group--optional :isJust $ fvErrors view:.form-group--has-error :isFormVertical:.form--vertical>
$if not (Blaze.null $ fvLabel view)
<label .form-group-label for=#{fvId view}>
<span .form-group-label__caption>
@ -30,7 +30,7 @@ $case formLayout
$maybe err <- fvErrors view
<div .form-error>
#{err}
$if formHasRequiredFields
$if formHasRequiredFields && not isFormVertical
<div .form-section-legend>
<span .form-group__required-marker>
_{MsgAFormFieldRequiredTip}

5
templates/widgets/exam-occurrence-mapping.hamlet
View File

@ -36,7 +36,10 @@ $newline never
$maybe mappingWgt <- occMapping occId
^{mappingWgt}
<td .table__td>
#{examOccurrenceRoom}
$maybe room <- examOccurrenceRoom
^{roomReferenceWidget room}
$nothing
_{MsgExamOccurrenceRoomIsUnset}
<td .table__td>
^{formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd}
<td .table__td>

12
templates/widgets/massinput/examRooms/form.hamlet
View File

@ -1,7 +1,7 @@
$newline never
<td>#{csrf}^{fvInput eofIdView}^{fvWidget eofNameView}
<td>^{fvWidget eofRoomView}
<td>^{fvWidget eofCapacityView}
<td>^{fvWidget eofStartView}
<td>^{fvWidget eofEndView}
<td>^{fvWidget eofDescView}
<td .form--vertical__cell>#{csrf}^{fvInput eofIdView}^{fvWidget eofNameView}
<td .form--vertical__cell>^{eofRoomView}
<td .form--vertical__cell>^{fvWidget eofCapacityView}
<td .form--vertical__cell>^{fvWidget eofStartView}
<td .form--vertical__cell>^{fvWidget eofEndView}
<td .form--vertical__cell>^{fvWidget eofDescView}

3
templates/widgets/massinput/examRooms/layout.hamlet
View File

@ -6,8 +6,7 @@ $newline never
_{MsgExamRoomName} #
<span .form-group__required-marker>
<th>
_{MsgExamRoom} #
<span .form-group__required-marker>
_{MsgExamRoom}
<th>
_{MsgExamRoomCapacity} #
<span .form-group__required-marker>

11
templates/widgets/room-reference/link-instructions-modal.hamlet Normal file
View File

@ -0,0 +1,11 @@
$newline never
<dl .deflist>
<dt .deflist__dt>
_{MsgRoomReferenceLinkLink}
<dd .deflist__dd>
<a href=#{linkText}>
#{linkText}
<dt .deflist__dt>
_{MsgRoomReferenceLinkInstructions}
<dd .deflist__dd>
#{roomRefInstructions}

5
templates/widgets/room-reference/link.hamlet Normal file
View File

@ -0,0 +1,5 @@
$newline never
<a href=#{linkText}>
_{MsgRoomReferenceLinkLink}
$if is _Just roomRefInstructions
, ^{instrModal}

2
test/Database/Fill.hs
View File

@ -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

3
test/Handler/Exam/FormSpec.hs
View File

@ -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 ]

19
test/Model/TypesSpec.hs
View File

@ -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 $

3
test/ModelSpec.hs
View File

@ -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

1
test/TestImport.hs
View File

@ -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)