86 lines
3.5 KiB
Haskell
86 lines
3.5 KiB
Haskell
module Handler.Allocation.AddUser
|
|
( getAAddUserR, postAAddUserR
|
|
) where
|
|
|
|
import Import
|
|
import Handler.Allocation.Application
|
|
import Handler.Allocation.UserForm
|
|
|
|
import Handler.Utils
|
|
|
|
import qualified Data.Map.Strict as Map
|
|
|
|
import qualified Data.Conduit.Combinators as C
|
|
|
|
|
|
getAAddUserR, postAAddUserR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html
|
|
getAAddUserR = postAAddUserR
|
|
postAAddUserR tid ssh ash = do
|
|
(Entity _ Allocation{..}, (addUserAct, addUserForm, addUserEnctype)) <- runDB $ do
|
|
alloc@(Entity aId _) <- getBy404 $ TermSchoolAllocationShort tid ssh ash
|
|
|
|
((addUserRes, addUserForm), addUserEnctype) <- runFormPost . renderAForm FormStandard $
|
|
allocationUserForm aId Nothing
|
|
|
|
addUserAct <- formResultMaybe addUserRes $ \AllocationUserForm{..} -> Just <$> do
|
|
now <- liftIO getCurrentTime
|
|
|
|
didInsert <- is _Just <$> insertUnique AllocationUser
|
|
{ allocationUserAllocation = aId
|
|
, allocationUserUser = aauUser
|
|
, allocationUserTotalCourses = aauTotalCourses
|
|
, allocationUserPriority = aauPriority
|
|
}
|
|
|
|
if
|
|
| didInsert -> do
|
|
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 MsgAllocationAddUserUserAdded
|
|
redirect $ AllocationR tid ssh ash AAddUserR
|
|
| otherwise -> return $ addMessageI Error MsgAllocationAddUserUserExists
|
|
|
|
return (alloc, (addUserAct, addUserForm, addUserEnctype))
|
|
|
|
sequence_ addUserAct
|
|
|
|
MsgRenderer mr <- getMsgRenderer
|
|
let title = MsgAllocationAddUserTitle (mr . ShortTermIdentifier $ unTermKey allocationTerm) (unSchoolKey allocationSchool) allocationName
|
|
shortTitle = MsgAllocationAddUserShortTitle allocationTerm allocationSchool allocationShorthand
|
|
|
|
siteLayoutMsg title $ do
|
|
setTitleI shortTitle
|
|
wrapForm addUserForm FormSettings
|
|
{ formMethod = POST
|
|
, formAction = Just . SomeRoute $ AllocationR tid ssh ash AAddUserR
|
|
, formEncoding = addUserEnctype
|
|
, formAttrs = []
|
|
, formSubmit = FormSubmit
|
|
, formAnchor = Nothing :: Maybe Text
|
|
}
|
|
|