refactor: split Handler.Course
This commit is contained in:
Gregor Kleen
parent
84c12b5fc7
commit
4b61c569a9
File diff suppressed because it is too large
Load Diff
71
src/Handler/Course/Communication.hs
Normal file
71
src/Handler/Course/Communication.hs
Normal file
@ -0,0 +1,71 @@
|
||||
module Handler.Course.Communication
|
||||
( postCCommR, getCCommR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Communication
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
|
||||
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
|
||||
E.&&. user E.^. UserId E.==. corrector E.^. SheetCorrectorUser
|
||||
return user
|
||||
)
|
||||
, ( RGCourseTutors
|
||||
, E.from $ \user -> do
|
||||
E.where_ $ E.exists $ E.from $ \(tutorial `E.InnerJoin` tutor) -> do
|
||||
E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial
|
||||
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
|
||||
E.&&. user E.^. UserId E.==. tutor E.^. TutorUser
|
||||
return user
|
||||
)
|
||||
]
|
||||
, crRecipientAuth = Just $ \uid -> do
|
||||
cID <- encrypt uid
|
||||
evalAccessDB (CourseR tid ssh csh $ CUserR cID) False
|
||||
}
|
||||
20
src/Handler/Course/Delete.hs
Normal file
20
src/Handler/Course/Delete.hs
Normal file
@ -0,0 +1,20 @@
|
||||
module Handler.Course.Delete
|
||||
( getCDeleteR, postCDeleteR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils.Course
|
||||
import Handler.Utils.Delete
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
|
||||
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
|
||||
}
|
||||
400
src/Handler/Course/Edit.hs
Normal file
400
src/Handler/Course/Edit.hs
Normal file
@ -0,0 +1,400 @@
|
||||
module Handler.Course.Edit
|
||||
( getCourseNewR, postCourseNewR
|
||||
, getCEditR, postCEditR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Lens
|
||||
import Utils.Form
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Invitations
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import Data.Function ((&))
|
||||
|
||||
import Data.Maybe (fromJust)
|
||||
import qualified Data.Set as Set
|
||||
import Data.Map ((!))
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import Jobs.Queue
|
||||
|
||||
import Handler.Course.LecturerInvite
|
||||
|
||||
|
||||
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] -> [(UserEmail, InvitationDBData Lecturer)] -> 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 (email, mType) | (email, InvDBDataLecturer mType) <- 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 :: Map ListPosition (Either UserEmail UserId) -- ^ 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")
|
||||
|
||||
miIdent :: Text
|
||||
miIdent = "lecturers"
|
||||
|
||||
|
||||
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 (UniWorXMessages [SomeMessage MsgCourseLecturerRightsIdentical, SomeMessage MsgMassInputTip]))
|
||||
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|
|
||||
<div class="alert alert-danger">
|
||||
<div class="alert__content">
|
||||
<h4> Fehler:
|
||||
<ul>
|
||||
$forall errmsg <- errorMsgs
|
||||
<li> #{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
|
||||
)
|
||||
] ]
|
||||
|
||||
|
||||
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 $ sourceInvitationsList . entityKey
|
||||
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
|
||||
|
||||
|
||||
-- | 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 $ CourseR tid ssh csh CShowR
|
||||
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
|
||||
}
|
||||
86
src/Handler/Course/LecturerInvite.hs
Normal file
86
src/Handler/Course/LecturerInvite.hs
Normal file
@ -0,0 +1,86 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Handler.Course.LecturerInvite
|
||||
( lecturerInvitationConfig
|
||||
, getCLecInviteR, postCLecInviteR
|
||||
, InvitableJunction(..), InvitationDBData(..), InvitationTokenData(..)
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Lens
|
||||
import Utils.Form
|
||||
import Handler.Utils.Invitations
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import Data.Function ((&))
|
||||
|
||||
import Data.Aeson hiding (Result(..))
|
||||
|
||||
import Text.Hamlet (ihamlet)
|
||||
|
||||
|
||||
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 { constructorTagModifier = camelToPathPiece' 3 }
|
||||
instance FromJSON (InvitationTokenData Lecturer) where
|
||||
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
||||
|
||||
lecturerInvitationConfig :: InvitationConfig Lecturer
|
||||
lecturerInvitationConfig = InvitationConfig{..}
|
||||
where
|
||||
invitationRoute (Entity _ Course{..}) _ = return . CourseR courseTerm courseSchool courseShorthand $ CLecInviteR
|
||||
invitationResolveFor _ = do
|
||||
Just (CourseR tid csh ssh CLecInviteR) <- getCurrentRoute
|
||||
getKeyBy404 $ TermSchoolCourseShort tid csh ssh
|
||||
invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand
|
||||
invitationHeading (Entity _ Course{..}) _ = return . 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
|
||||
invitationInsertHook _ _ _ _ = id
|
||||
invitationSuccessMsg (Entity _ Course{..}) (Entity _ Lecturer{..}) = do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
return . SomeMessage $ MsgLecturerInvitationAccepted (mr lecturerType) courseShorthand
|
||||
invitationUltDest (Entity _ Course{..}) _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR
|
||||
|
||||
|
||||
getCLecInviteR, postCLecInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCLecInviteR = postCLecInviteR
|
||||
postCLecInviteR = invitationR lecturerInvitationConfig
|
||||
|
||||
260
src/Handler/Course/List.hs
Normal file
260
src/Handler/Course/List.hs
Normal file
@ -0,0 +1,260 @@
|
||||
module Handler.Course.List
|
||||
( makeCourseTable
|
||||
, getCourseListR
|
||||
, getTermCurrentR
|
||||
, getTermSchoolCourseListR
|
||||
, getTermCourseListR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Lens
|
||||
import Utils.Form
|
||||
-- import Utils.DB
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Table.Cells
|
||||
|
||||
import Data.Function ((&))
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
|
||||
-- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method.
|
||||
type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School)
|
||||
|
||||
colCourse :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
|
||||
colCourse = sortable (Just "course") (i18nCell MsgCourse)
|
||||
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
|
||||
anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR)
|
||||
[whamlet|_{courseName}|]
|
||||
|
||||
-- colCourseDescr :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
|
||||
-- colCourseDescr = sortable (Just "course") (i18nCell MsgCourse) $ do
|
||||
-- course <- view $ _dbrOutput . _1 . _entityVal
|
||||
-- return $ courseCell course
|
||||
|
||||
colDescription :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
|
||||
colDescription = sortable Nothing mempty
|
||||
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
|
||||
case courseDescription of
|
||||
Nothing -> mempty
|
||||
(Just descr) -> cell $ modal (toWidget $ hasComment True) (Right $ toWidget descr)
|
||||
|
||||
colCShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
|
||||
colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort)
|
||||
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
|
||||
anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|_{courseShorthand}|]
|
||||
|
||||
-- colCShortDescr :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
|
||||
-- colCShortDescr = sortable (Just "cshort") (i18nCell MsgCourseShort)
|
||||
-- $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> mappend
|
||||
-- ( anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|] )
|
||||
-- ( case courseDescription of
|
||||
-- Nothing -> mempty
|
||||
-- (Just descr) -> cell
|
||||
-- [whamlet|
|
||||
-- $newline never
|
||||
-- <div>
|
||||
-- ^{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|#{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|_{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|_{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 textField (fslI MsgCourseFilterSearch)
|
||||
, muid $> prismAForm (singletonFilter "registered" . maybePrism _PathPiece) mPrev (aopt boolField (fslI MsgCourseFilterRegistered))
|
||||
]
|
||||
, dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
, dbtParams = def
|
||||
, dbtIdent = "courses" :: Text
|
||||
, dbtCsvEncode = noCsvEncode
|
||||
, dbtCsvDecode = Nothing
|
||||
}
|
||||
|
||||
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)) ->
|
||||
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")
|
||||
174
src/Handler/Course/ParticipantInvite.hs
Normal file
174
src/Handler/Course/ParticipantInvite.hs
Normal file
@ -0,0 +1,174 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Handler.Course.ParticipantInvite
|
||||
( InvitableJunction(..), InvitationDBData(..), InvitationTokenData(..)
|
||||
, getCInviteR, postCInviteR
|
||||
, getCAddUserR, postCAddUserR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Lens
|
||||
import Utils.Form
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Invitations
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import Data.Function ((&))
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Jobs.Queue
|
||||
|
||||
import Data.Aeson hiding (Result(..))
|
||||
|
||||
import Text.Hamlet (ihamlet)
|
||||
|
||||
import Control.Monad.Trans.Writer (WriterT, execWriterT)
|
||||
import Control.Monad.Except (MonadError(..))
|
||||
|
||||
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
|
||||
|
||||
|
||||
-- Invitations for ordinary participants of this course
|
||||
instance IsInvitableJunction CourseParticipant where
|
||||
type InvitationFor CourseParticipant = Course
|
||||
data InvitableJunction CourseParticipant = JunctionParticipant
|
||||
{ jParticipantRegistration :: UTCTime
|
||||
, jParticipantField :: Maybe StudyFeaturesId
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
data InvitationDBData CourseParticipant = InvDBDataParticipant
|
||||
-- no data needed in DB to manage participant invitation
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
data InvitationTokenData CourseParticipant = InvTokenDataParticipant
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
_InvitableJunction = iso
|
||||
(\CourseParticipant{..} -> (courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField))
|
||||
(\(courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField) -> CourseParticipant{..})
|
||||
|
||||
instance ToJSON (InvitableJunction CourseParticipant) where
|
||||
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
instance FromJSON (InvitableJunction CourseParticipant) where
|
||||
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
|
||||
instance ToJSON (InvitationDBData CourseParticipant) where
|
||||
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
||||
instance FromJSON (InvitationDBData CourseParticipant) where
|
||||
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
|
||||
|
||||
instance ToJSON (InvitationTokenData CourseParticipant) where
|
||||
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
||||
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
||||
instance FromJSON (InvitationTokenData CourseParticipant) where
|
||||
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
|
||||
|
||||
participantInvitationConfig :: InvitationConfig CourseParticipant
|
||||
participantInvitationConfig = InvitationConfig{..}
|
||||
where
|
||||
invitationRoute (Entity _ Course{..}) _ = return $ CourseR courseTerm courseSchool courseShorthand CInviteR
|
||||
invitationResolveFor _ = do
|
||||
Just (CourseR tid csh ssh CInviteR) <- getCurrentRoute
|
||||
getKeyBy404 $ TermSchoolCourseShort tid csh ssh
|
||||
invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectParticipantInvitation courseTerm courseSchool courseShorthand
|
||||
invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName
|
||||
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|]
|
||||
invitationTokenConfig _ _ = do
|
||||
itAuthority <- liftHandlerT requireAuthId
|
||||
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
|
||||
invitationRestriction _ _ = return Authorized
|
||||
invitationForm (Entity _ Course{..}) _ uid = hoistAForm lift . wFormToAForm $ do
|
||||
now <- liftIO getCurrentTime
|
||||
studyFeatures <- wreq (studyFeaturesPrimaryFieldFor False [] $ Just uid)
|
||||
(fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTooltip) Nothing
|
||||
return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures
|
||||
invitationInsertHook _ _ _ _ = id
|
||||
invitationSuccessMsg (Entity _ Course{..}) _ =
|
||||
return . SomeMessage $ MsgCourseParticipantInvitationAccepted (CI.original courseName)
|
||||
invitationUltDest (Entity _ Course{..}) _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR
|
||||
|
||||
data AddRecipientsResult = AddRecipientsResult
|
||||
{ aurAlreadyRegistered
|
||||
, aurNoUniquePrimaryField
|
||||
, aurSuccess :: [UserEmail]
|
||||
} deriving (Read, Show, Generic, Typeable)
|
||||
|
||||
instance Monoid AddRecipientsResult where
|
||||
mempty = memptydefault
|
||||
mappend = mappenddefault
|
||||
|
||||
getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCAddUserR = postCAddUserR
|
||||
postCAddUserR tid ssh csh = do
|
||||
cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
((usersToEnlist,formWgt),formEncoding) <- runFormPost . renderWForm FormStandard $ do
|
||||
enlist <- wreq checkBoxField (fslI MsgCourseParticipantEnlistDirectly) (Just False)
|
||||
wreq (multiUserField (maybe True not $ formResultToMaybe enlist) Nothing)
|
||||
(fslI MsgCourseParticipantInviteField & setTooltip MsgMultiEmailFieldTip) Nothing
|
||||
|
||||
formResultModal usersToEnlist (CourseR tid ssh csh CUsersR) $ processUsers cid
|
||||
|
||||
let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading
|
||||
|
||||
siteLayoutMsg heading $ do
|
||||
setTitleI heading
|
||||
wrapForm formWgt def
|
||||
{ formEncoding
|
||||
, formAction = Just . SomeRoute $ CourseR tid ssh csh CAddUserR
|
||||
}
|
||||
where
|
||||
processUsers :: CourseId -> Set (Either UserEmail UserId) -> WriterT [Message] Handler ()
|
||||
processUsers cid users = do
|
||||
let (emails,uids) = partitionEithers $ Set.toList users
|
||||
AddRecipientsResult{..} <- lift . runDBJobs $ do
|
||||
-- send Invitation eMails to unkown users
|
||||
sinkInvitationsF participantInvitationConfig [(mail,cid,(InvDBDataParticipant,InvTokenDataParticipant)) | mail <- emails]
|
||||
-- register known users
|
||||
execWriterT $ mapM (registerUser cid) uids
|
||||
|
||||
when (not $ null emails) $
|
||||
tell . pure <=< messageI Success . MsgCourseParticipantsInvited $ length emails
|
||||
|
||||
when (not $ null aurAlreadyRegistered) $ do
|
||||
let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyRegistered (length aurAlreadyRegistered)}|]
|
||||
modalContent = $(widgetFile "messages/courseInvitationAlreadyRegistered")
|
||||
tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent)
|
||||
|
||||
when (not $ null aurNoUniquePrimaryField) $ do
|
||||
let modalTrigger = [whamlet|_{MsgCourseParticipantsRegisteredWithoutField (length aurNoUniquePrimaryField)}|]
|
||||
modalContent = $(widgetFile "messages/courseInvitationRegisteredWithoutField")
|
||||
tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent)
|
||||
|
||||
when (not $ null aurSuccess) $
|
||||
tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length aurSuccess
|
||||
|
||||
registerUser :: CourseId -> UserId -> WriterT AddRecipientsResult (YesodJobDB UniWorX) ()
|
||||
registerUser cid uid = exceptT tell tell $ do
|
||||
User{..} <- lift . lift $ getJust uid
|
||||
|
||||
whenM (lift . lift . existsBy $ UniqueParticipant uid cid) $
|
||||
throwError $ mempty { aurAlreadyRegistered = pure userEmail }
|
||||
|
||||
features <- lift . lift $ selectKeysList [ StudyFeaturesUser ==. uid, StudyFeaturesValid ==. True, StudyFeaturesType ==. FieldPrimary ] []
|
||||
|
||||
let courseParticipantField
|
||||
| [f] <- features = Just f
|
||||
| otherwise = Nothing
|
||||
|
||||
courseParticipantRegistration <- liftIO getCurrentTime
|
||||
void . lift . lift . insert $ CourseParticipant
|
||||
{ courseParticipantCourse = cid
|
||||
, courseParticipantUser = uid
|
||||
, ..
|
||||
}
|
||||
|
||||
return $ case courseParticipantField of
|
||||
Nothing -> mempty { aurNoUniquePrimaryField = pure userEmail }
|
||||
Just _ -> mempty { aurSuccess = pure userEmail }
|
||||
|
||||
|
||||
getCInviteR, postCInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCInviteR = postCInviteR
|
||||
postCInviteR = invitationR participantInvitationConfig
|
||||
96
src/Handler/Course/Register.hs
Normal file
96
src/Handler/Course/Register.hs
Normal file
@ -0,0 +1,96 @@
|
||||
module Handler.Course.Register
|
||||
( ButtonCourseRegister(..)
|
||||
, courseRegisterForm
|
||||
, getCRegisterR, postCRegisterR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Form
|
||||
import Handler.Utils
|
||||
|
||||
import Data.Function ((&))
|
||||
|
||||
|
||||
-- Dedicated CourseRegistrationButton
|
||||
data ButtonCourseRegister = BtnCourseRegister | BtnCourseDeregister
|
||||
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
||||
instance Universe ButtonCourseRegister
|
||||
instance Finite ButtonCourseRegister
|
||||
nullaryPathPiece ''ButtonCourseRegister $ camelToPathPiece' 1
|
||||
embedRenderMessage ''UniWorX ''ButtonCourseRegister id
|
||||
instance Button UniWorX ButtonCourseRegister where
|
||||
btnClasses BtnCourseRegister = [BCIsButton, BCPrimary]
|
||||
btnClasses BtnCourseDeregister = [BCIsButton, BCDanger]
|
||||
|
||||
btnLabel BtnCourseRegister = [whamlet|#{iconEnrol True} _{MsgBtnCourseRegister}|]
|
||||
btnLabel BtnCourseDeregister = [whamlet|#{iconEnrol False} _{MsgBtnCourseDeregister}|]
|
||||
|
||||
|
||||
-- | Registration button with maybe a userid if logged in
|
||||
-- , maybe existing features if already registered
|
||||
-- , maybe some default study features
|
||||
-- , maybe a course secret
|
||||
courseRegisterForm :: 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
|
||||
courseRegisterForm 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 False [sfid] loggedin) (fslI MsgCourseStudyFeature) (Just sfid)
|
||||
_other -> mreq (studyFeaturesPrimaryFieldFor False [ ] loggedin) (fslI MsgCourseStudyFeature
|
||||
& setTooltip MsgCourseStudyFeatureTooltip) (Just defSFid)
|
||||
-- button de-/register
|
||||
(btnRes, btnView) <- mreq (buttonField $ bool BtnCourseRegister BtnCourseDeregister 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
|
||||
|
||||
|
||||
-- | Workaround for klicking register button without being logged in.
|
||||
-- After log in, the user sees a "get request not supported" error.
|
||||
getCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCRegisterR tid ssh csh = do
|
||||
muid <- maybeAuthId
|
||||
case muid of
|
||||
Nothing -> addMessageI Info MsgLoginNecessary
|
||||
(Just uid) -> runDB $ do
|
||||
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
registration <- getBy (UniqueParticipant uid cid)
|
||||
when (isNothing registration) $ addMessageI Warning MsgRegisterRetry
|
||||
redirect $ CourseR tid ssh csh CShowR
|
||||
|
||||
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 $ courseRegisterForm (Just aid) registration Nothing $ courseRegisterSecret course
|
||||
formResult regResult $ \(mbSfId,codeOk) -> if
|
||||
| isRegistered -> do
|
||||
runDB $ deleteBy $ UniqueParticipant aid cid
|
||||
addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk
|
||||
| codeOk -> do
|
||||
actTime <- liftIO getCurrentTime
|
||||
regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime mbSfId
|
||||
when (isJust regOk) $ addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk
|
||||
| otherwise -> addMessageI Warning MsgCourseSecretWrong
|
||||
-- addMessage Info $ toHtml $ show regResult -- For debugging only
|
||||
redirect $ CourseR tid ssh csh CShowR
|
||||
221
src/Handler/Course/Show.hs
Normal file
221
src/Handler/Course/Show.hs
Normal file
@ -0,0 +1,221 @@
|
||||
module Handler.Course.Show
|
||||
( getCShowR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Form
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Table.Cells
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import Database.Esqueleto.Utils.TH
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import Data.Function ((&))
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import Handler.Course.Register
|
||||
|
||||
|
||||
getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCShowR tid ssh csh = do
|
||||
mbAid <- maybeAuthId
|
||||
(cid,course,schoolName,participants,registration,defSFid,lecturers,assistants,correctors,tutors) <- 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
|
||||
correctors <- fmap (map $(unValueN 3)) . lift . E.select $ E.from $ \(sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> E.distinctOnOrderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName, E.asc $ user E.^. UserEmail ] $ do
|
||||
E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
|
||||
E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
|
||||
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
||||
E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ]
|
||||
return ( user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname )
|
||||
tutors <- fmap (map $(unValueN 3)) . lift . E.select $ E.from $ \(tutorial `E.InnerJoin` tutor `E.InnerJoin` user) -> E.distinctOnOrderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName, E.asc $ user E.^. UserEmail ] $ do
|
||||
E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
|
||||
E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
|
||||
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
|
||||
E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ]
|
||||
return ( user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname )
|
||||
return (cid,course,schoolName,participants,registration,entityKey <$> defSFid,lecturers,assistants,correctors,tutors)
|
||||
|
||||
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 $ courseRegisterForm 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
|
||||
|
||||
let
|
||||
tutorialDBTable = DBTable{..}
|
||||
where
|
||||
dbtSQLQuery tutorial = do
|
||||
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
|
||||
return tutorial
|
||||
dbtRowKey = (E.^. TutorialId)
|
||||
dbtProj = return
|
||||
dbtColonnade = dbColonnade $ mconcat
|
||||
[ sortable (Just "type") (i18nCell MsgTutorialType) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> textCell $ CI.original tutorialType
|
||||
, sortable (Just "name") (i18nCell MsgTutorialName) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> indicatorCell <> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|]
|
||||
, sortable Nothing (i18nCell MsgTutorialTutors) $ \DBRow{ dbrOutput = Entity 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
|
||||
return (user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname)
|
||||
return [whamlet|
|
||||
$newline never
|
||||
<ul .list--iconless .list--inline .list--comma-separated>
|
||||
$forall tutor <- tutTutors
|
||||
<li>
|
||||
^{nameEmailWidget' tutor}
|
||||
|]
|
||||
, sortable (Just "room") (i18nCell MsgTutorialRoom) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> 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
|
||||
Nothing -> mempty
|
||||
Just tutorialCapacity' -> sqlCell $ do
|
||||
[E.Value freeCapacity] <- E.select $ let numParticipants = E.sub_select . E.from $ \participant -> do
|
||||
E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid
|
||||
return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int))
|
||||
in return $ E.val tutorialCapacity' E.-. numParticipants
|
||||
return . toWidget . tshow $ max 0 freeCapacity
|
||||
, sortable Nothing mempty $ \DBRow{ dbrOutput = Entity tutId Tutorial{..} } -> sqlCell $ do
|
||||
mayRegister <- (== Authorized) <$> evalAccessDB (CTutorialR tid ssh csh tutorialName TRegisterR) True
|
||||
isRegistered <- case mbAid of
|
||||
Nothing -> return False
|
||||
Just uid -> existsBy $ UniqueTutorialParticipant tutId uid
|
||||
if
|
||||
| mayRegister -> do
|
||||
(tutRegisterForm, tutRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
|
||||
return $ wrapForm tutRegisterForm def
|
||||
{ formAction = Just . SomeRoute $ CTutorialR tid ssh csh tutorialName TRegisterR
|
||||
, formEncoding = tutRegisterEnctype
|
||||
, formSubmit = FormNoSubmit
|
||||
}
|
||||
| isRegistered -> return [whamlet|_{MsgTutorialRegistered}|]
|
||||
| otherwise -> return mempty
|
||||
]
|
||||
dbtSorting = Map.fromList
|
||||
[ ("type", SortColumn $ \tutorial -> tutorial E.^. TutorialType )
|
||||
, ("name", SortColumn $ \tutorial -> tutorial E.^. TutorialName )
|
||||
, ("room", SortColumn $ \tutorial -> tutorial E.^. TutorialRoom )
|
||||
, ("register-from", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterFrom )
|
||||
, ("register-to", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterTo )
|
||||
, ("deregister-until", SortColumn $ \tutorial -> tutorial E.^. TutorialDeregisterUntil )
|
||||
]
|
||||
dbtFilter = Map.empty
|
||||
dbtFilterUI = const mempty
|
||||
dbtStyle = def
|
||||
dbtParams = def
|
||||
dbtIdent :: Text
|
||||
dbtIdent = "tutorials"
|
||||
dbtCsvEncode = noCsvEncode
|
||||
dbtCsvDecode = Nothing
|
||||
|
||||
tutorialDBTableValidator = def
|
||||
& defaultSorting [SortAscBy "type", SortAscBy "name"]
|
||||
(Any hasTutorials, tutorialTable) <- runDB $ dbTable tutorialDBTableValidator tutorialDBTable
|
||||
|
||||
let
|
||||
examDBTable = DBTable{..}
|
||||
where
|
||||
dbtSQLQuery exam = do
|
||||
E.where_ $ exam E.^. ExamCourse E.==. E.val cid
|
||||
return exam
|
||||
dbtRowKey = (E.^. ExamId)
|
||||
dbtProj r@DBRow{ dbrOutput = Entity _ Exam{..} } = do
|
||||
guardM . hasReadAccessTo $ CExamR tid ssh csh examName EShowR
|
||||
return r
|
||||
dbtColonnade = dbColonnade $ mconcat
|
||||
[ sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> indicatorCell <> anchorCell (CExamR tid ssh csh examName EShowR) examName
|
||||
, sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom
|
||||
, sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
|
||||
, sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart
|
||||
, sortable (Just "registered") (i18nCell MsgExamRegistration ) $ \DBRow{ dbrOutput = Entity eId Exam{..} } -> sqlCell $ do
|
||||
mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True
|
||||
isRegistered <- case mbAid of
|
||||
Nothing -> return False
|
||||
Just uid -> existsBy $ UniqueExamRegistration eId uid
|
||||
let label = bool MsgExamNotRegistered MsgExamRegistered isRegistered
|
||||
examUrl = CExamR tid ssh csh examName EShowR
|
||||
if | mayRegister -> return $ simpleLinkI (SomeMessage label) examUrl
|
||||
| otherwise -> return [whamlet|_{label}|]
|
||||
-- , sortable Nothing mempty $ \DBRow{ dbrOutput = Entity eId Exam{..} } -> sqlCell $ do
|
||||
-- mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True
|
||||
-- isRegistered <- case mbAid of
|
||||
-- Nothing -> return False
|
||||
-- Just uid -> existsBy $ UniqueExamRegistration eId uid
|
||||
-- if
|
||||
-- | mayRegister -> do
|
||||
-- (examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered
|
||||
-- return $ wrapForm examRegisterForm def
|
||||
-- { formAction = Just . SomeRoute $ CExamR tid ssh csh examName ERegisterR
|
||||
-- , formEncoding = examRegisterEnctype
|
||||
-- , formSubmit = FormNoSubmit
|
||||
-- }
|
||||
-- | isRegistered -> return [whamlet|_{MsgExamRegistered}|]
|
||||
-- | otherwise -> return mempty
|
||||
]
|
||||
dbtSorting = Map.fromList
|
||||
[ ("name", SortColumn $ \exam -> exam E.^. ExamName )
|
||||
, ("time", SortColumn $ \exam -> exam E.^. ExamStart )
|
||||
, ("register-from", SortColumn $ \exam -> exam E.^. ExamRegisterFrom )
|
||||
, ("register-to", SortColumn $ \exam -> exam E.^. ExamRegisterTo )
|
||||
, ("visible", SortColumn $ \exam -> exam E.^. ExamVisibleFrom )
|
||||
, ("registered", SortColumn $ \exam ->
|
||||
case mbAid of
|
||||
Nothing -> E.false
|
||||
Just uid ->
|
||||
E.exists $ E.from $ \reg -> do
|
||||
E.where_ $ reg E.^. ExamRegistrationUser E.==. E.val uid
|
||||
E.where_ $ reg E.^. ExamRegistrationExam E.==. exam E.^. ExamId
|
||||
)
|
||||
]
|
||||
dbtFilter = Map.empty
|
||||
dbtFilterUI = const mempty
|
||||
dbtStyle = def
|
||||
dbtParams = def
|
||||
dbtIdent :: Text
|
||||
dbtIdent = "exams"
|
||||
dbtCsvEncode = noCsvEncode
|
||||
dbtCsvDecode = Nothing
|
||||
|
||||
examDBTableValidator = def
|
||||
& defaultSorting [SortAscBy "time"]
|
||||
(Any hasExams, examTable) <- runDB $ dbTable examDBTableValidator examDBTable
|
||||
|
||||
siteLayout (toWgt $ courseName course) $ do
|
||||
setTitleI $ prependCourseTitle tid ssh csh (""::Text)
|
||||
$(widgetFile "course")
|
||||
162
src/Handler/Course/User.hs
Normal file
162
src/Handler/Course/User.hs
Normal file
@ -0,0 +1,162 @@
|
||||
module Handler.Course.User
|
||||
( getCUserR, postCUserR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Lens
|
||||
import Utils.Form
|
||||
import Handler.Utils
|
||||
import Database.Esqueleto.Utils.TH
|
||||
|
||||
import Data.Function ((&))
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import Text.Blaze.Html.Renderer.Text (renderHtml)
|
||||
|
||||
import Handler.Course.Register
|
||||
|
||||
|
||||
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{..}, mRegistration, thisUniqueNote, noteText, noteEdits, studies) <- runDB $ do
|
||||
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
-- Abfrage Benutzerdaten
|
||||
user <- get404 uid
|
||||
registration <- 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
|
||||
<br>
|
||||
_{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)
|
||||
let noteFrag :: Text
|
||||
noteFrag = "notes"
|
||||
noteWidget = wrapForm noteView FormSettings
|
||||
{ formMethod = POST
|
||||
, formAction = Just . SomeRoute $ currentRoute :#: noteFrag
|
||||
, formEncoding = noteEnctype
|
||||
, formAttrs = []
|
||||
, formSubmit = FormSubmit
|
||||
, formAnchor = Just noteFrag
|
||||
}
|
||||
formResult noteRes $ \mbNote -> do
|
||||
now <- liftIO getCurrentTime
|
||||
runDB $ case mbNote of
|
||||
Nothing -> 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
|
||||
_ | (renderHtml <$> mbNote) == (renderHtml <$> noteText) -> return () -- no changes
|
||||
(Just note) -> do
|
||||
(Entity noteKey _) <- upsertBy thisUniqueNote (CourseUserNote cid uid note) [CourseUserNoteNote =. note]
|
||||
void . insert $ CourseUserNoteEdit dozentId now noteKey
|
||||
addMessageI Success MsgCourseUserNoteSaved
|
||||
redirect $ currentRoute :#: noteFrag -- reload page after post
|
||||
|
||||
((regFieldRes, regFieldView), regFieldEnctype) <- runFormPost . identifyForm FIDcRegField $ \csrf ->
|
||||
let currentField :: Maybe (Maybe StudyFeaturesId)
|
||||
currentField = courseParticipantField . entityVal <$> mRegistration
|
||||
in over _2 ((toWidget csrf <>) . fvInput) <$> mreq (studyFeaturesPrimaryFieldFor True (maybeToList $ join currentField) $ Just uid) ("" & addAutosubmit) currentField
|
||||
|
||||
let registrationFieldFrag :: Text
|
||||
registrationFieldFrag = "registration-field"
|
||||
regFieldWidget = wrapForm regFieldView FormSettings
|
||||
{ formMethod = POST
|
||||
, formAction = Just . SomeRoute $ currentRoute :#: registrationFieldFrag
|
||||
, formEncoding = regFieldEnctype
|
||||
, formAttrs = []
|
||||
, formSubmit = FormAutoSubmit
|
||||
, formAnchor = Just registrationFieldFrag
|
||||
}
|
||||
for_ mRegistration $ \(Entity pId CourseParticipant{..}) ->
|
||||
formResult regFieldRes $ \courseParticipantField' -> do
|
||||
runDB $ do
|
||||
update pId [ CourseParticipantField =. courseParticipantField' ]
|
||||
addMessageI Success MsgCourseStudyFeatureUpdated
|
||||
redirect $ currentRoute :#: registrationFieldFrag
|
||||
|
||||
let regButton
|
||||
| Just _ <- mRegistration = BtnCourseDeregister
|
||||
| otherwise = BtnCourseRegister
|
||||
((regButtonRes, regButtonView), regButtonEnctype) <- runFormPost . identifyForm FIDcRegButton $ buttonForm' [regButton]
|
||||
|
||||
let registrationButtonFrag :: Text
|
||||
registrationButtonFrag = "registration-button"
|
||||
regButtonWidget = wrapForm regButtonView FormSettings
|
||||
{ formMethod = POST
|
||||
, formAction = Just . SomeRoute $ currentRoute :#: registrationButtonFrag
|
||||
, formEncoding = regButtonEnctype
|
||||
, formAttrs = []
|
||||
, formSubmit = FormNoSubmit
|
||||
, formAnchor = Just registrationButtonFrag
|
||||
}
|
||||
formResult regButtonRes $ \case
|
||||
BtnCourseDeregister
|
||||
| Just (Entity pId _) <- mRegistration
|
||||
-> do
|
||||
runDB $ delete pId
|
||||
addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk
|
||||
redirect $ CourseR tid ssh csh CUsersR
|
||||
| otherwise
|
||||
-> invalidArgs ["User not registered"]
|
||||
BtnCourseRegister -> do
|
||||
now <- liftIO getCurrentTime
|
||||
let primaryField
|
||||
| [(Entity featId _, _, _)] <- filter (\(Entity _ StudyFeatures{..}, _, _) -> studyFeaturesType == FieldPrimary && studyFeaturesValid) studies
|
||||
= Just featId
|
||||
| otherwise
|
||||
= Nothing
|
||||
pId <- runDB . insertUnique $ CourseParticipant cid uid now primaryField
|
||||
case pId of
|
||||
Just _ -> do
|
||||
addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk
|
||||
redirect currentRoute
|
||||
Nothing -> invalidArgs ["User already registered"]
|
||||
|
||||
mRegAt <- for (courseParticipantRegistration . entityVal <$> mRegistration) $ formatTime SelFormatDateTime
|
||||
|
||||
-- generate output
|
||||
let headingLong = [whamlet|^{nameWidget userDisplayName userSurname} - _{MsgCourseMemberOf} #{csh} #{tid}|]
|
||||
headingShort = prependCourseTitle tid ssh csh $ SomeMessage userDisplayName
|
||||
siteLayout headingLong $ do
|
||||
setTitleI headingShort
|
||||
$(widgetFile "course-user")
|
||||
264
src/Handler/Course/Users.hs
Normal file
264
src/Handler/Course/Users.hs
Normal file
@ -0,0 +1,264 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Handler.Course.Users
|
||||
( queryUser
|
||||
, makeCourseUserTable
|
||||
, postCUsersR, getCUsersR
|
||||
, colUserDegreeShort, colUserField, colUserSemester
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Lens
|
||||
import Utils.Form
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Database
|
||||
import Handler.Utils.Table.Cells
|
||||
import Handler.Utils.Table.Columns
|
||||
import Database.Persist.Sql (deleteWhereCount)
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import Database.Esqueleto.Utils.TH
|
||||
|
||||
import Data.Function ((&))
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
|
||||
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 $ (note E.?. CourseUserNoteUser E.==. E.just (participant E.^. CourseParticipantUser))
|
||||
E.&&. (note E.?. CourseUserNoteCourse E.==. E.just (E.val cid))
|
||||
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) (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 :: forall h act.
|
||||
( Functor h, ToSortable h
|
||||
, RenderMessage UniWorX act, Eq act, PathPiece act, Finite act)
|
||||
=> CourseId
|
||||
-> (UserTableExpr -> E.SqlExpr (E.Value Bool))
|
||||
-> Colonnade h UserTableData (DBCell (MForm Handler) (FormResult (First act, DBFormResult UserId Bool UserTableData)))
|
||||
-> PSValidator (MForm Handler) (FormResult (First act, DBFormResult UserId Bool UserTableData))
|
||||
-> DB (FormResult (act, Set UserId), Widget)
|
||||
makeCourseUserTable cid restrict colChoices psValidator = do
|
||||
Just currentRoute <- liftHandlerT getCurrentRoute
|
||||
-- -- psValidator has default sorting and filtering
|
||||
let dbtIdent = "courseUsers" :: Text
|
||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||
dbtSQLQuery q = userTableQuery cid q <* E.where_ (restrict q)
|
||||
dbtRowKey = queryUser >>> (E.^. UserId)
|
||||
dbtProj = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms))
|
||||
dbtColonnade = colChoices
|
||||
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.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsName)
|
||||
, E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsShorthand)
|
||||
, E.mkExactFilterWith readMay $ queryFeaturesField >>> (E.?. StudyTermsKey)
|
||||
] )
|
||||
, ("degree" , FilterColumn $ E.anyFilter
|
||||
[ E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeName)
|
||||
, E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeShorthand)
|
||||
, E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey)
|
||||
] )
|
||||
, ("semesternr" , FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
|
||||
, ("tutorial" , FilterColumn $ E.mkExistsFilter $ \row criterion ->
|
||||
E.from $ \(tutorial `E.InnerJoin` tutorialParticipant) -> do
|
||||
E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
|
||||
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
|
||||
E.&&. E.hasInfix (tutorial E.^. TutorialName) (E.val criterion :: E.SqlExpr (E.Value (CI Text)))
|
||||
E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser row E.^. UserId
|
||||
)
|
||||
-- , ("course-registration", error "TODO") -- TODO
|
||||
-- , ("course-user-note", error "TODO") -- TODO
|
||||
]
|
||||
dbtFilterUI mPrev = mconcat
|
||||
[ fltrUserNameEmailUI mPrev
|
||||
, fltrUserMatriclenrUI mPrev
|
||||
, prismAForm (singletonFilter "degree") mPrev $ aopt textField (fslI MsgStudyFeatureDegree)
|
||||
, prismAForm (singletonFilter "field") mPrev $ aopt textField (fslI MsgCourseStudyFeature)
|
||||
, prismAForm (singletonFilter "tutorial") mPrev $ aopt textField (fslI MsgCourseTutorial)
|
||||
]
|
||||
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
|
||||
}
|
||||
dbtCsvEncode = noCsvEncode
|
||||
dbtCsvDecode = Nothing
|
||||
over _1 postprocess <$> dbTable psValidator DBTable{..}
|
||||
where
|
||||
postprocess :: FormResult (First act, DBFormResult UserId Bool UserTableData) -> FormResult (act, Set UserId)
|
||||
postprocess inp = do
|
||||
(First (Just act), usrMap) <- inp
|
||||
let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
|
||||
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 MsgRegisteredSince) (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 (const E.true) 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} #{tid}|]
|
||||
headingShort = prependCourseTitle tid ssh csh MsgCourseMembers
|
||||
siteLayout headingLong $ do
|
||||
setTitleI headingShort
|
||||
$(widgetFile "course-participants")
|
||||
@ -1,6 +1,8 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Handler.Tutorial where
|
||||
module Handler.Tutorial
|
||||
( module Handler.Tutorial
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
@ -28,6 +30,8 @@ import Utils.Lens
|
||||
import Data.Aeson hiding (Result(..))
|
||||
import Text.Hamlet (ihamlet)
|
||||
|
||||
import Handler.Tutorial.Users as Handler.Tutorial
|
||||
|
||||
{-# ANN module ("Hlint: ignore Redundant void" :: String) #-}
|
||||
|
||||
|
||||
|
||||
73
src/Handler/Tutorial/Users.hs
Normal file
73
src/Handler/Tutorial/Users.hs
Normal file
@ -0,0 +1,73 @@
|
||||
module Handler.Tutorial.Users
|
||||
( getTUsersR, postTUsersR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Lens
|
||||
import Utils.Form
|
||||
-- import Utils.DB
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Tutorial
|
||||
import Handler.Utils.Table.Columns
|
||||
import Database.Persist.Sql (deleteWhereCount)
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import Data.Function ((&))
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import Handler.Course.Users
|
||||
|
||||
|
||||
data TutorialUserAction = TutorialUserSendMail | TutorialUserDeregister
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
||||
|
||||
instance Universe TutorialUserAction
|
||||
instance Finite TutorialUserAction
|
||||
nullaryPathPiece ''TutorialUserAction $ camelToPathPiece' 2
|
||||
embedRenderMessage ''UniWorX ''TutorialUserAction id
|
||||
|
||||
|
||||
getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
|
||||
getTUsersR = postTUsersR
|
||||
postTUsersR tid ssh csh tutn = do
|
||||
(Entity tutid Tutorial{..}, (participantRes, participantTable)) <- runDB $ do
|
||||
tut@(Entity tutid _) <- fetchTutorial tid ssh csh tutn
|
||||
let colChoices = mconcat
|
||||
[ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
|
||||
, colUserName
|
||||
, colUserEmail
|
||||
, colUserMatriclenr
|
||||
, colUserDegreeShort
|
||||
, colUserField
|
||||
, colUserSemester
|
||||
]
|
||||
psValidator = def
|
||||
& defaultSortingByName
|
||||
& restrictSorting (\name _ -> none (== name) ["note"]) -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
|
||||
isInTut q = E.exists . E.from $ \tutorialParticipant ->
|
||||
E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser q E.^. UserId
|
||||
E.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid
|
||||
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
table <- makeCourseUserTable cid isInTut colChoices psValidator
|
||||
return (tut, table)
|
||||
|
||||
formResult participantRes $ \case
|
||||
(TutorialUserSendMail, selectedUsers) -> do
|
||||
cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser]
|
||||
redirect (CTutorialR tid ssh csh tutn TCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids])
|
||||
(TutorialUserDeregister,selectedUsers) -> do
|
||||
nrDel <- runDB $ deleteWhereCount
|
||||
[ TutorialParticipantTutorial ==. tutid
|
||||
, TutorialParticipantUser <-. Set.toList selectedUsers
|
||||
]
|
||||
addMessageI Success $ MsgTutorialUsersDeregistered nrDel
|
||||
redirect $ CTutorialR tid ssh csh tutn TUsersR
|
||||
|
||||
let heading = prependCourseTitle tid ssh csh $ CI.original tutorialName
|
||||
siteLayoutMsg heading $ do
|
||||
setTitleI heading
|
||||
$(widgetFile "tutorial-participants")
|
||||
@ -1,5 +1,5 @@
|
||||
<h2>
|
||||
_{MsgCourseParticipantsAlreadyRegistered (length alreadyRegistered)}
|
||||
_{MsgCourseParticipantsAlreadyRegistered (length aurAlreadyRegistered)}
|
||||
<ul>
|
||||
$forall email <- alreadyRegistered
|
||||
$forall email <- aurAlreadyRegistered
|
||||
<li style="font-family: monospace">#{email}
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
<h2>
|
||||
_{MsgCourseParticipantsRegisteredWithoutField (length registeredNoField)}
|
||||
_{MsgCourseParticipantsRegisteredWithoutField (length aurNoUniquePrimaryField)}
|
||||
<ul>
|
||||
$forall email <- registeredNoField
|
||||
$forall email <- aurNoUniquePrimaryField
|
||||
<li style="font-family: monospace">#{email}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user