102 lines
5.9 KiB
Haskell
102 lines
5.9 KiB
Haskell
module Handler.Utils.Course where
|
|
|
|
import Import
|
|
import Handler.Utils.Delete
|
|
import Handler.Utils.Memcached
|
|
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
import qualified Data.Set as Set
|
|
|
|
|
|
courseDeleteRoute :: Set CourseId -> DeleteRoute Course
|
|
courseDeleteRoute drRecords = DeleteRoute
|
|
{ drRecords
|
|
, drGetInfo = \(course `E.InnerJoin` school) -> do
|
|
E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
|
|
E.orderBy [E.asc $ course E.^. CourseName]
|
|
return (course E.^. CourseName, school E.^. SchoolShorthand, school E.^. SchoolName, course E.^. CourseTerm)
|
|
, drUnjoin = \(course `E.InnerJoin` _) -> course
|
|
, drRenderRecord = \(E.Value cName, _, E.Value sName, E.Value tid') ->
|
|
return [whamlet|
|
|
#{cName} (_{ShortTermIdentifier (unTermKey tid')}, #{sName})
|
|
|]
|
|
, drRecordConfirmString = \(E.Value cName, E.Value ssh', _, E.Value tid') ->
|
|
return [st|#{termToText (unTermKey tid')}/#{ssh'}/#{cName}|]
|
|
, drCaption = SomeMessage MsgCourseDeleteQuestion
|
|
, drSuccessMessage = SomeMessage MsgCourseDeleted
|
|
, drFormMessage = const $ return Nothing
|
|
, drAbort = error "drAbort undefined"
|
|
, drSuccess = error "drSuccess undefined"
|
|
, drDelete = const id -- TODO: audit
|
|
}
|
|
|
|
setUserSubmissionGroup :: ( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
, backend ~ SqlBackend
|
|
, MonadCatch m
|
|
) => CourseId -> UserId -> Maybe SubmissionGroupName -> ReaderT backend m Bool
|
|
setUserSubmissionGroup cid uid = fmap (> 0) . setUsersSubmissionGroup cid (Set.singleton uid)
|
|
|
|
setUsersSubmissionGroup :: ( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
, backend ~ SqlBackend
|
|
, MonadCatch m
|
|
) => CourseId -> Set UserId -> Maybe SubmissionGroupName -> ReaderT backend m Int64
|
|
setUsersSubmissionGroup cid uids Nothing = do
|
|
didDelete <- fmap getSum . flip foldMapM uids $ \uid -> do
|
|
didDelete <- fmap (> 0) . E.deleteCount . E.from $ \submissionGroupUser ->
|
|
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid
|
|
E.&&. E.subSelectForeign submissionGroupUser SubmissionGroupUserSubmissionGroup (E.^. SubmissionGroupCourse) E.==. E.val cid
|
|
when didDelete $ do
|
|
audit $ TransactionSubmissionGroupUnset cid uid
|
|
memcachedByInvalidate AuthCacheSubmissionGroupUserList (Proxy @(Set UserId))
|
|
return $ bool mempty (Sum 1) didDelete
|
|
E.delete . E.from $ \submissionGroup ->
|
|
E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val cid
|
|
E.&&. E.not_ (E.exists . E.from $ \submissionGroupUser -> E.where_ $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId)
|
|
return didDelete
|
|
setUsersSubmissionGroup cid uids (Just grp) = do
|
|
Entity gId _ <- upsert (SubmissionGroup cid grp) [ SubmissionGroupName =. grp ]
|
|
|
|
E.delete . E.from $ \submissionGroupUser ->
|
|
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser `E.in_` E.valList (Set.toList uids)
|
|
E.&&. E.subSelectForeign submissionGroupUser SubmissionGroupUserSubmissionGroup (E.^. SubmissionGroupCourse) E.==. E.val cid
|
|
E.&&. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.!=. E.val gId
|
|
E.delete . E.from $ \submissionGroup ->
|
|
E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val cid
|
|
E.&&. E.not_ (E.exists . E.from $ \submissionGroupUser -> E.where_ $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId)
|
|
E.&&. submissionGroup E.^. SubmissionGroupId E.!=. E.val gId
|
|
fmap getSum . flip foldMapM uids $ \uid -> do
|
|
didSet <- fmap (is _Just) . insertUnique $ SubmissionGroupUser gId uid
|
|
when didSet $ do
|
|
audit $ TransactionSubmissionGroupSet cid uid grp
|
|
memcachedByInvalidate AuthCacheSubmissionGroupUserList (Proxy @(Set UserId))
|
|
return $ bool mempty (Sum 1) didSet
|
|
|
|
showCourseEventRoom :: forall courseEvent courseId.
|
|
E.SqlProject CourseEvent CourseId courseEvent courseId
|
|
=> E.SqlExpr (E.Value UserId) -> E.SqlExpr courseEvent -> E.SqlExpr (E.Value Bool)
|
|
showCourseEventRoom uid courseEvent = E.or
|
|
[ E.exists . E.from $ \(tutor `E.InnerJoin` tutorial) -> do
|
|
E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial
|
|
E.where_ $ tutor E.^. TutorUser E.==. uid
|
|
E.&&. E.unSqlProjectExpr (Proxy @CourseEvent) (Proxy @courseEvent) (tutorial E.^. TutorialCourse) E.==. courseEvent `E.sqlProject` CourseEventCourse
|
|
, E.exists . E.from $ \(sheetCorrector `E.InnerJoin` sheet) -> do
|
|
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
|
|
E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. uid
|
|
E.&&. E.unSqlProjectExpr (Proxy @CourseEvent) (Proxy @courseEvent) (sheet E.^. SheetCourse) E.==. courseEvent `E.sqlProject` CourseEventCourse
|
|
, E.exists . E.from $ \(examCorrector `E.InnerJoin` exam) -> do
|
|
E.on $ exam E.^. ExamId E.==. examCorrector E.^. ExamCorrectorExam
|
|
E.where_ $ examCorrector E.^. ExamCorrectorUser E.==. uid
|
|
E.&&. E.unSqlProjectExpr (Proxy @CourseEvent) (Proxy @courseEvent) (exam E.^. ExamCourse) E.==. courseEvent `E.sqlProject` CourseEventCourse
|
|
, E.exists . E.from $ \courseParticipant ->
|
|
E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
|
E.&&. courseParticipant E.^. CourseParticipantUser E.==. uid
|
|
E.&&. E.unSqlProjectExpr (Proxy @CourseEvent) (Proxy @courseEvent) (courseParticipant E.^. CourseParticipantCourse) E.==. courseEvent `E.sqlProject` CourseEventCourse
|
|
, E.exists . E.from $ \lecturer ->
|
|
E.where_ $ lecturer E.^. LecturerUser E.==. uid
|
|
E.&&. E.unSqlProjectExpr (Proxy @CourseEvent) (Proxy @courseEvent) (lecturer E.^. LecturerCourse) E.==. courseEvent `E.sqlProject` CourseEventCourse
|
|
]
|