245 lines
12 KiB
Haskell
245 lines
12 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
|
|
--
|
|
-- 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
|
|
}
|