-- ^{modal "Beschreibung" (Right $ toWidget descr)} -- |] -- ) colTerm :: IsDBTable m a => Colonnade _ 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 _ 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 _ 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 _ CourseTableData (DBCell m a) colRegFrom = sortable (Just "register-from") (i18nCell MsgRegisterFrom) $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> maybe mempty timeCell courseRegisterFrom -- cell $ traverse (formatTime SelFormatDateTime) courseRegisterFrom >>= maybe mempty toWidget colRegTo :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colRegTo = sortable (Just "register-to") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> maybe mempty timeCell courseRegisterTo colMembers :: IsDBTable m a => Colonnade _ 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 _ 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 Int64) 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 Int64)) 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,registered,lecturers) <- runDB . maybeT notFound $ do [(E.Entity cid course, E.Value schoolName, E.Value participants, E.Value registered)] <- 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 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 Int64)) return (course,school E.^. SchoolName, numParticipants, participant E.?. CourseParticipantRegistration) lecturers <- 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 return $ user E.^. UserDisplayName return (course,schoolName,participants,registered,map E.unValue lecturers) mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course mRegAt <- traverse (formatTime SelFormatDateTime) registered (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm (isJust mRegAt) $ courseRegisterSecret course registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True siteLayout (toWgt $ courseName course) $ do setTitle [shamlet| #{toPathPiece tid} - #{csh}|] $(widgetFile "course") registerForm :: Bool -> Maybe Text -> Form Bool registerForm registered msecret extra = do (msecretRes', msecretView) <- case msecret of (Just _) | not registered -> bimap Just Just <$> mreq textField (fslpI MsgCourseSecret "Code") Nothing _ -> return (Nothing,Nothing) (btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister registered) "buttonField ignores settings anyway" Nothing let widget = $(widgetFile "widgets/register-form/register-form") let msecretRes | Just res <- msecretRes' = Just <$> res | otherwise = FormSuccess Nothing return (btnRes *> ((==msecret) <$> msecretRes), widget) -- checks that correct button was pressed, and ignores result of btnRes postCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html postCRegisterR tid ssh csh = do aid <- requireAuthId (cid, course, registered) <- runDB $ do (Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh registered <- isJust <$> getBy (UniqueParticipant aid cid) return (cid, course, registered) ((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course case regResult of (FormSuccess codeOk) | registered -> do runDB $ deleteBy $ UniqueParticipant aid cid addMessageI Info MsgCourseDeregisterOk | codeOk -> do actTime <- liftIO getCurrentTime regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime when (isJust regOk) $ addMessageI Success MsgCourseRegisterOk | otherwise -> addMessageI Warning MsgCourseSecretWrong _other -> return () -- TODO check this! 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 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 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 course <- runDB $ getBy $ TermSchoolCourseShort tid ssh csh -- 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 $ courseToForm <$> course 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 :: Maybe CourseForm -> Handler Html courseEditHandler mbCourseForm = do aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!! ((result, formWidget), formEnctype) <- runFormPost $ makeCourseForm mbCourseForm case result of (FormSuccess res@CourseForm { cfCourseId = Nothing , cfShort = csh , cfSchool = ssh , cfTerm = tid }) -> do -- create new course now <- liftIO getCurrentTime insertOkay <- runDB $ 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 } case insertOkay of (Just cid) -> do runDB $ do insert_ $ CourseEdit aid now cid insert_ $ Lecturer aid cid addMessageI Info $ MsgCourseNewOk tid ssh csh redirect $ TermCourseListR tid Nothing -> addMessageI Warning $ MsgCourseNewDupShort tid ssh csh (FormSuccess res@CourseForm { cfCourseId = Just cid , cfShort = csh , cfSchool = ssh , cfTerm = tid }) -> do -- edit existing course now <- liftIO getCurrentTime -- addMessage "debug" [shamlet| #{show res}|] success <- runDB $ 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 insert_ $ CourseEdit aid now cid addMessageI Success $ MsgCourseEditOk tid ssh csh return True when success $ redirect $ CourseR tid ssh csh CShowR (FormFailure _) -> addMessageI Warning MsgInvalidInput FormMissing -> return () actionUrl <- fromMaybe CourseNewR <$> getCurrentRoute defaultLayout $ do setTitleI MsgCourseEditTitle $(widgetFile "formPage") data CourseForm = CourseForm { cfCourseId :: Maybe CourseId , cfName :: CourseName , cfDesc :: Maybe Html , cfLink :: Maybe Text , cfShort :: CourseShorthand , cfTerm :: TermId , cfSchool :: SchoolId , cfCapacity :: Maybe Int64 , cfSecret :: Maybe Text , cfMatFree :: Bool , cfRegFrom :: Maybe UTCTime , cfRegTo :: Maybe UTCTime , cfDeRegUntil :: Maybe UTCTime } courseToForm :: Entity Course -> CourseForm courseToForm (Entity cid Course{..}) = 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 } makeCourseForm :: Maybe CourseForm -> Form CourseForm makeCourseForm template = identForm FIDcourse $ \html -> do -- TODO: Refactor to avoid the four repeated calls to liftHandlerT and three runDBs -- let editCid = cfCourseId =<< template -- possible start for refactoring mr <- liftHandlerT getMessageRender -- needed for translation of placeholders userSchools <- liftHandlerT . runDB $ do userId <- liftHandlerT requireAuthId (fmap concat . sequence) [ map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. userId] [] , map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. userId] [] ] 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 (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) <* submitButton return $ case result of FormSuccess courseResult | errorMsgs <- validateCourse courseResult , not $ null errorMsgs -> (FormFailure errorMsgs, [whamlet|

Fehler:
$forall errmsg <- errorMsgs
#{errmsg} ^{widget} |] ) _ -> (result, widget) validateCourse :: CourseForm -> [Text] validateCourse CourseForm{..} = [ msg | (False, msg) <- [ ( NTop cfRegFrom <= NTop cfRegTo , "Ende des Anmeldezeitraums muss nach dem Anfang liegen" ) , ( NTop cfRegFrom <= NTop cfDeRegUntil , "Ende des Abmeldezeitraums muss nach dem Anfang liegen" ) -- No starting date is okay: effective immediately -- ( cfHasReg <= (isNothing cfRegFrom) -- , "Beginn der Anmeldung angeben oder Anmeldungen deaktivieren" -- ) -- , ] ] -------------------- -- CourseUserTable type UserTableExpr = (E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote)) type UserTableWhere = UserTableExpr -> E.SqlExpr (E.Value Bool) type UserTableData = DBRow (Entity User, E.Value UTCTime, E.Value (Maybe CourseUserNoteId)) forceUserTableType :: (UserTableExpr -> a) -> (UserTableExpr -> a) forceUserTableType = id userTableQuery :: UserTableWhere -> UserTableExpr -> E.SqlQuery ( E.SqlExpr (Entity User) , E.SqlExpr (E.Value UTCTime) , E.SqlExpr (E.Value (Maybe CourseUserNoteId))) userTableQuery whereClause t@((user `E.InnerJoin` participant) `E.LeftOuterJoin` note) = do E.on $ E.just (participant E.^. CourseParticipantUser) E.==. note E.?. CourseUserNoteUser E.on $ participant E.^. CourseParticipantUser E.==. user E.^. UserId E.where_ $ whereClause t return (user, participant E.^. CourseParticipantRegistration, note E.?. CourseUserNoteId) 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 . _unValue -- FIXME: I am a prism due to maybe _userTableNote :: Lens' UserTableData (Maybe CourseUserNoteId) _userTableNote = _dbrOutput . _3 . _unValue -- default Where-Clause courseIs :: CourseId -> UserTableWhere courseIs cid ((_user `E.InnerJoin` participant) `E.LeftOuterJoin` _note) = participant E.^. CourseParticipantCourse E.==. E.val cid colUserComment :: IsDBTable m a => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m a) colUserComment tid ssh csh = sortable (Just "course-user-note") (i18nCell MsgCourseUserNote) $ \DBRow{ dbrOutput=(Entity uid _, _, E.Value mbNoteKey) } -> maybeEmpty mbNoteKey $ const $ anchorCellM (courseLink <$> encrypt uid) (toWidget $ hasComment True) where courseLink = CourseR tid ssh csh . CUserR -- makeCourseUserTable :: (ToSortable h, Functor h) => -- UserTableWhere -- -> Colonnade -- h -- (DBRow -- (Entity User, E.Value UTCTime, -- E.Value (Maybe CourseUserNoteId))) -- (DBCell (HandlerT UniWorX IO) ()) -- -> PSValidator (HandlerT UniWorX IO) () -- -> ReaderT SqlBackend (HandlerT UniWorX IO) Widget makeCourseUserTable :: UserTableWhere -> _ -> _ -> DB Widget makeCourseUserTable whereClause colChoices psValidator = -- return [whamlet|TODO|] -- TODO -- -- psValidator has default sorting and filtering let dbtIdent = "courseUsers" :: Text dbtStyle = def dbtSQLQuery = userTableQuery whereClause dbtRowKey ((user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note) = user E.^. UserId dbtProj = return -- . dbrOutput -- NOT SURE dbtColonnade = colChoices dbtSorting = Map.fromList [] -- TODO dbtFilter = Map.fromList [] -- TODO dbtFilterUI = mempty -- TODO dbtParams = def in dbTableWidget' psValidator DBTable{..} getCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCUsersR tid ssh csh = do Entity cid course <- runDB $ getBy404 $ TermSchoolCourseShort tid ssh csh let heading = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{display tid}|] whereClause = courseIs cid colChoices = mconcat [ colUserParticipantLink tid ssh csh , colUserMatriclenr -- ,colUserComment tid ssh csh ] psValidator = def tableWidget <- runDB $ makeCourseUserTable whereClause colChoices psValidator siteLayout heading $ do setTitle [shamlet| #{toPathPiece tid} - #{csh}|] -- TODO: creat hamlet wrapper tableWidget getCUserR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDUser -> Handler Html getCUserR _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 uid <- decrypt uCId User{..} <- runDB $ get404 uid -- USE src/utils/Form.formResult defaultLayout -- TODO [whamlet|
^{nameWidget userDisplayName userSurname} |] 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! getCNotesR = error "CNotesR: Not implemented" postCNotesR = error "CNotesR: Not implemented"