217 lines
12 KiB
Haskell
217 lines
12 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -- ihamletFile discards do results
|
|
|
|
module Jobs.Handler.SendNotification.Allocation
|
|
( dispatchNotificationAllocationStaffRegister
|
|
, dispatchNotificationAllocationRegister
|
|
, dispatchNotificationAllocationAllocation
|
|
, dispatchNotificationAllocationUnratedApplications
|
|
, dispatchNotificationAllocationResults
|
|
, dispatchNotificationAllocationNewCourse
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Handler.Utils
|
|
import Jobs.Handler.SendNotification.Utils
|
|
|
|
import Handler.Info (FAQItem(..))
|
|
|
|
import Text.Hamlet
|
|
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
|
|
dispatchNotificationAllocationStaffRegister :: Set AllocationId -> UserId -> Handler ()
|
|
dispatchNotificationAllocationStaffRegister (otoList -> nAllocations) jRecipient = userMailT jRecipient $ do
|
|
allocs <- fmap (sortOn $ \Allocation{..} -> (allocationSchool, allocationName)) . liftHandler . runDB $ mapM getJust nAllocations
|
|
|
|
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
|
|
case allocs of
|
|
[Allocation{..}] ->
|
|
setSubjectI $ MsgMailSubjectAllocationStaffRegister allocationSchool allocationName
|
|
_other ->
|
|
setSubjectI . MsgMailSubjectAllocationStaffRegisterMultiple $ length allocs
|
|
editNotifications <- mkEditNotifications jRecipient
|
|
deadlines <- forM allocs $ \alloc@Allocation{..} -> (alloc,) <$> traverse (formatTime SelFormatDateTime) allocationStaffRegisterTo
|
|
let doRegisterDeadlines = any (is _Just . allocationStaffRegisterTo) allocs
|
|
singleRegisterDeadline = maybe True (flip all (allocs ^.. folded . _allocationStaffRegisterTo) . (==)) $ allocs ^? _head . _allocationStaffRegisterTo
|
|
addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/allocationStaffRegister.hamlet")
|
|
|
|
dispatchNotificationAllocationRegister :: Set AllocationId -> UserId -> Handler ()
|
|
dispatchNotificationAllocationRegister (otoList -> nAllocations) jRecipient = userMailT jRecipient $ do
|
|
allocs <- fmap (sortOn $ \Allocation{..} -> (allocationSchool, allocationName)) . liftHandler . runDB $ mapM getJust nAllocations
|
|
|
|
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
|
|
case allocs of
|
|
[Allocation{..}] ->
|
|
setSubjectI $ MsgMailSubjectAllocationRegister allocationSchool allocationName
|
|
_other ->
|
|
setSubjectI . MsgMailSubjectAllocationRegisterMultiple $ length allocs
|
|
editNotifications <- mkEditNotifications jRecipient
|
|
deadlines <- forM allocs $ \alloc@Allocation{..} -> (alloc,) <$> traverse (formatTime SelFormatDateTime) allocationRegisterTo
|
|
let doRegisterDeadlines = any (is _Just . allocationRegisterTo) allocs
|
|
singleRegisterDeadline = maybe True (flip all (allocs ^.. folded . _allocationRegisterTo) . (==)) $ allocs ^? _head . _allocationRegisterTo
|
|
addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/allocationRegister.hamlet")
|
|
|
|
dispatchNotificationAllocationAllocation :: Set AllocationId -> UserId -> Handler ()
|
|
dispatchNotificationAllocationAllocation (otoList -> nAllocations) jRecipient = do
|
|
courses <- fmap (nubOrdOn $ views _2 entityKey) . runDB . E.select . E.from $ \(course `E.InnerJoin` allocationCourse `E.InnerJoin` allocation `E.InnerJoin` lecturer) -> do
|
|
E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
|
|
E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation
|
|
E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
|
|
|
|
E.where_ $ lecturer E.^. LecturerUser E.==. E.val jRecipient
|
|
E.where_ $ allocation E.^. AllocationId `E.in_` E.valList nAllocations
|
|
|
|
E.orderBy [ E.asc $ allocation E.^. AllocationSchool
|
|
, E.asc $ allocation E.^. AllocationName
|
|
, E.asc $ course E.^. CourseTerm
|
|
, E.asc $ course E.^. CourseSchool
|
|
, E.asc $ course E.^. CourseName
|
|
]
|
|
|
|
return (allocation, course)
|
|
|
|
let allocations = nubOrdOn entityKey $ courses ^.. folded . _1
|
|
|
|
unless (null courses) . userMailT jRecipient $ do
|
|
now <- liftIO getCurrentTime
|
|
let doRegisterDeadlines = any (((<) `on` NTop) (Just now) . allocationRegisterTo . entityVal) allocations
|
|
|
|
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
|
|
case allocations of
|
|
[Entity _ Allocation{..}]
|
|
-> setSubjectI $ MsgMailSubjectAllocationAllocation allocationSchool allocationName
|
|
_other
|
|
-> setSubjectI . MsgMailSubjectAllocationAllocationMultiple $ length allocations
|
|
editNotifications <- mkEditNotifications jRecipient
|
|
|
|
deadlines <- forM allocations $ \(Entity _ alloc@Allocation{..}) -> (alloc,,) <$> traverse (formatTime SelFormatDateTime) (guardOnM doRegisterDeadlines allocationRegisterTo) <*> traverse (formatTime SelFormatDateTime) allocationStaffAllocationTo
|
|
let doDeadlines = doRegisterDeadlines || any (has $ _entityVal . _allocationStaffAllocationTo . _Just) allocations
|
|
sameDeadlines = maybe True (flip all (allocations ^.. folded . _entityVal) . ((==) `on` bool ((, Nothing) . allocationStaffAllocationTo) ((,) <$> allocationStaffAllocationTo <*> allocationRegisterTo) doRegisterDeadlines)) $ allocations ^? _head . _entityVal
|
|
|
|
addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/allocationAllocation.hamlet")
|
|
|
|
dispatchNotificationAllocationUnratedApplications :: Set AllocationId -> UserId -> Handler ()
|
|
dispatchNotificationAllocationUnratedApplications (otoList -> nAllocations) jRecipient = do
|
|
courses <- fmap (nubOrdOn (views _2 entityKey) . over (traverse . _3) (fromIntegral . E.unValue)) . runDB . E.select . E.from $ \(course `E.InnerJoin` allocationCourse `E.InnerJoin` allocation `E.InnerJoin` lecturer) -> do
|
|
E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
|
|
E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation
|
|
E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
|
|
|
|
E.where_ $ lecturer E.^. LecturerUser E.==. E.val jRecipient
|
|
E.where_ $ allocation E.^. AllocationId `E.in_` E.valList nAllocations
|
|
|
|
let
|
|
unratedAppCount :: E.SqlExpr (E.Value Word64)
|
|
unratedAppCount = E.subSelectCount . E.from $ \application ->
|
|
E.where_ $ application E.^. CourseApplicationCourse E.==. course E.^. CourseId
|
|
E.&&. application E.^. CourseApplicationAllocation E.==. E.just (allocation E.^. AllocationId)
|
|
E.&&. E.maybe E.true (E.<. application E.^. CourseApplicationTime) (application E.^. CourseApplicationRatingTime)
|
|
|
|
E.where_ $ unratedAppCount E.>. E.val 0
|
|
|
|
E.orderBy [ E.asc $ allocation E.^. AllocationSchool
|
|
, E.asc $ allocation E.^. AllocationName
|
|
, E.asc $ course E.^. CourseTerm
|
|
, E.asc $ course E.^. CourseSchool
|
|
, E.asc $ course E.^. CourseName
|
|
]
|
|
|
|
return (allocation, course, unratedAppCount)
|
|
|
|
let allocations = nubOrdOn entityKey $ courses ^.. folded . _1
|
|
|
|
unless (null courses) . userMailT jRecipient $ do
|
|
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
|
|
case allocations of
|
|
[Entity _ Allocation{..}]
|
|
-> setSubjectI $ MsgMailSubjectAllocationUnratedApplications allocationSchool allocationName
|
|
_other
|
|
-> setSubjectI . MsgMailSubjectAllocationUnratedApplicationsMultiple $ length allocations
|
|
editNotifications <- mkEditNotifications jRecipient
|
|
|
|
deadlines <- forM allocations $ \(Entity _ alloc@Allocation{..}) -> (alloc,) <$> traverse (formatTime SelFormatDateTime) allocationStaffAllocationTo
|
|
let doDeadlines = any (has $ _entityVal . _allocationStaffAllocationTo . _Just) allocations
|
|
sameDeadlines = maybe True (flip all (allocations ^.. folded . _entityVal) . ((==) `on` allocationStaffAllocationTo)) $ allocations ^? _head . _entityVal
|
|
|
|
addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/allocationUnratedApplications.hamlet")
|
|
|
|
dispatchNotificationAllocationResults :: AllocationId -> UserId -> Handler ()
|
|
dispatchNotificationAllocationResults nAllocation jRecipient = userMailT jRecipient $ do
|
|
(Allocation{..}, lecturerResults, warnSubstituteCourses, participantResults) <- liftHandler . runDB $ do
|
|
allocation <- getJust nAllocation
|
|
|
|
lecturerResults' <- E.select . E.from $ \(lecturer `E.InnerJoin` course `E.InnerJoin` allocationCourse) -> do
|
|
E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
|
|
E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
|
|
E.where_ $ lecturer E.^. LecturerUser E.==. E.val jRecipient
|
|
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val nAllocation
|
|
let allocatedCount :: E.SqlExpr (E.Value Int64)
|
|
allocatedCount = E.subSelectCount . E.from $ \participant ->
|
|
E.where_ $ participant E.^. CourseParticipantCourse E.==. lecturer E.^. LecturerCourse
|
|
E.&&. participant E.^. CourseParticipantAllocated E.==. E.just (E.val nAllocation)
|
|
E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
|
let participantCount :: E.SqlExpr (E.Value Int64)
|
|
participantCount = E.subSelectCount . E.from $ \participant ->
|
|
E.where_ $ participant E.^. CourseParticipantCourse E.==. lecturer E.^. LecturerCourse
|
|
E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
|
return (course, allocationCourse, allocatedCount, participantCount)
|
|
let lecturerResults = flip map lecturerResults' $ \(Entity _ Course{..}, _, E.Value allocCount, E.Value partCount) -> SomeMessage $ if
|
|
| allocCount == partCount -> MsgAllocationResultLecturerAll courseShorthand allocCount
|
|
| allocCount == 0 -> MsgAllocationResultLecturerNone courseShorthand
|
|
| otherwise -> MsgAllocationResultLecturer courseShorthand allocCount partCount
|
|
warnSubstituteCourses = flip mapMaybe lecturerResults' $ \(Entity _ course, Entity _ AllocationCourse{..}, _, _) -> guardOn (isn't _Just allocationCourseAcceptSubstitutes) course
|
|
|
|
doParticipantResults <- E.selectExists . E.from $ \application ->
|
|
E.where_ $ application E.^. CourseApplicationAllocation E.==. E.just (E.val nAllocation)
|
|
E.&&. application E.^. CourseApplicationUser E.==. E.val jRecipient
|
|
participantResults' <- E.select . E.from $ \(participant `E.InnerJoin` course) -> do
|
|
E.on $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
|
|
E.where_ $ participant E.^. CourseParticipantAllocated E.==. E.just (E.val nAllocation)
|
|
E.&&. participant E.^. CourseParticipantUser E.==. E.val jRecipient
|
|
E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
|
return course
|
|
let participantResults = case participantResults' of
|
|
[] | doParticipantResults -> Just []
|
|
| otherwise -> Nothing
|
|
cs -> Just $ map (courseShorthand . entityVal) cs
|
|
|
|
return (allocation, lecturerResults, warnSubstituteCourses, participantResults)
|
|
|
|
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
|
|
setSubjectI $ MsgMailSubjectAllocationResults allocationName
|
|
editNotifications <- mkEditNotifications jRecipient
|
|
|
|
studentFaqItems <- forM studentFaqItems' $ \faqItem -> (faqItem, ) <$> toTextUrl (FaqR :#: faqItem)
|
|
|
|
addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/allocationResults.hamlet")
|
|
where
|
|
studentFaqItems' = [FAQAllocationNoPlaces]
|
|
|
|
dispatchNotificationAllocationNewCourse :: AllocationId -> CourseId -> UserId -> Handler ()
|
|
dispatchNotificationAllocationNewCourse nAllocation nCourse jRecipient = userMailT jRecipient $ do
|
|
(Allocation{..}, Course{..}, hasApplied) <- liftHandler . runDB $ (,,)
|
|
<$> getJust nAllocation
|
|
<*> getJust nCourse
|
|
<*> exists [CourseApplicationAllocation ==. Just nAllocation, CourseApplicationUser ==. jRecipient]
|
|
|
|
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
|
|
setSubjectI $ MsgMailSubjectAllocationNewCourse allocationName
|
|
editNotifications <- mkEditNotifications jRecipient
|
|
|
|
cID <- encrypt nCourse
|
|
mayApply <- lift $ orM
|
|
[ is _Authorized <$> evalAccessFor (Just jRecipient) (AllocationR allocationTerm allocationSchool allocationShorthand ARegisterR) True
|
|
, is _Authorized <$> evalAccessFor (Just jRecipient) (AllocationR allocationTerm allocationSchool allocationShorthand $ AApplyR cID) True
|
|
]
|
|
|
|
allocUrl <- toTextUrl $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: cID
|
|
|
|
addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/allocationNewCourse.hamlet")
|