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")