516 lines
31 KiB
Haskell
516 lines
31 KiB
Haskell
module Handler.News where
|
|
|
|
import Import hiding (maximum, minimum, minimumBy)
|
|
|
|
import Handler.Utils
|
|
import Handler.Utils.News
|
|
|
|
import Handler.SystemMessage
|
|
|
|
import qualified Data.Map.Strict as Map
|
|
import qualified Data.Set as Set
|
|
|
|
import Database.Esqueleto.Utils.TH
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
import qualified Data.Conduit.List as C (consume, mapMaybeM)
|
|
import qualified Data.Conduit.Combinators as C
|
|
import qualified Data.Conduit.Lift as C
|
|
|
|
import qualified Data.HashMap.Strict as HashMap
|
|
|
|
import Handler.Utils.Exam (showExamOccurrenceRoom)
|
|
|
|
import Data.List (maximum, minimum, minimumBy)
|
|
|
|
|
|
getNewsR :: Handler Html
|
|
getNewsR = do
|
|
muid <- maybeAuthId
|
|
defaultLayout $ do
|
|
setTitleI MsgNewsHeading
|
|
|
|
newsSystemMessages
|
|
|
|
when (is _Nothing muid) $
|
|
notificationWidget NotificationBroad Info $(i18nWidgetFile "pitch")
|
|
|
|
case muid of
|
|
Just uid -> do
|
|
newsActiveAllocations uid
|
|
newsUpcomingExams uid
|
|
newsUpcomingSheets uid
|
|
Nothing ->
|
|
$(i18nWidgetFile "unauth-news")
|
|
|
|
|
|
newsSystemMessages :: Widget
|
|
newsSystemMessages = do
|
|
now <- liftIO getCurrentTime
|
|
|
|
showHidden <- isJust <$> lookupGetParam (toPathPiece GetHidden)
|
|
|
|
let tellShown smId = liftHandler $ do
|
|
cID <- encrypt smId :: Handler CryptoUUIDSystemMessage
|
|
tellRegisteredCookieJson CookieSystemMessageState . MergeHashMap $
|
|
HashMap.singleton cID mempty{ userSystemMessageShown = Just now }
|
|
mkHideForm smId SystemMessage{..} = liftHandler $ do
|
|
cID <- encrypt smId
|
|
hidden <- getSystemMessageState smId <&> \UserSystemMessageState{..} -> userSystemMessageHidden > Just systemMessageLastUnhide
|
|
|
|
(btnView, btnEnctype) <- generateFormPost . buttonForm' $ bool [BtnSystemMessageHide] [BtnSystemMessageUnhide] hidden
|
|
return $ wrapForm btnView def
|
|
{ formSubmit = FormNoSubmit
|
|
, formEncoding = btnEnctype
|
|
, formAction = Just . SomeRoute $ MessageHideR cID
|
|
, formAttrs = [("class", "form--inline")]
|
|
}
|
|
checkHidden (smId, sm@SystemMessage{..}, trans) = do
|
|
hidden <- getSystemMessageState smId <&> \UserSystemMessageState{..} -> userSystemMessageHidden > Just systemMessageLastUnhide
|
|
|
|
tell $ Any hidden
|
|
|
|
return $ guardOn (not hidden || showHidden) (smId, sm, trans, hidden)
|
|
|
|
(messages', Any anyHidden) <- liftHandler . runDB . runConduit . C.runWriterLC $
|
|
transPipe lift (selectKeys [] [])
|
|
.| C.filterM (lift . hasReadAccessTo . MessageR <=< encrypt)
|
|
.| transPipe lift (C.mapMaybeM $ \smId -> fmap (\args@(sm, _) -> (smId, sm, systemMessageToTranslation smId args)) <$> getSystemMessage smId)
|
|
.| C.filter (\(_, SystemMessage{..}, _) -> NTop systemMessageFrom <= NTop (Just now) && NTop (Just now) < NTop systemMessageTo)
|
|
.| C.mapMaybeM checkHidden
|
|
.| C.iterM (\(smId, _, _, _) -> tellShown smId)
|
|
.| C.mapM (\(smId, sm@SystemMessage{..}, trans, hidden) -> (sm, trans, hidden,,) <$> formatTime SelFormatDateTime (maybe id max systemMessageFrom systemMessageLastChanged) <*> mkHideForm smId sm)
|
|
.| C.consume
|
|
let messages = sortOn (\(SystemMessage{..}, _, _, _, _) -> (Down systemMessageManualPriority, Down $ maybe id max systemMessageFrom systemMessageLastChanged, systemMessageSeverity)) messages'
|
|
|
|
hiddenUrl <- toTextUrl (NewsR, [(toPathPiece GetHidden, "")])
|
|
|
|
unless (not anyHidden && null messages)
|
|
$(widgetFile "news/system-messages")
|
|
|
|
|
|
newsUpcomingSheets :: UserId -> Widget
|
|
newsUpcomingSheets uid = do
|
|
cTime <- liftIO getCurrentTime
|
|
let noActiveToCutoff = toMidnight . addGregorianDurationRollOver (scaleCalendarDiffDays (-1) calendarMonth) $ utctDay cTime
|
|
|
|
let tableData :: E.LeftOuterJoin
|
|
(E.InnerJoin (E.InnerJoin (E.SqlExpr (Entity CourseParticipant)) (E.SqlExpr (Entity Course))) (E.SqlExpr (Entity Sheet)))
|
|
(E.InnerJoin (E.SqlExpr (Maybe (Entity Submission))) (E.SqlExpr (Maybe (Entity SubmissionUser))))
|
|
-> E.SqlQuery ( E.SqlExpr (E.Value (Key Term))
|
|
, E.SqlExpr (E.Value SchoolId)
|
|
, E.SqlExpr (E.Value CourseShorthand)
|
|
, E.SqlExpr (E.Value SheetName)
|
|
, E.SqlExpr (E.Value (Maybe UTCTime))
|
|
, E.SqlExpr (E.Value (Maybe SubmissionId)))
|
|
tableData ((participant `E.InnerJoin` course `E.InnerJoin` sheet) `E.LeftOuterJoin` (submission `E.InnerJoin` subuser)) = do
|
|
E.on $ submission E.?. SubmissionId E.==. subuser E.?. SubmissionUserSubmission
|
|
E.&&. E.just (E.val uid) E.==. subuser E.?. SubmissionUserUser
|
|
E.on $ submission E.?. SubmissionSheet E.==. E.just(sheet E.^. SheetId)
|
|
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
|
E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
|
|
|
|
let showSheetNoActiveTo =
|
|
E.maybe E.false (E.>=. E.val noActiveToCutoff) (sheet E.^. SheetActiveFrom)
|
|
E.||. E.maybe E.false (E.>=. E.val noActiveToCutoff) (sheet E.^. SheetVisibleFrom)
|
|
E.||. E.maybe E.false (E.>=. E.val noActiveToCutoff) (sheet E.^. SheetHintFrom)
|
|
E.||. E.maybe E.false (E.>=. E.val noActiveToCutoff) (sheet E.^. SheetSolutionFrom)
|
|
|
|
E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
|
|
E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
|
E.&&. E.maybe showSheetNoActiveTo (E.>=. E.val cTime) (sheet E.^. SheetActiveTo)
|
|
|
|
return
|
|
( course E.^. CourseTerm
|
|
, course E.^. CourseSchool
|
|
, course E.^. CourseShorthand
|
|
, sheet E.^. SheetName
|
|
, sheet E.^. SheetActiveTo
|
|
, submission E.?. SubmissionId
|
|
)
|
|
|
|
colonnade :: Colonnade Sortable (DBRow ( E.Value (Key Term)
|
|
, E.Value SchoolId
|
|
, E.Value CourseShorthand
|
|
, E.Value SheetName
|
|
, E.Value (Maybe UTCTime)
|
|
, E.Value (Maybe SubmissionId)
|
|
))
|
|
(DBCell Handler ())
|
|
colonnade = mconcat
|
|
[ -- dbRow
|
|
-- TOOD: sortable (Just "term") (textCell MsgTableTerm) $ \DBRow{ dbrOutput=(view _1 -> E.Value tid) } ->
|
|
sortable (Just "term") (i18nCell MsgTableTerm) $ \DBRow{ dbrOutput=(E.Value tid,_,_,_,_,_) } ->
|
|
textCell $ toMessage tid
|
|
, sortable (Just "school") (i18nCell MsgTableCourseSchool) $ \DBRow{ dbrOutput=(_,E.Value ssh,_,_,_,_) } ->
|
|
textCell $ toMessage ssh
|
|
, sortable (Just "course") (i18nCell MsgTableCourse) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, _, _, _) } ->
|
|
anchorCell (CourseR tid ssh csh CShowR) csh
|
|
, sortable (Just "sheet") (i18nCell MsgTableSheet) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) } ->
|
|
anchorCell (CSheetR tid ssh csh shn SShowR) shn
|
|
, sortable (Just "deadline") (i18nCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, _, E.Value mDeadline, _) } ->
|
|
maybe mempty (cell . formatTimeW SelFormatDateTime) mDeadline
|
|
, sortable (Just "done") (i18nCell MsgDone) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, E.Value mbsid) } ->
|
|
case mbsid of
|
|
Nothing -> cell $ do
|
|
let submitRoute = CSheetR tid ssh csh shn SubmissionNewR
|
|
whenM (hasWriteAccessTo submitRoute) $
|
|
modal [whamlet|_{MsgSubmissionNew}|] . Left $ SomeRoute submitRoute
|
|
(Just sid) -> anchorCellM (CSubmissionR tid ssh csh shn <$> encrypt sid <*> pure SubShowR)
|
|
(hasTickmark True)
|
|
]
|
|
let validator = def & defaultSorting [SortDescBy "done", SortAscBy "deadline"]
|
|
& forceFilter "may-access" (Any True)
|
|
sheetTable <- liftHandler . runDB $ dbTableWidget' validator DBTable
|
|
{ dbtSQLQuery = tableData
|
|
, dbtRowKey = \((_ `E.InnerJoin` _ `E.InnerJoin` sheet) `E.LeftOuterJoin` _) -> sheet E.^. SheetId
|
|
, dbtColonnade = colonnade
|
|
, dbtProj = dbtProjFilteredPostId
|
|
, dbtSorting = Map.fromList
|
|
[ ( "term"
|
|
, SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseTerm
|
|
)
|
|
, ( "school"
|
|
, SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseSchool
|
|
)
|
|
, ( "course"
|
|
, SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseShorthand
|
|
)
|
|
, ( "sheet"
|
|
, SortColumn $ \(_ `E.InnerJoin` _ `E.InnerJoin` sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName
|
|
)
|
|
, ( "deadline"
|
|
, SortColumn $ \(_ `E.InnerJoin` _ `E.InnerJoin` sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveTo
|
|
)
|
|
, ( "done"
|
|
, SortColumn $ \(_ `E.InnerJoin` _ `E.InnerJoin` _ `E.LeftOuterJoin` (subm `E.InnerJoin` _)) -> E.isNothing $ subm E.?. SubmissionId
|
|
)
|
|
]
|
|
, dbtFilter = mconcat
|
|
[ singletonMap "may-access" . mkFilterProjectedPost $ \(Any b) DBRow{..} ->
|
|
let (E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) = dbrOutput :: ( E.Value (Key Term)
|
|
, E.Value SchoolId
|
|
, E.Value CourseShorthand
|
|
, E.Value SheetName
|
|
, E.Value (Maybe UTCTime)
|
|
, E.Value (Maybe SubmissionId)
|
|
)
|
|
in (==b) <$> hasReadAccessTo (CSheetR tid ssh csh shn SShowR) :: DB Bool
|
|
]
|
|
, dbtFilterUI = mempty
|
|
, dbtStyle = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = SomeMessage MsgNoUpcomingSheetDeadlines }
|
|
, dbtParams = def
|
|
, dbtIdent = "upcoming-sheets" :: Text
|
|
, dbtCsvEncode = noCsvEncode
|
|
, dbtCsvDecode = Nothing
|
|
, dbtExtraReps = []
|
|
}
|
|
$(widgetFile "news/upcomingSheets")
|
|
|
|
|
|
newsUpcomingExams :: UserId -> Widget
|
|
newsUpcomingExams uid = do
|
|
now <- liftIO getCurrentTime
|
|
((Any hasExams, examTable), warningDays) <- liftHandler . runDB $ do
|
|
User {userWarningDays} <- get404 uid
|
|
let fortnight = addUTCTime userWarningDays now
|
|
let -- code copied and slightly adapted from Handler.Course.getCShowR:
|
|
examDBTable = DBTable{..}
|
|
where
|
|
-- for ease of refactoring:
|
|
queryCourse = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
|
|
queryExam = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
|
|
lensCourse = _1
|
|
lensExam = _2
|
|
lensRegister = _3 . _Just
|
|
lensOccurrence = _4 . _Just
|
|
lensShowRoom = _5 . _Value
|
|
|
|
dbtSQLQuery ((course `E.InnerJoin` exam) `E.LeftOuterJoin` register `E.LeftOuterJoin` occurrence) = do
|
|
E.on $ register E.?. ExamRegistrationOccurrence E.==. E.just (occurrence E.?. ExamOccurrenceId)
|
|
E.on $ register E.?. ExamRegistrationExam E.==. E.just (exam E.^. ExamId)
|
|
E.&&. register E.?. ExamRegistrationUser E.==. E.just (E.val uid)
|
|
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
|
E.where_ $ E.exists $ E.from $ \participant ->
|
|
E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
|
|
E.&&. participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
|
|
E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
|
let regToWithinFortnight = exam E.^. ExamRegisterTo E.<=. E.just (E.val fortnight)
|
|
E.&&. exam E.^. ExamRegisterTo E.>=. E.just (E.val now)
|
|
E.&&. E.isNothing (register E.?. ExamRegistrationId)
|
|
startExamFortnight = exam E.^. ExamStart E.<=. E.just (E.val fortnight)
|
|
E.&&. exam E.^. ExamStart E.>=. E.just (E.val now)
|
|
E.&&. E.isJust (register E.?. ExamRegistrationId)
|
|
startOccurFortnight = occurrence E.?. ExamOccurrenceStart E.<=. E.just (E.val fortnight)
|
|
E.&&. occurrence E.?. ExamOccurrenceStart E.>=. E.just (E.val now)
|
|
E.&&. E.isJust (register E.?. ExamRegistrationId)
|
|
earliestOccurrence = E.subSelectMaybe $ E.from $ \occ -> do
|
|
E.where_ $ occ E.^. ExamOccurrenceExam E.==. exam E.^. ExamId
|
|
E.&&. occ E.^. ExamOccurrenceStart E.>=. E.val now
|
|
return $ E.min_ $ occ E.^. ExamOccurrenceStart
|
|
startEarliest = E.isNothing (occurrence E.?. ExamOccurrenceId)
|
|
E.&&. earliestOccurrence E.<=. E.just (E.val fortnight)
|
|
-- E.&&. earliestOccurrence E.>=. E.just (E.val now)
|
|
E.where_ $ regToWithinFortnight E.||. startExamFortnight E.||. startOccurFortnight E.||. startEarliest
|
|
let showRoom = showExamOccurrenceRoom (E.val uid) occurrence
|
|
E.||. E.maybe E.false E.not_ (occurrence E.?. ExamOccurrenceRoomHidden)
|
|
return (course, exam, register, occurrence, showRoom)
|
|
dbtRowKey = queryExam >>> (E.^. ExamId)
|
|
dbtProj = dbtProjFilteredPostId
|
|
dbtColonnade = dbColonnade $ mconcat
|
|
[ sortable (Just "term") (i18nCell MsgTableTerm) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } ->
|
|
msgCell courseTerm
|
|
, sortable (Just "school") (i18nCell MsgTableCourseSchool) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } ->
|
|
msgCell courseSchool
|
|
, sortable (Just "course") (i18nCell MsgTableCourse) $ \DBRow{ dbrOutput = view lensCourse -> Entity _ Course{..} } ->
|
|
anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) (toWgt courseShorthand)
|
|
-- continue here
|
|
, sortable (Just "name") (i18nCell MsgTableExamName) $ \DBRow{ dbrOutput } -> do
|
|
let Entity _ Exam{..} = view lensExam dbrOutput
|
|
Entity _ Course{..} = view lensCourse dbrOutput
|
|
indicatorCell <> anchorCell (CExamR courseTerm courseSchool courseShorthand examName EShowR) examName
|
|
, sortable (Just "register-from") (i18nCell MsgTableExamRegisterFrom) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom
|
|
, sortable (Just "register-to") (i18nCell MsgTableExamRegisterTo) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
|
|
, sortable (Just "time") (i18nCell MsgTableExamTime) $ \DBRow{ dbrOutput } ->
|
|
if | Just (Entity _ ExamOccurrence{..}) <- preview lensOccurrence dbrOutput
|
|
-> cell $ formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd
|
|
| Entity _ Exam{..} <- view lensExam dbrOutput
|
|
, Just start <- examStart -> cell $ formatTimeRangeW SelFormatDateTime start examEnd
|
|
| otherwise -> mempty
|
|
{- NOTE: We do not want thoughtless exam registrations, since many people click "register" and don't show up, causing logistic problems.
|
|
Hence we force them here to click twice. Maybe add a captcha where users have to distinguish pictures showing pink elephants and course lecturers.
|
|
, sortable Nothing mempty $ \DBRow{ dbrOutput } -> sqlCell $ do
|
|
let Entity eId Exam{..} = view lensExam dbrOutput
|
|
Entity _ Course{..} = view lensCourse dbrOutput
|
|
mayRegister <- (== Authorized) <$> evalAccessDB (CExamR courseTerm courseSchool courseShorthand examName ERegisterR) True
|
|
isRegistered <- existsBy $ UniqueExamRegistration eId uid
|
|
if
|
|
| mayRegister -> do
|
|
(examRegisterForm, examRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
|
|
return $ wrapForm examRegisterForm def
|
|
{ formAction = Just . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName ERegisterR
|
|
, formEncoding = examRegisterEnctype
|
|
, formSubmit = FormNoSubmit
|
|
}
|
|
| isRegistered -> return [whamlet|_{MsgNewsExamRegistered}|]
|
|
| otherwise -> return mempty
|
|
-}
|
|
, sortable (Just "registered") (i18nCell MsgTableExamRegistration ) $ \DBRow{ dbrOutput } -> sqlCell $ do
|
|
let Entity _ Exam{..} = view lensExam dbrOutput
|
|
Entity _ Course{..} = view lensCourse dbrOutput
|
|
mayRegister <- (== Authorized) <$> evalAccessDB (CExamR courseTerm courseSchool courseShorthand examName ERegisterR) True
|
|
let isRegistered = has lensRegister dbrOutput
|
|
label = bool MsgNewsExamNotRegistered MsgNewsExamRegistered isRegistered
|
|
examUrl = CExamR courseTerm courseSchool courseShorthand examName EShowR
|
|
if | mayRegister -> return $ simpleLinkI (SomeMessage label) examUrl
|
|
| otherwise -> return [whamlet|_{label}|]
|
|
, sortable (toNothingS "occurrence") (i18nCell MsgTableExamOccurrence) $ \DBRow{ dbrOutput } ->
|
|
if | Just (Entity _ ExamOccurrence{..}) <- preview lensOccurrence dbrOutput
|
|
-> if | view lensShowRoom dbrOutput -> maybe (i18nCell MsgNewsExamOccurrenceRoomIsUnset) roomReferenceCell examOccurrenceRoom
|
|
| otherwise -> i18nCell MsgNewsExamOccurrenceRoomIsHidden & addCellClass ("explanation" :: Text)
|
|
| otherwise -> mempty
|
|
]
|
|
dbtSorting = Map.fromList
|
|
[ ("demo-both", SortColumn $ queryCourse &&& queryExam >>> (\(_course,exam)-> exam E.^. ExamName))
|
|
, ("term", SortColumn $ queryCourse >>> (E.^. CourseTerm ))
|
|
, ("school", SortColumn $ queryCourse >>> (E.^. CourseSchool ))
|
|
, ("course", SortColumn $ queryCourse >>> (E.^. CourseShorthand ))
|
|
, ("name", SortColumn $ queryExam >>> (E.^. ExamName ))
|
|
, ("time", SortColumn $ queryExam >>> (E.^. ExamStart ))
|
|
, ("register-from", SortColumn $ queryExam >>> (E.^. ExamRegisterFrom ))
|
|
, ("register-to", SortColumn $ queryExam >>> (E.^. ExamRegisterTo ))
|
|
, ("visible", SortColumn $ queryExam >>> (E.^. ExamVisibleFrom ))
|
|
, ("registered", SortColumn $ queryExam >>> (\exam ->
|
|
E.exists $ E.from $ \registration -> do
|
|
E.where_ $ registration E.^. ExamRegistrationUser E.==. E.val uid
|
|
E.where_ $ registration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
|
|
))
|
|
]
|
|
dbtFilter = mconcat
|
|
[ singletonMap "may-access" . mkFilterProjectedPost $ \(Any b) DBRow{..} ->
|
|
let Entity _ Exam{..} = view lensExam dbrOutput
|
|
Entity _ Course{..} = view lensCourse dbrOutput
|
|
in (==b) <$> hasReadAccessTo (CExamR courseTerm courseSchool courseShorthand examName EShowR) :: DB Bool
|
|
]
|
|
dbtFilterUI = const mempty
|
|
dbtStyle = def
|
|
dbtParams = def
|
|
dbtIdent :: Text
|
|
dbtIdent = "exams"
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
dbtExtraReps = []
|
|
|
|
examDBTableValidator = def
|
|
& defaultSorting [SortAscBy "time"]
|
|
& forceFilter "may-access" (Any True)
|
|
|
|
(, userWarningDays) <$> dbTable examDBTableValidator examDBTable
|
|
|
|
$(widgetFile "news/upcomingExams")
|
|
|
|
|
|
data AllocationUtilInfo = AllocationUtilInfo
|
|
{ auiApplicants
|
|
, auiPlaces
|
|
, auiPlacementsMade
|
|
, auiApplicantsPlaced :: Word64
|
|
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
newsActiveAllocations :: UserId -> Widget
|
|
newsActiveAllocations uid = maybeT_ $ do
|
|
now <- liftIO getCurrentTime
|
|
activeAllocs <- hoist (liftHandler . runDB) $ do
|
|
guardM . lift $ or2M (hasWriteAccessTo CourseNewR) (hasWriteAccessTo AllocationNewR)
|
|
|
|
userSchools <- lift . fmap (map E.unValue) . E.select . E.from $ \userSchool -> E.distinctOnOrderBy [E.asc $ userSchool E.^. UserSchoolSchool] $ do
|
|
E.where_ $ userSchool E.^. UserSchoolUser E.==. E.val uid
|
|
return $ userSchool E.^. UserSchoolSchool
|
|
functionSchools <- lift . fmap (map E.unValue) . E.select . E.from $ \userFunction -> E.distinctOnOrderBy [E.asc $ userFunction E.^. UserFunctionSchool] $ do
|
|
E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val uid
|
|
E.&&. userFunction E.^. UserFunctionFunction E.==. E.val SchoolAllocation
|
|
return $ userFunction E.^. UserFunctionSchool
|
|
|
|
let allocSchools = Set.fromList $ userSchools <> functionSchools
|
|
|
|
guard . not $ null allocSchools
|
|
|
|
activeAllocs <- lift . E.select . E.from $ \allocation -> do
|
|
E.where_ $ allocation E.^. AllocationSchool `E.in_` E.valList (Set.toList allocSchools)
|
|
E.where_ $ E.maybe E.false (E.<=. E.val now) (allocation E.^. AllocationStaffRegisterFrom) E.&&. E.maybe E.true (E.>=. E.val now) (allocation E.^. AllocationStaffRegisterTo)
|
|
E.||. E.maybe E.false (E.<=. E.val now) (allocation E.^. AllocationStaffAllocationFrom) E.&&. E.maybe E.true (E.>=. E.val now) (allocation E.^. AllocationStaffAllocationTo)
|
|
E.||. E.maybe E.false (E.<=. E.val now) (allocation E.^. AllocationRegisterFrom) E.&&. E.maybe E.true (E.>=. E.val now) (allocation E.^. AllocationRegisterTo)
|
|
E.||. E.maybe E.true (E.>=. E.val now) (allocation E.^. AllocationRegisterByStaffFrom) E.||. E.maybe E.false (E.<=. E.val now) (allocation E.^. AllocationRegisterByStaffTo)
|
|
E.||. E.maybe E.false (E.>=. E.val now) (allocation E.^. AllocationRegisterByCourse)
|
|
|
|
return allocation
|
|
|
|
guard . not $ null activeAllocs
|
|
|
|
fmap Map.fromList . forM activeAllocs $ \activeAlloc'@(Entity _ activeAlloc) -> lift $ ((allocationTerm activeAlloc, allocationSchool activeAlloc, allocationShorthand activeAlloc), ) <$> do
|
|
prevAllocs <- E.select . E.from $ \allocation -> E.distinctOnOrderBy [ E.desc $ allocation E.^. AllocationTerm ] $ do
|
|
E.where_ $ allocation E.^. AllocationShorthand `E.in_` E.valList (allocationShorthand activeAlloc : allocationLegacyShorthands activeAlloc)
|
|
E.&&. allocation E.^. AllocationTerm E.<. E.val (allocationTerm activeAlloc)
|
|
E.&&. allocation E.^. AllocationSchool E.==. E.val (allocationSchool activeAlloc)
|
|
E.orderBy [E.asc $ allocation E.^. AllocationSchool]
|
|
E.limit 2
|
|
return allocation
|
|
|
|
let allocInfo :: Entity Allocation -> DB (Entity Allocation, AllocationUtilInfo)
|
|
allocInfo ent@(Entity aId' _) = (ent, ) <$> do
|
|
auiApplicants <- E.selectCountRows . E.from $ \allocationUser -> do
|
|
E.where_ $ allocationUser E.^. AllocationUserAllocation E.==. E.val aId'
|
|
E.where_ $ allocationUser E.^. AllocationUserTotalCourses E.>=. E.val 1 -- wants at least one course
|
|
E.where_ . E.exists . E.from $ \(courseApplication `E.InnerJoin` allocationCourse) -> do -- at least one application
|
|
E.on $ courseApplication E.^. CourseApplicationCourse E.==. allocationCourse E.^. AllocationCourseCourse
|
|
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId'
|
|
E.where_ $ courseApplication E.^. CourseApplicationUser E.==. allocationUser E.^. AllocationUserUser
|
|
E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.justVal aId'
|
|
auiPlaces <- fmap (fromMaybe 0 . (E.unValue =<<)) . E.selectMaybe . E.from $ \(allocationCourse `E.InnerJoin` course) -> do
|
|
E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
|
|
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId'
|
|
return . E.explicitUnsafeCoerceSqlExprValue @(Maybe Word64) @(Maybe Rational) "integer" . E.sum_ . E.maybe (E.val 0) id . E.maybe (course E.^. CourseCapacity) E.just $ allocationCourse E.^. AllocationCourseOverrideSumCapacity
|
|
placementsCounts <- E.select . E.from $ \(courseParticipant `E.InnerJoin` allocationCourse) -> do
|
|
E.on $ courseParticipant E.^. CourseParticipantCourse E.==. allocationCourse E.^. AllocationCourseCourse
|
|
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId'
|
|
E.where_ . E.isJust $ courseParticipant E.^. CourseParticipantAllocated -- count any allocations; course can only be in one allocation at a time
|
|
return ( E.countRows
|
|
, E.countDistinct $ courseParticipant E.^. CourseParticipantUser
|
|
)
|
|
let (auiPlacementsMade, auiApplicantsPlaced) = case placementsCounts of
|
|
[(E.Value placementsMade, E.Value applicantsPlaced)] -> (placementsMade, applicantsPlaced)
|
|
_other -> error "Query `SELECT COUNT(*), COUNT(DISTINCT …) …` did not return exactly one row"
|
|
return AllocationUtilInfo{..}
|
|
|
|
(:|) <$> allocInfo activeAlloc'
|
|
<*> traverse allocInfo prevAllocs
|
|
|
|
let allocsToList allocs = toList allocs
|
|
& sortOn (Down . allocationTerm . views _1 entityVal)
|
|
allocationInfo = $(i18nWidgetFile "news/activeAllocations-info")
|
|
allocTime Allocation{..} | null timeOpts' = Nothing
|
|
| otherwise = Just . view _2 $ minimumBy (comparing $ view _1) timeOpts'
|
|
where
|
|
timeOpts' = flip mapMaybe timeOpts $ \(ts, w)
|
|
-> let ts' = flip mapMaybe ts $ \mt -> assertM' (>= 0) . (`diffUTCTime` now) =<< mt
|
|
in if | null ts' -> Nothing
|
|
| otherwise -> Just (minimum ts', w)
|
|
timeOpts = catMaybes
|
|
[ allocationRegisterByStaffFrom <&> \registerByStaffFrom ->
|
|
( [allocationRegisterByStaffFrom, allocationRegisterByStaffTo]
|
|
, [whamlet|
|
|
$newline never
|
|
_{MsgAllocationRegisterByStaff}: #
|
|
^{formatTimeRangeW (selFormat $ catMaybes [allocationRegisterByStaffFrom, allocationRegisterByStaffTo]) registerByStaffFrom allocationRegisterByStaffTo}
|
|
|]
|
|
)
|
|
, allocationRegisterByStaffTo <&> \registerByStaffTo ->
|
|
( [allocationRegisterByStaffTo]
|
|
, [whamlet|
|
|
$newline never
|
|
_{MsgAllocationRegisterByStaffTo}: #
|
|
^{formatTimeW (selFormat $ catMaybes [allocationRegisterByStaffTo]) registerByStaffTo}
|
|
|]
|
|
)
|
|
, allocationStaffRegisterFrom <&> \staffRegisterFrom ->
|
|
( [allocationStaffRegisterFrom, allocationStaffRegisterTo]
|
|
, [whamlet|
|
|
$newline never
|
|
_{MsgAllocationStaffRegister}: #
|
|
^{formatTimeRangeW (selFormat $ catMaybes [allocationStaffRegisterFrom, allocationStaffRegisterTo]) staffRegisterFrom allocationStaffRegisterTo}
|
|
|]
|
|
)
|
|
, allocationStaffRegisterTo <&> \staffRegisterTo ->
|
|
( [allocationStaffRegisterTo]
|
|
, [whamlet|
|
|
$newline never
|
|
_{MsgAllocationStaffRegisterTo}: #
|
|
^{formatTimeW (selFormat $ catMaybes [allocationStaffRegisterTo]) staffRegisterTo}
|
|
|]
|
|
)
|
|
, allocationRegisterFrom <&> \registerFrom ->
|
|
( [allocationRegisterFrom, allocationRegisterTo]
|
|
, [whamlet|
|
|
$newline never
|
|
_{MsgAllocationRegister}: #
|
|
^{formatTimeRangeW (selFormat $ catMaybes [allocationRegisterFrom, allocationRegisterTo]) registerFrom allocationRegisterTo}
|
|
|]
|
|
)
|
|
, allocationRegisterTo <&> \registerTo ->
|
|
( [allocationRegisterTo]
|
|
, [whamlet|
|
|
$newline never
|
|
_{MsgAllocationRegisterTo}: #
|
|
^{formatTimeW (selFormat $ catMaybes [allocationRegisterTo]) registerTo}
|
|
|]
|
|
)
|
|
, allocationStaffAllocationFrom <&> \staffAllocationFrom ->
|
|
( [allocationStaffAllocationFrom, allocationStaffAllocationTo]
|
|
, [whamlet|
|
|
$newline never
|
|
_{MsgAllocationStaffAllocation}: #
|
|
^{formatTimeRangeW (selFormat $ catMaybes [allocationStaffAllocationFrom, allocationStaffAllocationTo]) staffAllocationFrom allocationStaffAllocationTo}
|
|
|]
|
|
)
|
|
, allocationStaffAllocationTo <&> \staffAllocationTo ->
|
|
( [allocationStaffAllocationTo]
|
|
, [whamlet|
|
|
$newline never
|
|
_{MsgAllocationStaffAllocationTo}: #
|
|
^{formatTimeW (selFormat $ catMaybes [allocationStaffAllocationTo]) staffAllocationTo}
|
|
|]
|
|
)
|
|
]
|
|
selFormat ts | not $ null ts = maximum $ map selFormat' ts
|
|
| otherwise = SelFormatDate
|
|
where selFormat' (utcToLocalTime -> t@LocalTime{..})
|
|
| closeToEndOfDay = SelFormatDate
|
|
| otherwise = SelFormatDateTime
|
|
where closeToEndOfDay = any (\t' -> abs (t `diffLocalTime` t') <= 5 * nominalMinute)
|
|
[ LocalTime localDay midnight
|
|
, LocalTime (addDays 1 localDay) midnight
|
|
]
|
|
|
|
lift $(widgetFile "news/activeAllocations")
|