73 lines
3.7 KiB
Haskell
73 lines
3.7 KiB
Haskell
module Handler.Utils.Course where
|
|
|
|
import Import
|
|
import Handler.Utils.Delete
|
|
|
|
import qualified Database.Esqueleto 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 $
|
|
audit $ TransactionSubmissionGroupUnset cid uid
|
|
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 $
|
|
audit $ TransactionSubmissionGroupSet cid uid grp
|
|
return $ bool mempty (Sum 1) didSet
|