-- SPDX-FileCopyrightText: 2022 Gregor Kleen -- -- SPDX-License-Identifier: AGPL-3.0-or-later module Handler.Allocation.EditUser ( getAEditUserR, postAEditUserR , getADelUserR, postADelUserR ) where import Import import Handler.Allocation.Application import Handler.Allocation.UserForm import Handler.Utils import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified Data.Conduit.Combinators as C import Handler.Utils.Delete import qualified Database.Esqueleto.Legacy as E import qualified Database.Esqueleto.Utils as E import Handler.Course.Register (deregisterParticipant) import Jobs.Queue data AllocationCourseParticipantFormDefaultReason = AllocationCourseParticipantFormDefaultReason deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) deriving anyclass (Universe, Finite) embedRenderMessage ''UniWorX ''AllocationCourseParticipantFormDefaultReason id getAEditUserR, postAEditUserR :: TermId -> SchoolId -> AllocationShorthand -> CryptoUUIDUser -> Handler Html getAEditUserR = postAEditUserR postAEditUserR tid ssh ash cID = do (Entity _ Allocation{..}, User{..}, editUserAct, editUserForm, regFormForm, formEnctype) <- runDBJobs $ do uid <- decrypt cID user <- get404 uid alloc@(Entity aId _) <- getBy404 $ TermSchoolAllocationShort tid ssh ash Entity auId oldAllocationUser@AllocationUser{..} <- getBy404 $ UniqueAllocationUser aId uid regState <- do courses <- E.select . E.from $ \((course `E.InnerJoin` allocationCourse) `E.LeftOuterJoin` courseParticipant `E.LeftOuterJoin` allocationDeregister) -> do E.on $ allocationDeregister E.?. AllocationDeregisterUser E.==. E.justVal uid E.&&. E.joinV (allocationDeregister E.?. AllocationDeregisterCourse) E.==. E.just (allocationCourse E.^. AllocationCourseCourse) E.on $ courseParticipant E.?. CourseParticipantUser E.==. E.justVal uid E.&&. courseParticipant E.?. CourseParticipantCourse E.==. E.just (allocationCourse E.^. AllocationCourseCourse) E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId return ( course E.^. CourseId , ( ( course E.^. CourseTerm , course E.^. CourseSchool , course E.^. CourseShorthand ) , course E.^. CourseName , ( ( E.joinV (courseParticipant E.?. CourseParticipantAllocated) E.==. E.justVal aId E.||. E.isNothing (courseParticipant E.?. CourseParticipantId) , courseParticipant E.?. CourseParticipantState ) , ( E.isJust $ allocationDeregister E.?. AllocationDeregisterId , E.joinV $ allocationDeregister E.?. AllocationDeregisterReason ) ) ) ) MsgRenderer mr <- getMsgRenderer return $ let toRegState (E.Value cId, (ident, E.Value cname, regState')) = (cId, ((tid', ssh', csh), cname, courseRegState)) where (E.Value tid', E.Value ssh', E.Value csh) = ident ((E.Value isAlloc, E.Value mParState), (E.Value isDeregister, E.Value regReason)) = regState' courseRegState | not isAlloc = CourseParticipantFormNotAllocated | isDeregister = CourseParticipantFormDeregistered { cpfDeregisterReason = Just $ fromMaybe defReason regReason , cpfEverRegistered = True } | mParState == Just CourseParticipantActive = CourseParticipantFormRegistered | otherwise = CourseParticipantFormDeregistered { cpfDeregisterReason = Nothing , cpfEverRegistered = is _Just mParState } defReason = [st|<#{mr AllocationCourseParticipantFormDefaultReason}>|] in Map.fromList $ map toRegState courses ((formRes, (regFormForm, editUserForm)), formEnctype) <- runFormPost $ \csrf -> let allocForm = renderAForm FormStandard $ allocationUserForm aId $ Just AllocationUserForm { aauUser = uid , aauTotalCourses = allocationUserTotalCourses , aauPriority = allocationUserPriority , aauApplications = Map.empty -- form collects existing applications itself } in (\(regRes, regForm) (editUserRes, editUserForm) -> ((,) <$> regRes <*> editUserRes, (regForm, editUserForm))) <$> courseParticipantForm regState csrf <*> allocForm mempty editUserAct <- formResultMaybe formRes $ \(regState', AllocationUserForm{..}) -> Just <$> do now <- liftIO getCurrentTime iforM_ (Map.intersectionWith (,) regState' regState) $ \cId (cpf, (_, _, oldCPF)) -> when (cpf /= oldCPF) $ case cpf of CourseParticipantFormNotAllocated -> return () CourseParticipantFormDeregistered mReason _ -> do hoist liftHandler $ deregisterParticipant uid =<< getJustEntity cId app <- getYesod let mReason' = mReason <&> \str -> maybe (Just str) (const Nothing) (listToMaybe $ unRenderMessageLenient @AllocationCourseParticipantFormDefaultReason app str) deleteWhere [AllocationDeregisterUser ==. uid, AllocationDeregisterCourse ==. Just cId] for_ mReason' $ \allocationDeregisterReason -> insert AllocationDeregister { allocationDeregisterCourse = Just cId , allocationDeregisterTime = now , allocationDeregisterUser = uid , allocationDeregisterReason } CourseParticipantFormRegistered -> do void $ upsert CourseParticipant { courseParticipantCourse = cId , courseParticipantUser = uid , courseParticipantAllocated = Just aId , courseParticipantState = CourseParticipantActive , courseParticipantRegistration = now } [ CourseParticipantRegistration =. now , CourseParticipantAllocated =. Just aId , CourseParticipantState =. CourseParticipantActive ] audit $ TransactionCourseParticipantEdit cId uid queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cId let newAllocationUser = AllocationUser { allocationUserAllocation = aId , allocationUserUser = aauUser , allocationUserTotalCourses = aauTotalCourses , allocationUserPriority = aauPriority } when (newAllocationUser /= oldAllocationUser) $ do replace auId newAllocationUser audit $ TransactionAllocationUserEdited aauUser aId -- Applications are complicated and it isn't easy to detect if something changed -- Therefore we just always replace... oldApps <- selectList [CourseApplicationUser ==. aauUser, CourseApplicationAllocation ==. Just aId] [] forM_ oldApps $ \(Entity appId CourseApplication{..}) -> do deleteWhere [ CourseApplicationFileApplication ==. appId ] delete appId unless (courseApplicationCourse `Map.member` aauApplications) $ audit $ TransactionCourseApplicationDeleted courseApplicationCourse courseApplicationUser appId iforM_ aauApplications $ \cId ApplicationForm{..} -> maybeT_ $ do prio <- hoistMaybe afPriority let rated = afRatingVeto || is _Just afRatingPoints appId <- lift $ insert CourseApplication { courseApplicationCourse = cId , courseApplicationUser = aauUser , courseApplicationText = afText , courseApplicationRatingVeto = afRatingVeto , courseApplicationRatingPoints = afRatingPoints , courseApplicationRatingComment = afRatingComment , courseApplicationAllocation = Just aId , courseApplicationAllocationPriority = Just prio , courseApplicationTime = now , courseApplicationRatingTime = guardOn rated now } lift . runConduit $ transPipe liftHandler (sequence_ afFiles) .| C.mapM_ (insert_ . review _FileReference . (, CourseApplicationFileResidual appId)) lift . audit $ TransactionCourseApplicationEdit cId aauUser appId return $ do addMessageI Success MsgAllocationEditUserUserEdited redirect . AllocationR tid ssh ash $ AEditUserR cID return (alloc, user, editUserAct, editUserForm, regFormForm, formEnctype) sequence_ editUserAct MsgRenderer mr <- getMsgRenderer let title = MsgAllocationEditUserTitle (mr . ShortTermIdentifier $ unTermKey allocationTerm) (unSchoolKey allocationSchool) allocationShorthand userDisplayName shortTitle = MsgAllocationEditUserShortTitle allocationTerm allocationSchool allocationShorthand userDisplayName siteLayoutMsg title $ do setTitleI shortTitle wrapForm $(widgetFile "allocation/edit-user") FormSettings { formMethod = POST , formAction = Just . SomeRoute . AllocationR tid ssh ash $ AEditUserR cID , formEncoding = formEnctype , formAttrs = [] , formSubmit = FormSubmit , formAnchor = Nothing :: Maybe Text } getADelUserR, postADelUserR :: TermId -> SchoolId -> AllocationShorthand -> CryptoUUIDUser -> Handler Html getADelUserR = postADelUserR postADelUserR tid ssh ash cID = do uid <- decrypt cID (aId, auId) <- runDB . maybeT notFound $ do aId <- MaybeT . getKeyBy $ TermSchoolAllocationShort tid ssh ash auId <- MaybeT . getKeyBy $ UniqueAllocationUser aId uid return (aId, auId) deleteR DeleteRoute { drRecords = Set.singleton auId , drGetInfo = \(allocationUser `E.InnerJoin` user) -> do E.on $ allocationUser E.^. AllocationUserUser E.==. user E.^. UserId let appsCount = E.subSelectCount . E.from $ \courseApplication -> E.where_ $ courseApplication E.^. CourseApplicationUser E.==. allocationUser E.^. AllocationUserUser E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocationUser E.^. AllocationUserAllocation) allocsCount = E.subSelectCount . E.from $ \courseParticipant -> E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. allocationUser E.^. AllocationUserUser E.&&. courseParticipant E.^. CourseParticipantAllocated E.==. E.just (allocationUser E.^. AllocationUserAllocation) return ( ( user E.^. UserDisplayName, user E.^. UserSurname ) , appsCount :: E.SqlExpr (E.Value Word64) , allocsCount :: E.SqlExpr (E.Value Word64) ) , drUnjoin = \(allocationUser `E.InnerJoin` _user) -> allocationUser , drRenderRecord = \((E.Value dName, E.Value sName), E.Value (assertM' (> 0) -> appsCount), E.Value (assertM' (> 0) -> allocsCount)) -> return [whamlet| $newline never ^{nameWidget dName sName} $if is _Just appsCount || is _Just allocsCount \ ( $maybe c <- appsCount _{MsgAllocationApplicationsCount c} $if is _Just appsCount || is _Just allocsCount , # $maybe c <- appsCount _{MsgAllocationAllocationsCount c} ) |] , drRecordConfirmString = \((E.Value dName, _), _, _) -> return [st|#{dName}|] , drFormMessage = \_ -> return Nothing , drCaption = SomeMessage MsgAllocationUserDeleteQuestion , drSuccessMessage = SomeMessage MsgAllocationUserDeleted , drAbort = SomeRoute . AllocationR tid ssh ash $ AEditUserR cID , drSuccess = SomeRoute $ AllocationR tid ssh ash AUsersR , drDelete = \_k doDelete -> do res <- doDelete audit $ TransactionAllocationUserDeleted uid aId return res }