205 lines
10 KiB
Haskell
205 lines
10 KiB
Haskell
module Handler.Allocation.Show
|
|
( getAShowR, postAShowR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Utils.Course
|
|
|
|
import Handler.Utils
|
|
import Handler.Utils.Allocation (allocationNotifyNewCourses)
|
|
|
|
import Handler.Allocation.Register
|
|
import Handler.Allocation.Application
|
|
|
|
import qualified Database.Esqueleto as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
|
|
data NotifyNewCourseButton
|
|
= BtnNotifyNewCourseForceOn
|
|
| BtnNotifyNewCourseForceOff
|
|
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
|
deriving anyclass (Universe, Finite)
|
|
embedRenderMessage ''UniWorX ''NotifyNewCourseButton id
|
|
nullaryPathPiece ''NotifyNewCourseButton $ camelToPathPiece' 2
|
|
|
|
instance Button UniWorX NotifyNewCourseButton where
|
|
btnLabel BtnNotifyNewCourseForceOn
|
|
= [whamlet|
|
|
$newline never
|
|
#{iconNotification} \
|
|
_{BtnNotifyNewCourseForceOn}
|
|
|]
|
|
btnLabel BtnNotifyNewCourseForceOff
|
|
= [whamlet|
|
|
$newline never
|
|
#{iconNoNotification} \
|
|
_{BtnNotifyNewCourseForceOff}
|
|
|]
|
|
|
|
btnClasses _ = [BCIsButton]
|
|
|
|
|
|
getAShowR, postAShowR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html
|
|
getAShowR = postAShowR
|
|
postAShowR tid ssh ash = do
|
|
muid <- maybeAuthId
|
|
now <- liftIO getCurrentTime
|
|
ata <- getSessionActiveAuthTags
|
|
|
|
let
|
|
resultCourse :: _ => Lens' a (Entity Course)
|
|
resultCourse = _1
|
|
resultCourseApplication :: _ => Traversal' a (Entity CourseApplication)
|
|
resultCourseApplication = _2 . _Just
|
|
resultHasTemplate :: _ => Lens' a Bool
|
|
resultHasTemplate = _3 . _Value
|
|
resultIsRegistered :: _ => Lens' a Bool
|
|
resultIsRegistered = _4 . _Value
|
|
resultCourseVisible :: _ => Lens' a Bool
|
|
resultCourseVisible = _5 . _Value
|
|
resultAllocationCourse :: _ => Lens' a AllocationCourse
|
|
resultAllocationCourse = _6 . _entityVal
|
|
resultParticipantCount :: _ => Lens' a Int
|
|
resultParticipantCount = _7 . _Value
|
|
|
|
(Entity aId Allocation{..}, School{..}, isAnyLecturer, isAdmin, courses, registration, wouldNotifyNewCourse) <- runDB $ do
|
|
alloc@(Entity aId Allocation{allocationSchool}) <- getBy404 $ TermSchoolAllocationShort tid ssh ash
|
|
school <- getJust allocationSchool
|
|
|
|
courses <- E.select . E.from $ \((allocationCourse `E.InnerJoin` course) `E.LeftOuterJoin` courseApplication `E.LeftOuterJoin` registration) -> do
|
|
E.on $ registration E.?. CourseParticipantCourse E.==. E.just (course E.^. CourseId)
|
|
E.&&. registration E.?. CourseParticipantUser E.==. E.val muid
|
|
E.&&. registration E.?. CourseParticipantState E.==. E.just (E.val CourseParticipantActive)
|
|
E.on $ courseApplication E.?. CourseApplicationCourse E.==. E.just (course E.^. CourseId)
|
|
E.&&. courseApplication E.?. CourseApplicationUser E.==. E.val muid
|
|
E.&&. courseApplication E.?. CourseApplicationAllocation E.==. E.just (E.just $ E.val aId)
|
|
E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
|
|
E.where_ $ allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId
|
|
E.&&. ( E.isJust (courseApplication E.?. CourseApplicationId)
|
|
E.||. mayViewCourse muid ata now course (Just $ E.val aId)
|
|
)
|
|
E.orderBy [E.asc $ course E.^. CourseName]
|
|
let hasTemplate = E.exists . E.from $ \courseAppInstructionFile ->
|
|
E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. course E.^. CourseId
|
|
participantCount = E.subSelectCount . E.from $ \courseParticipant ->
|
|
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
|
|
E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
|
return ( course
|
|
, courseApplication
|
|
, hasTemplate
|
|
, E.not_ . E.isNothing $ registration E.?. CourseParticipantId
|
|
, courseIsVisible now course . Just $ E.val aId
|
|
, allocationCourse
|
|
, participantCount
|
|
)
|
|
|
|
registration <- fmap join . for muid $ getBy . UniqueAllocationUser aId
|
|
|
|
isAnyLecturer <- hasWriteAccessTo CourseNewR
|
|
isAdmin <- hasReadAccessTo $ AllocationR tid ssh ash AUsersR
|
|
|
|
wouldNotifyNewCourse <- fmap (maybe False E.unValue . join) . for muid $ E.selectMaybe . pure . allocationNotifyNewCourses (E.val aId) . E.val
|
|
|
|
return (alloc, school, isAnyLecturer, isAdmin, nubOn (view $ resultCourse . _entityKey) courses, registration, wouldNotifyNewCourse)
|
|
|
|
let nextSubstitutesDeadline = minimumOf (folded . resultAllocationCourse . _allocationCourseAcceptSubstitutes . _Just . filtered (>= now)) courses
|
|
freeCapacity = fmap getSum . getAp . flip foldMap courses $ \cEntry -> Ap . fmap (Sum . max 0) $ subtract (cEntry ^. resultParticipantCount) <$> preview (resultCourse . _entityVal . _courseCapacity . _Just) cEntry
|
|
|
|
MsgRenderer mr <- getMsgRenderer
|
|
let title = MsgAllocationTitle (mr . ShortTermIdentifier $ unTermKey allocationTerm) (unSchoolKey allocationSchool) allocationName
|
|
shortTitle = MsgAllocationShortTitle (mr . ShortTermIdentifier $ unTermKey allocationTerm) (unSchoolKey allocationSchool) allocationShorthand
|
|
|
|
-- staffInformation <- anyM courses $ \(view $ resultCourse . _entityVal -> Course{..}) ->
|
|
-- hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CApplicationsR
|
|
mayRegister <- hasWriteAccessTo $ AllocationR tid ssh ash ARegisterR
|
|
(registerForm, registerEnctype) <- generateFormPost . identifyForm FIDAllocationRegister . renderAForm FormStandard . allocationRegisterForm $ allocationUserToForm . entityVal <$> registration
|
|
let
|
|
registerBtn = bool BtnAllocationRegister BtnAllocationRegistrationEdit $ is _Just registration
|
|
registerForm' = wrapForm' registerBtn registerForm FormSettings
|
|
{ formMethod = POST
|
|
, formAction = Just . SomeRoute $ AllocationR tid ssh ash ARegisterR
|
|
, formEncoding = registerEnctype
|
|
, formAttrs = []
|
|
, formSubmit = FormSubmit
|
|
, formAnchor = Nothing :: Maybe Text
|
|
}
|
|
|
|
((notificationResult, notificationForm), notificationEnctype) <- runFormPost . identifyForm FIDAllocationNotification . buttonForm' $ if
|
|
| wouldNotifyNewCourse
|
|
-> [BtnNotifyNewCourseForceOff]
|
|
| otherwise
|
|
-> [BtnNotifyNewCourseForceOn]
|
|
let
|
|
allocationNotificationIdent = "allocation-notification" :: Text
|
|
notificationForm' = wrapForm notificationForm FormSettings
|
|
{ formMethod = POST
|
|
, formAction = Just . SomeRoute $ AllocationR tid ssh ash AShowR
|
|
, formEncoding = notificationEnctype
|
|
, formAttrs = []
|
|
, formSubmit = FormNoSubmit
|
|
, formAnchor = Just allocationNotificationIdent
|
|
}
|
|
|
|
whenIsJust muid $ \uid -> formResult notificationResult $ \notificationBtn -> do
|
|
let allocationNotificationSettingIsOptOut = case notificationBtn of
|
|
BtnNotifyNewCourseForceOn -> False
|
|
BtnNotifyNewCourseForceOff -> True
|
|
runDB . void $ upsertBy (UniqueAllocationNotificationSetting uid aId) AllocationNotificationSetting
|
|
{ allocationNotificationSettingUser = uid
|
|
, allocationNotificationSettingAllocation = aId
|
|
, allocationNotificationSettingIsOptOut
|
|
}
|
|
[ AllocationNotificationSettingIsOptOut =. allocationNotificationSettingIsOptOut ]
|
|
addMessageI Success $ bool MsgAllocationNotificationNewCourseSuccessForceOn MsgAllocationNotificationNewCourseSuccessForceOff allocationNotificationSettingIsOptOut
|
|
redirect $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: allocationNotificationIdent
|
|
|
|
siteLayoutMsg title $ do
|
|
setTitleI shortTitle
|
|
|
|
let courseWidgets = flip map courses $ \cEntry -> do
|
|
let Entity cid Course{..} = cEntry ^. resultCourse
|
|
hasApplicationTemplate = cEntry ^. resultHasTemplate
|
|
mApp = cEntry ^? resultCourseApplication
|
|
isRegistered = cEntry ^. resultIsRegistered
|
|
courseVisible = cEntry ^. resultCourseVisible
|
|
AllocationCourse{..} = cEntry ^. resultAllocationCourse
|
|
partCount = cEntry ^. resultParticipantCount
|
|
cID <- encrypt cid :: WidgetFor UniWorX CryptoUUIDCourse
|
|
mayApply <- hasWriteAccessTo . AllocationR tid ssh ash $ AApplyR cID
|
|
mayEdit <- hasWriteAccessTo $ CourseR tid ssh courseShorthand CEditR
|
|
isLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR
|
|
mApplyFormView <- liftHandler . for muid $ \uid -> generateFormPost $ applicationForm (Just aId) cid (Just uid) (ApplicationFormMode True mayApply isLecturer) . Just
|
|
tRoute <- case mApp of
|
|
Nothing -> return . AllocationR tid ssh ash $ AApplyR cID
|
|
Just (Entity appId _) -> CApplicationR courseTerm courseSchool courseShorthand <$> encrypt appId <*> pure CAEditR
|
|
mApplicationTemplate <- runMaybeT $ do
|
|
guard hasApplicationTemplate
|
|
toTextUrl $ CourseR courseTerm courseSchool courseShorthand CRegisterTemplateR
|
|
|
|
let mApplyFormView' = view _1 <$> mApplyFormView
|
|
overrideVisible = not mayApply && is _Just mApp
|
|
case mApplyFormView of
|
|
Just (_, appFormEnctype)
|
|
-> wrapForm $(widgetFile "allocation/show/course") FormSettings
|
|
{ formMethod = POST
|
|
, formAction = Just $ SomeRoute tRoute
|
|
, formEncoding = appFormEnctype
|
|
, formAttrs = [ ("class", "allocation-course")
|
|
]
|
|
, formSubmit = FormNoSubmit
|
|
, formAnchor = Just cID
|
|
}
|
|
Nothing
|
|
-> let wdgt = $(widgetFile "allocation/show/course")
|
|
in [whamlet|
|
|
<div .allocation-course ##{toPathPiece cID}>
|
|
^{wdgt}
|
|
|]
|
|
let daysToRegistrationStart = assertM (>0) $ (`diffUTCTime` now) <$> allocationRegisterFrom
|
|
allocationInfoModal = modal [whamlet|_{MsgMenuAllocationInfo}|] $ Left $ SomeRoute InfoAllocationR
|
|
numCourses = length courses
|
|
numAppliedCourses = lengthOf (folded . _2 . _Just) courses
|
|
$(widgetFile "allocation/show")
|