diff --git a/messages/uniworx/categories/courses/allocation/de-de-formal.msg b/messages/uniworx/categories/courses/allocation/de-de-formal.msg index 195269d41..af8e9efe4 100644 --- a/messages/uniworx/categories/courses/allocation/de-de-formal.msg +++ b/messages/uniworx/categories/courses/allocation/de-de-formal.msg @@ -13,6 +13,9 @@ AllocationAddUserTitle termText@Text ssh'@SchoolShorthand allocation@AllocationN AllocationAddUserShortTitle tid@TermId ssh@SchoolId ash@AllocationShorthand: #{tid}-#{ssh}-#{ash}: Bewerber:in hinzufügen AllocationAddUserUserAdded: Bewerber:in erfolgreich zur Zentralanmeldung hinzugefügt AllocationAddUserUserExists: Der/Die angegebene Benutzer/Benutzerin ist bereits ein/eine Bewerber/Bewerberin zur Zentralanmeldung +AllocationEditUserUserEdited: Bewerber:in erfolgreich bearbeitet +AllocationEditUserTitle termText@Text ssh@SchoolShorthand ash@AllocationShorthand userDisplayName@Text: #{termText} - #{ssh} - #{ash}, Bewerber:in bearbeiten: #{userDisplayName} +AllocationEditUserShortTitle tid@TermId ssh@SchoolId ash@AllocationShorthand userDisplayName@Text !ident-ok: #{tid}-#{ssh}-#{ash}: #{userDisplayName} AllocationPriority: Priorität CourseAllocationCourseAcceptsSubstitutesUntil: Akzeptiert Nachrücker:innen bis CourseAllocationCourseAcceptsSubstitutesNever: Akzeptiert keine Nachrücker:innen diff --git a/messages/uniworx/categories/courses/allocation/en-eu.msg b/messages/uniworx/categories/courses/allocation/en-eu.msg index 6150f9cb4..62312f26b 100644 --- a/messages/uniworx/categories/courses/allocation/en-eu.msg +++ b/messages/uniworx/categories/courses/allocation/en-eu.msg @@ -13,6 +13,9 @@ AllocationAddUserTitle termText ssh' allocation: #{termText} - #{ssh'} - #{alloc AllocationAddUserShortTitle tid@TermId ssh@SchoolId ash@AllocationShorthand: #{tid}-#{ssh}-#{ash}: Add applicant AllocationAddUserUserAdded: Successfully added applicant to central allocation AllocationAddUserUserExists: The specified user is already an applicant for the central allocation +AllocationEditUserUserEdited: Successfully edited applicant +AllocationEditUserTitle termText ssh ash userDisplayName: #{termText} - #{ssh} - #{ash}, Edit applicant: #{userDisplayName} +AllocationEditUserShortTitle tid ssh ash userDisplayName !ident-ok: #{tid}-#{ssh}-#{ash}: #{userDisplayName} AllocationPriority: Priority CourseAllocationCourseAcceptsSubstitutesUntil: Accepts substitutes until CourseAllocationCourseAcceptsSubstitutesNever: Does not accept substitutes diff --git a/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg b/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg index a266c9861..7e44bf414 100644 --- a/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg @@ -73,6 +73,7 @@ BreadcrumbAllocationPriorities: Zentrale Dringlichkeiten BreadcrumbAllocationCompute: Platzvergabe berechnen BreadcrumbAllocationAccept: Platzvergabe akzeptieren BreadcrumbAllocationAddUser: Bewerber:in hinzufügen +BreadcrumbAllocationEditUser: Bewerber:in bearbeiten BreadcrumbMessageHide: Verstecken BreadcrumbFaq !ident-ok: FAQ BreadcrumbSheetPersonalisedFiles: Personalisierte Dateien herunterladen diff --git a/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg b/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg index 4128ffd30..bf60ba6aa 100644 --- a/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg +++ b/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg @@ -73,6 +73,7 @@ BreadcrumbAllocationPriorities: Central priorities BreadcrumbAllocationCompute: Compute allocation BreadcrumbAllocationAccept: Accept allocation BreadcrumbAllocationAddUser: Add applicant +BreadcrumbAllocationEditUser: Edit applicant BreadcrumbMessageHide: Hide BreadcrumbFaq: FAQ BreadcrumbSheetPersonalisedFiles: Download personalised sheet files diff --git a/routes b/routes index 4a62bdbbc..b697d57f3 100644 --- a/routes +++ b/routes @@ -161,7 +161,8 @@ /register ARegisterR POST !time /course/#CryptoUUIDCourse/apply AApplyR POST !timeANDallocation-registered /users AUsersR GET POST !allocation-admin - /users/add AAddUserR GET POST !allocation-admin + /users/#CryptoUUIDUser AEditUserR GET POST !allocation-admin + !/users/add AAddUserR GET POST !allocation-admin /priorities APriosR GET POST !allocation-admin /compute AComputeR GET POST !allocation-admin /accept AAcceptR GET POST !allocation-admin diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index eadcaf463..054732ad2 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -213,6 +213,11 @@ breadcrumb (AllocationR tid ssh ash sRoute) = case sRoute of AComputeR -> i18nCrumb MsgBreadcrumbAllocationCompute . Just $ AllocationR tid ssh ash AUsersR AAcceptR -> i18nCrumb MsgBreadcrumbAllocationAccept . Just $ AllocationR tid ssh ash AUsersR AAddUserR -> i18nCrumb MsgBreadcrumbAllocationAddUser . Just $ AllocationR tid ssh ash AUsersR + AEditUserR cID -> useRunDB . maybeT (i18nCrumb MsgBreadcrumbAllocationEditUser . Just $ AllocationR tid ssh ash AUsersR) $ do + guardM . lift . hasReadAccessTo . AllocationR tid ssh ash $ AEditUserR cID + uid <- decrypt cID + User{..} <- MaybeT $ get uid + return (userDisplayName, Just $ AllocationR tid ssh ash AUsersR) breadcrumb ParticipantsListR = i18nCrumb MsgBreadcrumbParticipantsList $ Just CourseListR breadcrumb (ParticipantsR _ _) = i18nCrumb MsgBreadcrumbParticipants $ Just ParticipantsListR diff --git a/src/Handler/Allocation.hs b/src/Handler/Allocation.hs index a3eace4f6..031e5c055 100644 --- a/src/Handler/Allocation.hs +++ b/src/Handler/Allocation.hs @@ -9,6 +9,7 @@ import Handler.Allocation.Register as Handler.Allocation import Handler.Allocation.List as Handler.Allocation import Handler.Allocation.Users as Handler.Allocation import Handler.Allocation.AddUser as Handler.Allocation +import Handler.Allocation.EditUser as Handler.Allocation import Handler.Allocation.Prios as Handler.Allocation import Handler.Allocation.Compute as Handler.Allocation import Handler.Allocation.Accept as Handler.Allocation diff --git a/src/Handler/Allocation/AddUser.hs b/src/Handler/Allocation/AddUser.hs index 24230e64b..01a140380 100644 --- a/src/Handler/Allocation/AddUser.hs +++ b/src/Handler/Allocation/AddUser.hs @@ -4,46 +4,25 @@ module Handler.Allocation.AddUser import Import import Handler.Allocation.Application +import Handler.Allocation.UserForm import Handler.Utils -import qualified Data.Map as Map +import qualified Data.Map.Strict 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 + ((addUserRes, addUserForm), addUserEnctype) <- runFormPost . renderAForm FormStandard $ + allocationUserForm aId Nothing - addUserAct <- formResultMaybe addUserRes $ \AllocationAddUserForm{..} -> Just <$> do + addUserAct <- formResultMaybe addUserRes $ \AllocationUserForm{..} -> Just <$> do now <- liftIO getCurrentTime didInsert <- is _Just <$> insertUnique AllocationUser @@ -57,6 +36,7 @@ postAAddUserR tid ssh ash = do | 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 @@ -103,77 +83,3 @@ postAAddUserR tid ssh ash = do , 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 -

- _{MsgCourseAllocationApplicationInstructionsApplication} -
- $maybe aInst <- courseApplicationsInstructions -

- #{aInst} - $maybe templateUrl <- mApplicationTemplate -

- - #{iconRegisterTemplate} _{MsgCourseAllocationApplicationTemplateApplication} -

- _{MsgCourseApplication} -
- ^{renderFieldViews FormStandard afvForm} - |] - MsgRenderer mr <- getMsgRenderer - let fvLabel = toHtml $ mr fsLabel - fvTooltip = toHtml . mr <$> fsTooltip - fvErrors = case appsRes of - FormFailure errs -> Just - [shamlet| - $newline never -