-- ^{modal "Beschreibung" (Right $ toWidget descr)} -- |] -- ) colTerm :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colTerm = sortable (Just "term") (i18nCell MsgTerm) $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> anchorCell (TermCourseListR courseTerm) [whamlet|#{display courseTerm}|] colSchool :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colSchool = sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } -> anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|#{display schoolName}|] colSchoolShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort) $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } -> anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|#{display schoolShorthand}|] colRegFrom :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colRegFrom = sortable (Just "register-from") (i18nCell MsgRegisterFrom) $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> maybe mempty dateTimeCell courseRegisterFrom -- cell $ traverse (formatTime SelFormatDateTime) courseRegisterFrom >>= maybe mempty toWidget colRegTo :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colRegTo = sortable (Just "register-to") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> maybe mempty dateTimeCell courseRegisterTo colMembers :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colMembers = sortable (Just "members") (i18nCell MsgCourseMembers) $ \DBRow{ dbrOutput=(Entity _ Course{..}, currentParticipants, _, _) } -> i18nCell $ case courseCapacity of Nothing -> MsgCourseMembersCount currentParticipants Just limit -> MsgCourseMembersCountLimited currentParticipants limit colRegistered :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) colRegistered = sortable (Just "registered") (i18nCell MsgRegistered) $ \DBRow{ dbrOutput=(_, _, registered, _) } -> tickmarkCell registered type CourseTableExpr = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity School) course2Participants :: CourseTableExpr -> E.SqlExpr (E.Value Int) course2Participants (course `E.InnerJoin` _school) = E.sub_select . E.from $ \courseParticipant -> do E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId return (E.countRows :: E.SqlExpr (E.Value Int)) course2Registered :: Maybe UserId -> CourseTableExpr -> E.SqlExpr (E.Value Bool) course2Registered muid (course `E.InnerJoin` _school) = E.exists . E.from $ \courseParticipant -> E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId E.&&. E.just (courseParticipant E.^. CourseParticipantUser) E.==. E.val muid makeCourseTable :: ( IsDBTable m x, ToSortable h, Functor h, DBResult m x ~ ((), Widget) ) => _ -> Colonnade h CourseTableData (DBCell m x) -> PSValidator m x -> DB Widget makeCourseTable whereClause colChoices psValidator = do muid <- lift maybeAuthId let dbtSQLQuery :: CourseTableExpr -> E.SqlQuery _ dbtSQLQuery qin@(course `E.InnerJoin` school) = do E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId let participants = course2Participants qin let registered = course2Registered muid qin E.where_ $ whereClause (course, participants, registered) return (course, participants, registered, school) dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CourseTableData dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> return (course, participants, registered, school) snd <$> dbTable psValidator DBTable { dbtSQLQuery , dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId , dbtColonnade = colChoices , dbtProj , dbtSorting = Map.fromList -- OverloadedLists does not work with the templates here [ ( "course", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseName) , ( "cshort", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseShorthand) , ( "term" , SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseTerm) , ( "school", SortColumn $ \(_course `E.InnerJoin` school) -> school E.^. SchoolName) , ( "schoolshort", SortColumn $ \(_course `E.InnerJoin` school) -> school E.^. SchoolShorthand) , ( "register-from", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseRegisterFrom) , ( "register-to", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseRegisterTo) , ( "members", SortColumn course2Participants ) , ( "registered", SortColumn $ course2Registered muid) ] , dbtFilter = Map.fromList -- OverloadedLists does not work with the templates here [ ( "course", FilterColumn $ \(course `E.InnerJoin` _school:: CourseTableExpr) criterias -> if | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool) | otherwise -> course E.^. CourseName `E.in_` E.valList (Set.toList criterias) ) , ( "cshort", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterias -> if | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool) | otherwise -> course E.^. CourseShorthand `E.in_` E.valList (Set.toList criterias) ) , ( "term" , FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterias -> if | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool) | otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList criterias) ) -- , ( "school", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) criterias -> if -- | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool) -- | otherwise -> school E.^. SchoolName `E.in_` E.valList (Set.toList criterias) -- ) , ( "school", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) -> emptyOrIn $ school E.^. SchoolName -- TODO: Refactor all?! ) , ( "schoolshort", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) criterias -> if | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool) | otherwise -> school E.^. SchoolShorthand `E.in_` E.valList (Set.toList criterias) ) , ( "registered", FilterColumn $ \tExpr criterion -> case getLast (criterion :: Last Bool) of Nothing -> E.val True :: E.SqlExpr (E.Value Bool) Just needle -> course2Registered muid tExpr E.==. E.val needle ) , ( "search", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterion -> case getLast (criterion :: Last Text) of Nothing -> E.val True :: E.SqlExpr (E.Value Bool) Just needle -> (E.castString (course E.^. CourseName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) E.||. (E.castString (course E.^. CourseShorthand) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) E.||. (E.castString (course E.^. CourseDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) ) ] , dbtFilterUI = \mPrev -> mconcat $ catMaybes [ Just $ prismAForm (singletonFilter "search") mPrev $ aopt (searchField True) (fslI MsgCourseFilterSearch) , muid $> prismAForm (singletonFilter "registered" . maybePrism _PathPiece) mPrev (aopt boolField (fslI MsgCourseFilterRegistered)) ] , dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } , dbtParams = def , dbtIdent = "courses" :: Text } getCourseListR :: Handler Html getCourseListR = do muid <- maybeAuthId let colonnade = widgetColonnade $ mconcat [ colCourse -- colCourseDescr , colDescription , colSchoolShort , colTerm , colCShort , maybe mempty (const colRegistered) muid ] whereClause = const $ E.val True validator = def & defaultSorting [SortDescBy "term",SortAscBy "course"] coursesTable <- runDB $ makeCourseTable whereClause colonnade validator defaultLayout $ do setTitleI MsgCourseListTitle $(widgetFile "courses") getTermCurrentR :: Handler Html getTermCurrentR = do termIds <- runDB $ selectKeysList [TermActive ==. True] [Desc TermName] case fromNullable termIds of Nothing -> notFound (Just (maximum -> tid)) -> -- getTermCourseListR tid redirect $ TermCourseListR tid -- redirect avoids problematic breadcrumbs, headings, etc. getTermSchoolCourseListR :: TermId -> SchoolId -> Handler Html getTermSchoolCourseListR tid ssh = do void . runDB $ get404 tid -- Just ensure the term exists School{schoolName=school} <- runDB $ get404 ssh -- Just ensure the term exists muid <- maybeAuthId let colonnade = widgetColonnade $ mconcat [ dbRow , colCShort , colDescription , colRegFrom , colRegTo , colMembers , maybe mempty (const colRegistered) muid ] whereClause (course, _, _) = course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh validator = def & defaultSorting [SortAscBy "cshort"] coursesTable <- runDB $ makeCourseTable whereClause colonnade validator defaultLayout $ do setTitleI $ MsgTermSchoolCourseListTitle tid school $(widgetFile "courses") getTermCourseListR :: TermId -> Handler Html getTermCourseListR tid = do void . runDB $ get404 tid -- Just ensure the term exists muid <- maybeAuthId let colonnade = widgetColonnade $ mconcat [ dbRow , colCShort , colDescription , colSchoolShort , colRegFrom , colRegTo , colMembers , maybe mempty (const colRegistered) muid ] whereClause (course, _, _) = course E.^. CourseTerm E.==. E.val tid validator = def & defaultSorting [SortAscBy "cshort"] coursesTable <- runDB $ makeCourseTable whereClause colonnade validator defaultLayout $ do setTitleI . MsgTermCourseListTitle $ tid $(widgetFile "courses") getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCShowR tid ssh csh = do mbAid <- maybeAuthId (course,schoolName,participants,registration,defSFid,lecturers,assistants) <- runDB . maybeT notFound $ do [(E.Entity cid course, E.Value schoolName, E.Value participants, fmap entityVal -> registration)] <- lift . E.select . E.from $ \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do E.on $ E.just (course E.^. CourseId) E.==. participant E.?. CourseParticipantCourse E.&&. E.val mbAid E.==. participant E.?. CourseParticipantUser E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId E.where_ $ course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh E.limit 1 -- we know that there is at most one match, but we tell the DB this info too let numParticipants = E.sub_select . E.from $ \part -> do E.where_ $ part E.^. CourseParticipantCourse E.==. course E.^. CourseId return ( E.countRows :: E.SqlExpr (E.Value Int)) return (course,school E.^. SchoolName, numParticipants, participant) defSFid <- ifMaybeM mbAid Nothing $ \uid -> lift $ selectFirst [StudyFeaturesUser ==. uid, StudyFeaturesType ==. FieldPrimary, StudyFeaturesValid ==. True] [Desc StudyFeaturesUpdated, Desc StudyFeaturesDegree, Desc StudyFeaturesField] -- sorting by degree & field is an heuristic only, but this is okay for a default suggestion staff <- lift . E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ] return ( lecturer E.^. LecturerType , user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname) let partStaff :: (LecturerType, UserEmail, Text, Text) -> Either (UserEmail, Text, Text) (UserEmail, Text, Text) partStaff (CourseLecturer ,name,surn,mail) = Right (name,surn,mail) partStaff (_courseAssistant,name,surn,mail) = Left (name,surn,mail) (assistants,lecturers) = partitionWith partStaff $ map $(unValueN 4) staff return (course,schoolName,participants,registration,entityKey <$> defSFid,lecturers,assistants) mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course mRegAt <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration (regWidget, regEnctype) <- generateFormPost $ registerForm mbAid registration defSFid $ courseRegisterSecret course let regForm = wrapForm regWidget def { formAction = Just . SomeRoute $ CourseR tid ssh csh CRegisterR , formEncoding = regEnctype , formSubmit = FormNoSubmit } registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True siteLayout (toWgt $ courseName course) $ do setTitleI $ prependCourseTitle tid ssh csh (""::Text) $(widgetFile "course") -- | Registration button with maybe a userid if logged in -- , maybe existing features if already registered -- , maybe some default study features -- , maybe a course secret registerForm :: Maybe UserId -> Maybe CourseParticipant -> Maybe StudyFeaturesId -> Maybe Text -> Form (Maybe StudyFeaturesId, Bool) -- unfinished WIP: must take study features if registred and show as mforced field registerForm loggedin participant defSFid msecret = identifyForm FIDcourseRegister $ \extra -> do -- secret fields (msecretRes', msecretView) <- case msecret of (Just _) | not isRegistered -> bimap Just Just <$> mreq textField (fslpI MsgCourseSecret "Code") Nothing _ -> return (Nothing,Nothing) -- study features (msfRes', msfView) <- case loggedin of Nothing -> return (Nothing,Nothing) Just _ -> bimap Just Just <$> case participant of Just CourseParticipant{courseParticipantField=Just sfid} -> mforced (studyFeaturesPrimaryFieldFor [sfid] loggedin) (fslI MsgCourseStudyFeature) (Just sfid) _other -> mreq (studyFeaturesPrimaryFieldFor [ ] loggedin) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTooltip) (Just defSFid) -- button de-/register (btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister isRegistered) "buttonField ignores settings anyway" Nothing let widget = $(widgetFile "widgets/register-form/register-form") let msecretRes | Just res <- msecretRes' = Just <$> res | otherwise = FormSuccess Nothing let msfRes | Just res <- msfRes' = res | otherwise = FormSuccess Nothing -- checks that correct button was pressed, and ignores result of btnRes let formRes = (,) <$ btnRes <*> msfRes <*> ((==msecret) <$> msecretRes) return (formRes, widget) where isRegistered = isJust participant postCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html postCRegisterR tid ssh csh = do aid <- requireAuthId (cid, course, registration) <- runDB $ do (Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh registration <- getBy (UniqueParticipant aid cid) return (cid, course, entityVal <$> registration) let isRegistered = isJust registration ((regResult,_), _) <- runFormPost $ registerForm (Just aid) registration Nothing $ courseRegisterSecret course formResult regResult $ \(mbSfId,codeOk) -> if | isRegistered -> do runDB $ deleteBy $ UniqueParticipant aid cid addMessageI Info MsgCourseDeregisterOk | codeOk -> do actTime <- liftIO getCurrentTime regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime mbSfId when (isJust regOk) $ addMessageI Success MsgCourseRegisterOk | otherwise -> addMessageI Warning MsgCourseSecretWrong -- addMessage Info $ toHtml $ show regResult -- For debugging only redirect $ CourseR tid ssh csh CShowR getCourseNewR :: Handler Html -- call via toTextUrl getCourseNewR = do uid <- requireAuthId params <- runInputGetResult $ (,,) --TODO: change to AForm, which is used in Course-Copy-Button <$> iopt termNewField "tid" <*> iopt ciField "ssh" <*> iopt ciField "csh" let courseEditHandler' = courseEditHandler $ \p -> Just . SomeRoute $ (CourseNewR, getParams) :#: p getParams = concat [ [ ("tid", toPathPiece tid) | FormSuccess (Just tid, _, _) <- [params] ] , [ ("ssh", toPathPiece ssh) | FormSuccess (_, Just ssh, _) <- [params] ] , [ ("csh", toPathPiece csh) | FormSuccess (_, _, Just csh) <- [params] ] ] let noTemplateAction = courseEditHandler' Nothing case params of -- DO NOT REMOVE: without this distinction, lecturers would never see an empty makeCourseForm any more! FormMissing -> noTemplateAction FormFailure msgs -> forM_ msgs (addMessage Error . toHtml) >> noTemplateAction FormSuccess (Nothing, Nothing, Nothing) -> noTemplateAction FormSuccess (fmap TermKey -> mbTid, fmap SchoolKey -> mbSsh, mbCsh) -> do oldCourses <- runDB $ E.select $ E.from $ \course -> do whenIsJust mbTid $ \tid -> E.where_ $ course E.^. CourseTerm E.==. E.val tid whenIsJust mbSsh $ \ssh -> E.where_ $ course E.^. CourseSchool E.==. E.val ssh whenIsJust mbCsh $ \csh -> E.where_ $ course E.^. CourseShorthand E.==. E.val csh let lecturersCourse = E.exists $ E.from $ \lecturer -> E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId let lecturersSchool = E.exists $ E.from $ \user -> E.where_ $ user E.^. UserLecturerUser E.==. E.val uid E.&&. user E.^. UserLecturerSchool E.==. course E.^. CourseSchool let courseCreated c = E.sub_select . E.from $ \edit -> do -- oldest edit must be creation E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId return $ E.min_ $ edit E.^. CourseEditTime E.orderBy [ E.desc $ E.case_ [(lecturersCourse, E.val (1 :: Int64))] (E.val 0) -- prefer courses from lecturer , E.desc $ E.case_ [(lecturersSchool, E.val (1 :: Int64))] (E.val 0) -- prefer from schools of lecturer , E.desc $ courseCreated course] -- most recent created course E.limit 1 return course template <- case listToMaybe oldCourses of (Just oldTemplate) -> let newTemplate = courseToForm oldTemplate [] [] in return $ Just $ newTemplate { cfCourseId = Nothing , cfTerm = TermKey $ TermIdentifier 0 Winter -- invalid, will be ignored; undefined won't work due to strictness , cfRegFrom = Nothing , cfRegTo = Nothing , cfDeRegUntil = Nothing } Nothing -> do (tidOk,sshOk,cshOk) <- runDB $ (,,) <$> ifMaybeM mbTid True existsKey <*> ifMaybeM mbSsh True existsKey <*> ifMaybeM mbCsh True (\csh -> not . null <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1]) unless tidOk $ addMessageI Warning $ MsgNoSuchTerm $ fromJust mbTid -- safe, since tidOk==True otherwise unless sshOk $ addMessageI Warning $ MsgNoSuchSchool $ fromJust mbSsh -- safe, since sshOk==True otherwise unless cshOk $ addMessageI Warning $ MsgNoSuchCourseShorthand $ fromJust mbCsh when (tidOk && sshOk && cshOk) $ addMessageI Warning MsgNoSuchCourse return Nothing courseEditHandler' template postCourseNewR :: Handler Html postCourseNewR = courseEditHandler (\p -> Just . SomeRoute $ CourseNewR :#: p) Nothing -- Note: Nothing is safe here, since we will create a new course. getCEditR, postCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCEditR = pgCEditR postCEditR = pgCEditR pgCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html pgCEditR tid ssh csh = do courseData <- runDB $ do mbCourse <- getBy (TermSchoolCourseShort tid ssh csh) mbLecs <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType] mbLecInvites <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerInvitationCourse ==. entityKey course] [Asc LecturerInvitationType] return $ (,,) <$> mbCourse <*> mbLecs <*> mbLecInvites -- IMPORTANT: both GET and POST Handler must use the same template, -- since an Edit is identified via CourseID, which is not embedded in the received form data for security reasons. courseEditHandler (\p -> Just . SomeRoute $ CourseR tid ssh csh CEditR :#: p) $ $(uncurryN 3) courseToForm <$> courseData getCDeleteR, postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCDeleteR = postCDeleteR postCDeleteR tid ssh csh = do Entity cId _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh deleteR $ (courseDeleteRoute $ Set.singleton cId) { drAbort = SomeRoute $ CourseR tid ssh csh CShowR , drSuccess = SomeRoute $ TermSchoolCourseListR tid ssh } -- | Course Creation and Editing -- | IMPORTANT: in case of Edit, Post/Get Request is provided with the same CourseForm template (cannot be Nothing), -- | since an edit is identified via cfCourseId which is not contained in the received form data for security reasons! courseEditHandler :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Handler Html courseEditHandler miButtonAction mbCourseForm = do aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!! ((result, formWidget), formEnctype) <- runFormPost $ makeCourseForm miButtonAction mbCourseForm formResult result $ \case res@CourseForm { cfCourseId = Nothing , cfShort = csh , cfSchool = ssh , cfTerm = tid } -> do -- create new course now <- liftIO getCurrentTime insertOkay <- runDBJobs $ do insertOkay <- insertUnique Course { courseName = cfName res , courseDescription = cfDesc res , courseLinkExternal = cfLink res , courseShorthand = cfShort res , courseTerm = cfTerm res , courseSchool = cfSchool res , courseCapacity = cfCapacity res , courseRegisterSecret = cfSecret res , courseMaterialFree = cfMatFree res , courseRegisterFrom = cfRegFrom res , courseRegisterTo = cfRegTo res , courseDeregisterUntil = cfDeRegUntil res } whenIsJust insertOkay $ \cid -> do let (invites, adds) = partitionEithers $ cfLecturers res insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites insert_ $ CourseEdit aid now cid return insertOkay case insertOkay of Just _ -> do addMessageI Info $ MsgCourseNewOk tid ssh csh redirect $ TermCourseListR tid Nothing -> addMessageI Warning $ MsgCourseNewDupShort tid ssh csh res@CourseForm { cfCourseId = Just cid , cfShort = csh , cfSchool = ssh , cfTerm = tid } -> do -- edit existing course now <- liftIO getCurrentTime -- addMessage "debug" [shamlet| #{show res}|] success <- runDBJobs $ do old <- get cid case old of Nothing -> addMessageI Error MsgInvalidInput $> False (Just _) -> do updOkay <- myReplaceUnique cid Course { courseName = cfName res , courseDescription = cfDesc res , courseLinkExternal = cfLink res , courseShorthand = cfShort res , courseTerm = cfTerm res -- dangerous , courseSchool = cfSchool res , courseCapacity = cfCapacity res , courseRegisterSecret = cfSecret res , courseMaterialFree = cfMatFree res , courseRegisterFrom = cfRegFrom res , courseRegisterTo = cfRegTo res , courseDeregisterUntil = cfDeRegUntil res } case updOkay of (Just _) -> addMessageI Warning (MsgCourseEditDupShort tid ssh csh) $> False Nothing -> do deleteWhere [LecturerCourse ==. cid] deleteWhere [InvitationFor ==. invRef @Lecturer cid, InvitationEmail /<-. toListOf (folded . _Left . _1) (cfLecturers res)] let (invites, adds) = partitionEithers $ cfLecturers res insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites insert_ $ CourseEdit aid now cid addMessageI Success $ MsgCourseEditOk tid ssh csh return True when success $ redirect $ CourseR tid ssh csh CShowR actionUrl <- fromMaybe CourseNewR <$> getCurrentRoute defaultLayout $ do setTitleI MsgCourseEditTitle wrapForm formWidget def { formAction = Just $ SomeRoute actionUrl , formEncoding = formEnctype } instance IsInvitableJunction Lecturer where type InvitationFor Lecturer = Course data InvitableJunction Lecturer = JunctionLecturer { jLecturerType :: LecturerType } deriving (Eq, Ord, Read, Show, Generic, Typeable) data InvitationDBData Lecturer = InvDBDataLecturer { invDBLecturerType :: Maybe LecturerType } deriving (Eq, Ord, Read, Show, Generic, Typeable) data InvitationTokenData Lecturer = InvTokenDataLecturer deriving (Eq, Ord, Read, Show, Generic, Typeable) _InvitableJunction = iso (\Lecturer{..} -> (lecturerUser, lecturerCourse, JunctionLecturer lecturerType)) (\(lecturerUser, lecturerCourse, JunctionLecturer lecturerType) -> Lecturer{..}) instance ToJSON (InvitableJunction Lecturer) where toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } instance FromJSON (InvitableJunction Lecturer) where parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } instance ToJSON (InvitationDBData Lecturer) where toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 } toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 } instance FromJSON (InvitationDBData Lecturer) where parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 } instance ToJSON (InvitationTokenData Lecturer) where toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 } toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 } instance FromJSON (InvitationTokenData Lecturer) where parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 } lecturerInvitationConfig :: InvitationConfig Lecturer lecturerInvitationConfig = InvitationConfig{..} where invitationRoute Course{..} _ = return . CourseR courseTerm courseSchool courseShorthand $ CLecInviteR invitationResolveFor = do Just (CourseR tid csh ssh CLecInviteR) <- getCurrentRoute getKeyBy404 $ TermSchoolCourseShort tid csh ssh invitationSubject Course{..} _ = SomeMessage $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand invitationHeading Course{..} _ = SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgCourseLecInviteExplanation}|] invitationTokenConfig _ _ = do itAuthority <- liftHandlerT requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized invitationForm _ (InvDBDataLecturer mlType, _) = hoistAForm liftHandlerT $ toJunction <$> case mlType of Nothing -> areq (selectField optionsFinite) lFs Nothing Just lType -> aforced (selectField optionsFinite) lFs lType where toJunction jLecturerType = JunctionLecturer{..} lFs = fslI MsgLecturerType & setTooltip MsgCourseLecturerRightsIdentical invitationSuccessMsg Course{..} (Entity _ Lecturer{..}) = do MsgRenderer mr <- getMsgRenderer return . SomeMessage $ MsgLecturerInvitationAccepted (mr lecturerType) courseShorthand invitationUltDest Course{..} _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR data CourseForm = CourseForm { cfCourseId :: Maybe CourseId , cfName :: CourseName , cfDesc :: Maybe Html , cfLink :: Maybe Text , cfShort :: CourseShorthand , cfTerm :: TermId , cfSchool :: SchoolId , cfCapacity :: Maybe Int , cfSecret :: Maybe Text , cfMatFree :: Bool , cfRegFrom :: Maybe UTCTime , cfRegTo :: Maybe UTCTime , cfDeRegUntil :: Maybe UTCTime , cfLecturers :: [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)] } courseToForm :: Entity Course -> [Lecturer] -> [LecturerInvitation] -> CourseForm courseToForm (Entity cid Course{..}) lecs lecInvites = CourseForm { cfCourseId = Just cid , cfName = courseName , cfDesc = courseDescription , cfLink = courseLinkExternal , cfShort = courseShorthand , cfTerm = courseTerm , cfSchool = courseSchool , cfCapacity = courseCapacity , cfSecret = courseRegisterSecret , cfMatFree = courseMaterialFree , cfRegFrom = courseRegisterFrom , cfRegTo = courseRegisterTo , cfDeRegUntil = courseDeregisterUntil , cfLecturers = [Right (lecturerUser, lecturerType) | Lecturer{..} <- lecs] ++ [Left (lecturerInvitationEmail, lecturerInvitationType) | LecturerInvitation{..} <- lecInvites ] } makeCourseForm :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Form CourseForm makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do -- TODO: Refactor to avoid the four repeated calls to liftHandlerT and three runDBs -- let editCid = cfCourseId =<< template -- possible start for refactoring MsgRenderer mr <- getMsgRenderer uid <- liftHandlerT requireAuthId (lecSchools, admSchools) <- liftHandlerT . runDB $ (,) <$> (map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] [] ) <*> (map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. uid] [] ) let userSchools = lecSchools ++ admSchools termsField <- case template of -- Change of term is only allowed if user may delete the course (i.e. no participants) or admin (Just cform) | (Just cid) <- cfCourseId cform -> liftHandlerT $ do -- edit existing course _courseOld@Course{..} <- runDB $ get404 cid mayEditTerm <- isAuthorized TermEditR True mayDelete <- isAuthorized (CourseR courseTerm courseSchool courseShorthand CDeleteR) True return $ if | (mayEditTerm == Authorized) || (mayDelete == Authorized) -> termsAllowedField | otherwise -> termsSetField [cfTerm cform] _allOtherCases -> return termsAllowedField let miAdd :: ListPosition -> Natural -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId)))) miAdd _ _ nudge btn = Just $ \csrf -> do (addRes, addView) <- mpreq emailField ("" & addName (nudge "user")) Nothing addRes' <- for addRes $ liftHandlerT . runDB . getKeyBy . UniqueEmail . CI.mk let addRes'' = case (,) <$> addRes <*> addRes' of FormSuccess (CI.mk -> email, mLid) -> let new = maybe (Left email) Right mLid in FormSuccess $ \prev -> if | new `elem` Map.elems prev -> FormFailure [ mr $ MsgCourseLecturerAlreadyAdded email ] -- Since there is only ever one email address associated with any user, the case where a @Left email@ corresponds to a @Right lid@ can never occur (at least logically; might still be the same person, of course) | otherwise -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax prev) new FormFailure errs -> FormFailure errs FormMissing -> FormMissing addView' = $(widgetFile "course/lecturerMassInput/add") return (addRes'', addView') miCell :: ListPosition -> Either UserEmail UserId -> Maybe (Maybe LecturerType) -> (Text -> Text) -> Form (Maybe LecturerType) miCell _ (Right lid) defType nudge = \csrf -> do (lrwRes,lrwView) <- mreq (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) (join defType) User{userEmail, userDisplayName, userSurname} <- liftHandlerT . runDB $ get404 lid let lrwView' = $(widgetFile "course/lecturerMassInput/cellKnown") return (Just <$> lrwRes,lrwView') miCell _ (Left lEmail) defType nudge = \csrf -> do (lrwRes,lrwView) <- mopt (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType let lrwView' = $(widgetFile "course/lecturerMassInput/cellInvitation") return (lrwRes,lrwView') miDelete :: ListLength -- ^ Current shape -> ListPosition -- ^ Coordinate to delete -> MaybeT (MForm (HandlerT UniWorX IO)) (Map ListPosition ListPosition) miDelete = miDeleteList miAllowAdd :: ListPosition -> Natural -> ListLength -> Bool miAllowAdd _ _ _ = True miAddEmpty :: ListPosition -> Natural -> ListLength -> Set ListPosition miAddEmpty _ _ _ = Set.empty miLayout :: ListLength -> Map ListPosition (Either UserEmail UserId, FormResult (Maybe LecturerType)) -- ^ massInput state -> Map ListPosition Widget -- ^ Cell widgets -> Map ListPosition (FieldView UniWorX) -- ^ Deletion buttons -> Map (Natural, ListPosition) Widget -- ^ Addition widgets -> Widget miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "course/lecturerMassInput/layout") lecturerForm :: AForm Handler [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)] lecturerForm = formToAForm . over (mapped._2) pure . over (mapped._1.mapped) (map liftEither . Map.elems) $ massInput MassInput{..} (fslI MsgCourseLecturers & setTooltip MsgCourseLecturerRightsIdentical) True (Just . Map.fromList . zip [0..] $ maybe [(Right uid, Just CourseLecturer)] (map unliftEither . cfLecturers) template) mempty where liftEither :: (Either UserEmail UserId, Maybe LecturerType) -> Either (UserEmail, Maybe LecturerType) (UserId, LecturerType) liftEither (Right lid , Just lType) = Right (lid , lType ) liftEither (Left lEmail, mLType ) = Left (lEmail, mLType) liftEither _ = error "liftEither: lecturerForm produced output it should not have been able to" unliftEither :: Either (UserEmail, Maybe LecturerType) (UserId, LecturerType) -> (Either UserEmail UserId, Maybe LecturerType) unliftEither (Right (lid , lType )) = (Right lid , Just lType) unliftEither (Left (lEmail, mLType)) = (Left lEmail, mLType ) (newRegFrom,newRegTo,newDeRegUntil) <- case template of (Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing) _allIOtherCases -> do mbLastTerm <- liftHandlerT $ runDB $ selectFirst [TermActive ==. True] [Desc TermName] return ( (Just . toMidnight . termStart . entityVal) <$> mbLastTerm , (Just . beforeMidnight . termEnd . entityVal) <$> mbLastTerm , (Just . beforeMidnight . termEnd . entityVal) <$> mbLastTerm ) (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm <$> pure (cfCourseId =<< template) <*> areq ciField (fslI MsgCourseName) (cfName <$> template) <*> aopt htmlField (fslpI MsgCourseDescription "Bitte mindestens die Modulbeschreibung angeben" & setTooltip MsgCourseDescriptionTip) (cfDesc <$> template) <*> aopt urlField (fslpI MsgCourseHomepageExternal "Optionale externe URL") (cfLink <$> template) <*> areq ciField (fslI MsgCourseShorthand -- & addAttr "disabled" "disabled" & setTooltip MsgCourseShorthandUnique) (cfShort <$> template) <*> areq termsField (fslI MsgCourseSemester) (cfTerm <$> template) <*> areq (schoolFieldFor userSchools) (fslI MsgCourseSchool) (cfSchool <$> template) <*> aopt (natFieldI MsgCourseCapacity) (fslI MsgCourseCapacity & setTooltip MsgCourseCapacityTip) (cfCapacity <$> template) <*> aopt textField (fslpI MsgCourseSecret (mr MsgCourseSecretFormat) & setTooltip MsgCourseSecretTip) (cfSecret <$> template) <*> areq checkBoxField (fslI MsgMaterialFree) (cfMatFree <$> template) <*> aopt utcTimeField (fslpI MsgRegisterFrom (mr MsgDate) & setTooltip MsgCourseRegisterFromTip) (deepAlt (cfRegFrom <$> template) newRegFrom) <*> aopt utcTimeField (fslpI MsgRegisterTo (mr MsgDate) & setTooltip MsgCourseRegisterToTip) (deepAlt (cfRegTo <$> template) newRegTo) <*> aopt utcTimeField (fslpI MsgDeRegUntil (mr MsgDate) & setTooltip MsgCourseDeregisterUntilTip) (deepAlt (cfDeRegUntil <$> template) newDeRegUntil) <*> lecturerForm errorMsgs' <- traverse validateCourse result return $ case errorMsgs' of FormSuccess errorMsgs | not $ null errorMsgs -> (FormFailure errorMsgs, [whamlet|

Fehler:
$forall errmsg <- errorMsgs
#{errmsg} ^{widget} |] ) _ -> (result, widget) validateCourse :: (MonadHandler m, HandlerSite m ~ UniWorX) => CourseForm -> m [Text] validateCourse CourseForm{..} = do uid <- liftHandlerT requireAuthId userAdmin <- liftHandlerT . runDB . getBy $ UniqueUserAdmin uid cfSchool -- FIXME: This /needs/ to be a call to `isAuthorized` on a route MsgRenderer mr <- getMsgRenderer return [ mr msg | (False, msg) <- [ ( NTop cfRegFrom <= NTop cfRegTo , MsgCourseRegistrationEndMustBeAfterStart ) , ( NTop cfRegFrom <= NTop cfDeRegUntil , MsgCourseDeregistrationEndMustBeAfterStart ) , ( maybe (anyOf (traverse . _Right . _1) (== uid) cfLecturers) (\(Entity _ UserAdmin{}) -> True) userAdmin , MsgCourseUserMustBeLecturer ) ] ] -------------------- -- CourseUserTable type UserTableExpr = (E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin`E.SqlExpr (Maybe (Entity StudyTerms))) -- forceUserTableType :: (UserTableExpr -> a) -> (UserTableExpr -> a) -- forceUserTableType = id -- Sql-Getters for this query, used for sorting and filtering (cannot be lenses due to being Esqueleto expressions) -- This ought to ease refactoring the query queryUser :: UserTableExpr -> E.SqlExpr (Entity User) queryUser = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) queryParticipant :: UserTableExpr -> E.SqlExpr (Entity CourseParticipant) queryParticipant = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1) queryUserNote :: UserTableExpr -> E.SqlExpr (Maybe (Entity CourseUserNote)) queryUserNote = $(sqlLOJproj 3 2) queryFeaturesStudy :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures)) queryFeaturesStudy = $(sqlIJproj 3 1) . $(sqlLOJproj 3 3) queryFeaturesDegree :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree)) queryFeaturesDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 3 3) queryFeaturesField :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms)) queryFeaturesField = $(sqlIJproj 3 3) . $(sqlLOJproj 3 3) userTableQuery :: CourseId -> UserTableExpr -> E.SqlQuery ( E.SqlExpr (Entity User) , E.SqlExpr (E.Value UTCTime) , E.SqlExpr (E.Value (Maybe (Key CourseUserNote))) , StudyFeaturesDescription') userTableQuery cid ((user `E.InnerJoin` participant) `E.LeftOuterJoin` note `E.LeftOuterJoin` studyFeatures) = do -- Note that order of E.on for nested joins is seemingly right-to-left, ignoring nesting paranthesis features <- studyFeaturesQuery' (participant E.^. CourseParticipantField) studyFeatures E.on $ E.just (participant E.^. CourseParticipantUser) E.==. note E.?. CourseUserNoteUser E.on $ participant E.^. CourseParticipantUser E.==. user E.^. UserId E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid return (user, participant E.^. CourseParticipantRegistration, note E.?. CourseUserNoteId, features) type UserTableData = DBRow (Entity User, UTCTime, Maybe CourseUserNoteId, (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms)) instance HasEntity UserTableData User where hasEntity = _dbrOutput . _1 instance HasUser UserTableData where -- hasUser = _entityVal hasUser = _dbrOutput . _1 . _entityVal _userTableRegistration :: Lens' UserTableData UTCTime _userTableRegistration = _dbrOutput . _2 _userTableNote :: Lens' UserTableData (Maybe CourseUserNoteId) _userTableNote = _dbrOutput . _3 _userTableFeatures :: Lens' UserTableData (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms) _userTableFeatures = _dbrOutput . _4 _rowUserSemester :: Traversal' UserTableData Int _rowUserSemester = _userTableFeatures . _1 . _Just . _studyFeaturesSemester colUserComment :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c) colUserComment tid ssh csh = sortable (Just "note") (i18nCell MsgCourseUserNote) $ \DBRow{ dbrOutput=(Entity uid _, _, mbNoteKey,_) } -> maybeEmpty mbNoteKey $ const $ anchorCellM (courseLink <$> encrypt uid) (toWidget $ hasComment True) where courseLink = CourseR tid ssh csh . CUserR colUserSemester :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) colUserSemester = sortable (Just "semesternr") (i18nCell MsgStudyFeatureAge) $ foldMap numCell . preview _rowUserSemester colUserField :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) colUserField = sortable (Just "field") (i18nCell MsgCourseStudyFeature) $ foldMap i18nCell . view (_userTableFeatures . _3) colUserFieldShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) colUserFieldShort = sortable (Just "field-short") (i18nCell MsgCourseStudyFeature) $ foldMap (i18nCell . ShortStudyTerms) . view (_userTableFeatures . _3) colUserDegree :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) colUserDegree = sortable (Just "degree") (i18nCell MsgStudyFeatureDegree) $ foldMap i18nCell . preview (_userTableFeatures . _2 . _Just) colUserDegreeShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) colUserDegreeShort = sortable (Just "degree-short") (i18nCell MsgStudyFeatureDegree) $ foldMap (i18nCell . ShortStudyDegree) . preview (_userTableFeatures . _2 . _Just) data CourseUserAction = CourseUserSendMail | CourseUserDeregister deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) instance Universe CourseUserAction instance Finite CourseUserAction nullaryPathPiece ''CourseUserAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''CourseUserAction id makeCourseUserTable :: CourseId -> _ -> _ -> DB (FormResult (CourseUserAction, Set UserId), Widget) makeCourseUserTable cid colChoices psValidator = do Just currentRoute <- liftHandlerT getCurrentRoute -- -- psValidator has default sorting and filtering let dbtIdent = "courseUsers" :: Text dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } dbtSQLQuery = userTableQuery cid dbtRowKey = queryUser >>> (E.^. UserId) dbtProj = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms)) dbtColonnade = colChoices dbtSorting = Map.fromList [ sortUserNameLink queryUser -- slower sorting through clicking name column header , sortUserSurname queryUser -- needed for initial sorting , sortUserDisplayName queryUser -- needed for initial sorting , sortUserEmail queryUser , sortUserMatriclenr queryUser , ("degree" , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName)) , ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand)) , ("field" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsName)) , ("field-short" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsShorthand)) , ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) , ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration)) , ("note" , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date E.sub_select . E.from $ \edit -> do E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote) return . E.max_ $ edit E.^. CourseUserNoteEditTime ) ] dbtFilter = Map.fromList [ fltrUserNameLink queryUser , fltrUserEmail queryUser , fltrUserMatriclenr queryUser , fltrUserNameEmail queryUser , ("field-name" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName)) , ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand)) , ("field-key" , FilterColumn $ E.mkExactFilter $ queryFeaturesField >>> (E.?. StudyTermsKey)) , ("field" , FilterColumn $ E.anyFilter [ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName) , E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand) , E.mkExactFilterWith readMay $ queryFeaturesField >>> (E.?. StudyTermsKey) ] ) , ("degree" , FilterColumn $ E.anyFilter [ E.mkContainsFilter $ queryFeaturesDegree >>> (E.?. StudyDegreeName) , E.mkContainsFilter $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand) , E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey) ] ) , ("semesternr" , FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester)) -- , ("course-registration", error "TODO") -- TODO -- , ("course-user-note", error "TODO") -- TODO ] dbtFilterUI mPrev = mconcat [ fltrUserNameEmailUI mPrev , fltrUserMatriclenrUI mPrev , prismAForm (singletonFilter "degree") mPrev $ aopt (searchField False) (fslI MsgStudyFeatureDegree) , prismAForm (singletonFilter "field") mPrev $ aopt (searchField False) (fslI MsgCourseStudyFeature) ] dbtParams = DBParamsForm { dbParamsFormMethod = POST , dbParamsFormAction = Just $ SomeRoute currentRoute , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit , dbParamsFormAdditional = \csrf -> do (res,vw) <- mreq (selectField optionsFinite) "" Nothing let formWgt = toWidget csrf <> fvInput vw formRes = (, mempty) . First . Just <$> res return (formRes,formWgt) , dbParamsFormEvaluate = liftHandlerT . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def } over _1 postprocess <$> dbTable psValidator DBTable{..} where postprocess :: FormResult (First CourseUserAction, DBFormResult UserId Bool UserTableData) -> FormResult (CourseUserAction, Set UserId) postprocess inp = do (First (Just act), usrMap) <- inp let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap return (act, usrSet) getCUsersR, postCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCUsersR = postCUsersR postCUsersR tid ssh csh = do (Entity cid course, numParticipants, (participantRes,participantTable)) <- runDB $ do let colChoices = mconcat [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) , colUserNameLink (CourseR tid ssh csh . CUserR) , colUserEmail , colUserMatriclenr , colUserDegreeShort , colUserField , colUserSemester , sortable (Just "registration") (i18nCell MsgRegisteredHeader) (dateCell . view _userTableRegistration) , colUserComment tid ssh csh ] psValidator = def & defaultSortingByName ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh numParticipants <- count [CourseParticipantCourse ==. cid] table <- makeCourseUserTable cid colChoices psValidator return (ent, numParticipants, table) formResult participantRes $ \case (CourseUserSendMail, selectedUsers) -> do cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser] redirect (CourseR tid ssh csh CCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids]) (CourseUserDeregister,selectedUsers) -> do nrDel <- runDB $ deleteWhereCount [ CourseParticipantCourse ==. cid , CourseParticipantUser <-. Set.toList selectedUsers ] addMessageI Success $ MsgCourseUsersDeregistered nrDel redirect $ CourseR tid ssh csh CUsersR let headingLong = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{display tid}|] headingShort = prependCourseTitle tid ssh csh MsgCourseMembers siteLayout headingLong $ do setTitleI headingShort $(widgetFile "course-participants") getCUserR, postCUserR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDUser -> Handler Html getCUserR = postCUserR postCUserR tid ssh csh uCId = do -- Has authorization checks (OR): -- -- - User is current member of course -- - User has submitted in course -- - User is member of registered group for course -- - User is member of a tutorial for course -- - User is corrector for course -- - User is a tutor for course -- - User is a lecturer for course let currentRoute = CourseR tid ssh csh (CUserR uCId) dozentId <- requireAuthId uid <- decrypt uCId -- DB reads (cid, User{..}, registration, thisUniqueNote, noteText, noteEdits, studies ) <- runDB $ do cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh -- Abfrage Benutzerdaten user <- get404 uid registration <- fmap entityVal <$> getBy (UniqueParticipant uid cid) -- Abfrage Teilnehmernotiz let thisUniqueNote = UniqueCourseUserNote uid cid mbNoteEnt <- getBy thisUniqueNote (noteText,noteEdits) <- case mbNoteEnt of Nothing -> return (Nothing,[]) (Just (Entity noteKey CourseUserNote{courseUserNoteNote})) -> do noteEdits <- E.select $ E.from $ \(edit `E.InnerJoin` usr) -> do E.on $ edit E.^. CourseUserNoteEditUser E.==. usr E.^. UserId E.where_ $ edit E.^. CourseUserNoteEditNote E.==. E.val noteKey E.orderBy [E.desc $ edit E.^. CourseUserNoteEditTime] E.limit 1 -- more will be shown, if changed here return (edit E.^. CourseUserNoteEditTime, usr E.^. UserEmail, usr E.^. UserDisplayName, usr E.^. UserSurname) return (Just courseUserNoteNote, $(unValueN 4) <$> noteEdits) -- Abfrage Studiengänge studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId return (studyfeat, studydegree, studyterms) return (cid,user,registration,thisUniqueNote,noteText,noteEdits,studies) let editByWgt = [whamlet| $forall (etime,_eemail,ename,_esurname) <- noteEdits
_{MsgLastEdit} ^{editedByW SelFormatDateTime etime ename} |] -- _{MsgLastEdit} ^{formatTimeW SelFormatDateTime etime} ^{nameWidget ename esurname} ((noteRes, noteView), noteEnctype) <- runFormPost . identifyForm FIDcUserNote . renderAForm FormStandard $ aopt (annotateField editByWgt htmlField') (fslpI MsgCourseUserNote "HTML" & setTooltip MsgCourseUserNoteTooltip) (Just noteText) <* saveButton formResult noteRes $ \mbNote -> (do now <- liftIO getCurrentTime case mbNote of Nothing -> do runDB $ do -- must delete all edits due to foreign key constraints, which does not make sense -> refactor! maybeM (return ()) (\nk -> deleteWhere [CourseUserNoteEditNote ==. nk]) (getKeyBy thisUniqueNote) deleteBy thisUniqueNote addMessageI Info MsgCourseUserNoteDeleted redirect currentRoute -- reload page after post _ | (renderHtml <$> mbNote) == (renderHtml <$> noteText) -> return() -- no changes (Just note) -> do runDB $ do (Entity noteKey _) <- upsertBy thisUniqueNote (CourseUserNote cid uid note) [CourseUserNoteNote =. note] void . insert $ CourseUserNoteEdit dozentId now noteKey addMessageI Success MsgCourseUserNoteSaved redirect currentRoute -- reload page after post ) -- De-/Register Button for Lecturer mRegAt <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration ((registerRes,registerView), registerEnctype) <- runFormPost $ registerForm (Just uid) registration Nothing Nothing -- Lecturers are never asked their own register secret formResult registerRes $ \(mbSfId, _secretCorrect) -> if -- lecturers need no secret verification | isJust registration -> do runDB $ deleteBy $ UniqueParticipant uid cid addMessageI Info MsgCourseDeregisterOk | otherwise -> do actTime <- liftIO getCurrentTime regOk <- runDB $ insertUnique $ CourseParticipant cid uid actTime mbSfId when (isJust regOk) $ addMessageI Success MsgCourseRegisterOk -- generate output let headingLong = [whamlet|^{nameWidget userDisplayName userSurname} - _{MsgCourseMemberOf} #{csh} #{display tid}|] headingShort = prependCourseTitle tid ssh csh $ SomeMessage userDisplayName siteLayout headingLong $ do setTitleI headingShort $(widgetFile "course-user") getCHiWisR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCHiWisR = error "CHiWisR: Not implemented" getCNotesR, postCNotesR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -- NOTE: The route getNotesR is abused for correctorORlecturer access rights! -- PROBLEM: Correctors usually don't know Participants by name (anonymous), maybe notes are not shared? -- If they are shared, adjust MsgCourseUserNoteTooltip getCNotesR = error "CNotesR: Not implemented" postCNotesR = error "CNotesR: Not implemented" getCCommR, postCCommR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCCommR = postCCommR postCCommR tid ssh csh = do jSender <- requireAuthId cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh commR CommunicationRoute { crHeading = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommCourseHeading , crUltDest = SomeRoute $ CourseR tid ssh csh CCommR , crJobs = \Communication{..} -> do let jSubject = cSubject jMailContent = cBody jCourse = cid allRecipients = Set.toList $ Set.insert (Right jSender) cRecipients jMailObjectUUID <- liftIO getRandom jAllRecipientAddresses <- lift . fmap Set.fromList . forM allRecipients $ \case Left email -> return . Address Nothing $ CI.original email Right rid -> userAddress <$> getJust rid forM_ allRecipients $ \jRecipientEmail -> yield JobSendCourseCommunication{..} , crRecipients = Map.fromList [ ( RGCourseParticipants , E.from $ \(user `E.InnerJoin` participant) -> do E.on $ user E.^. UserId E.==. participant E.^. CourseParticipantUser E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid return user ) , ( RGCourseLecturers , E.from $ \(user `E.InnerJoin` lecturer) -> do E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid return user ) , ( RGCourseCorrectors , E.from $ \user -> do E.where_ $ E.exists $ E.from $ \(sheet `E.InnerJoin` corrector) -> do E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet E.where_ $ sheet E.^. SheetCourse E.==. E.val cid return user ) ] , crRecipientAuth = Just $ \uid -> do cID <- encrypt uid evalAccessDB (CourseR tid ssh csh $ CUserR cID) False } getCLecInviteR, postCLecInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCLecInviteR = postCLecInviteR postCLecInviteR = invitationR lecturerInvitationConfig