module Handler.Allocation.AddUser ( getAAddUserR, postAAddUserR ) where import Import import Handler.Allocation.Application import Handler.Utils import qualified Data.Map as Map import qualified Data.Conduit.Combinators as C import qualified Database.Esqueleto as E data AllocationAddUserForm = AllocationAddUserForm { aauUser :: UserId , aauTotalCourses :: Word64 , aauPriority :: Maybe AllocationPriority , aauApplications :: Map CourseId ApplicationForm } 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 allocCourses <- E.select . E.from $ \(course `E.InnerJoin` allocationCourse) -> do E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId E.where_ $ allocationCourse E.^. AllocationCourseAllocation E.==. E.val aId return ( course , E.exists . E.from $ \courseAppInstructionFile -> E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. course E.^. CourseId , allocationCourse ) MsgRenderer mr <- getMsgRenderer ((addUserRes, addUserForm), addUserEnctype) <- liftHandler . runFormPost . renderAForm FormStandard $ AllocationAddUserForm <$> areq (checkMap (first $ const MsgAllocationAddUserUserNotFound) Right $ userField False Nothing) (fslpI MsgAllocationAddUserUser (mr MsgAllocationAddUserUserPlaceholder)) Nothing <*> areq (posIntFieldI MsgAllocationAddUserTotalCoursesLessThanOne) (fslI MsgAllocationAddUserTotalCourses) (Just 1) <*> optionalActionA (allocationPriorityForm (fslI MsgAllocationAddUserPriority) Nothing) (fslI MsgAllocationAddUserSetPriority) (Just True) <*> allocationApplicationsForm aId (Map.fromList [ (cId, (course, allocationCourse, hasTemplate)) | (Entity cId course, E.Value hasTemplate, Entity _ allocationCourse) <- allocCourses ]) (fslI MsgAllocationAddUserApplications) False addUserAct <- formResultMaybe addUserRes $ \AllocationAddUserForm{..} -> 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 delete appId unless (courseApplicationCourse `Map.member` aauApplications) $ audit $ TransactionCourseApplicationDeleted courseApplicationCourse courseApplicationUser appId iforM_ aauApplications $ \cId ApplicationForm{..} -> maybeT (return ()) $ 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 } allocationApplicationsForm :: AllocationId -> Map CourseId (Course, AllocationCourse, Bool) -> FieldSettings UniWorX -> Bool -> AForm Handler (Map CourseId ApplicationForm) allocationApplicationsForm aId courses FieldSettings{..} fvRequired = formToAForm $ do now <- liftIO getCurrentTime let afmApplicant = True afmApplicantEdit = True afmLecturer = True appsRes' <- iforM courses $ \cId (course, allocCourse, hasApplicationTemplate) -> do mApplicationTemplate <- runMaybeT $ do guard hasApplicationTemplate let Course{..} = course toTextUrl $ CourseR courseTerm courseSchool courseShorthand CRegisterTemplateR over _2 (course, allocCourse, mApplicationTemplate, ) <$> applicationForm (Just aId) cId Nothing ApplicationFormMode{..} Nothing let appsRes = sequenceA $ view _1 <$> appsRes' appsViews = view _2 <$> appsRes' let fvInput = [whamlet| $newline never
$forall (Course{courseTerm, courseSchool, courseShorthand, courseName, courseApplicationsInstructions}, AllocationCourse{allocationCourseAcceptSubstitutes}, mApplicationTemplate, ApplicationFormView{afvPriority, afvForm}) <- Map.elems appsViews
_{MsgAllocationPriority}
$maybe prioView <- afvPriority ^{fvWidget prioView} #{courseName}

$maybe deadline <- allocationCourseAcceptSubstitutes _{MsgCourseAllocationCourseAcceptsSubstitutesUntil}: # ^{formatTimeW SelFormatDateTime deadline} $nothing _{MsgCourseAllocationCourseAcceptsSubstitutesNever} $if allocationCourseAcceptSubstitutes >= Just now \ ^{iconOK} $if is _Just mApplicationTemplate || is _Just courseApplicationsInstructions