feat(allocations): edit allocation-user and their applications
This commit is contained in:
parent
b742731511
commit
4daf33a1a0
@ -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
|
AllocationAddUserShortTitle tid@TermId ssh@SchoolId ash@AllocationShorthand: #{tid}-#{ssh}-#{ash}: Bewerber:in hinzufügen
|
||||||
AllocationAddUserUserAdded: Bewerber:in erfolgreich zur Zentralanmeldung hinzugefügt
|
AllocationAddUserUserAdded: Bewerber:in erfolgreich zur Zentralanmeldung hinzugefügt
|
||||||
AllocationAddUserUserExists: Der/Die angegebene Benutzer/Benutzerin ist bereits ein/eine Bewerber/Bewerberin zur Zentralanmeldung
|
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
|
AllocationPriority: Priorität
|
||||||
CourseAllocationCourseAcceptsSubstitutesUntil: Akzeptiert Nachrücker:innen bis
|
CourseAllocationCourseAcceptsSubstitutesUntil: Akzeptiert Nachrücker:innen bis
|
||||||
CourseAllocationCourseAcceptsSubstitutesNever: Akzeptiert keine Nachrücker:innen
|
CourseAllocationCourseAcceptsSubstitutesNever: Akzeptiert keine Nachrücker:innen
|
||||||
|
|||||||
@ -13,6 +13,9 @@ AllocationAddUserTitle termText ssh' allocation: #{termText} - #{ssh'} - #{alloc
|
|||||||
AllocationAddUserShortTitle tid@TermId ssh@SchoolId ash@AllocationShorthand: #{tid}-#{ssh}-#{ash}: Add applicant
|
AllocationAddUserShortTitle tid@TermId ssh@SchoolId ash@AllocationShorthand: #{tid}-#{ssh}-#{ash}: Add applicant
|
||||||
AllocationAddUserUserAdded: Successfully added applicant to central allocation
|
AllocationAddUserUserAdded: Successfully added applicant to central allocation
|
||||||
AllocationAddUserUserExists: The specified user is already an applicant for the 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
|
AllocationPriority: Priority
|
||||||
CourseAllocationCourseAcceptsSubstitutesUntil: Accepts substitutes until
|
CourseAllocationCourseAcceptsSubstitutesUntil: Accepts substitutes until
|
||||||
CourseAllocationCourseAcceptsSubstitutesNever: Does not accept substitutes
|
CourseAllocationCourseAcceptsSubstitutesNever: Does not accept substitutes
|
||||||
|
|||||||
@ -73,6 +73,7 @@ BreadcrumbAllocationPriorities: Zentrale Dringlichkeiten
|
|||||||
BreadcrumbAllocationCompute: Platzvergabe berechnen
|
BreadcrumbAllocationCompute: Platzvergabe berechnen
|
||||||
BreadcrumbAllocationAccept: Platzvergabe akzeptieren
|
BreadcrumbAllocationAccept: Platzvergabe akzeptieren
|
||||||
BreadcrumbAllocationAddUser: Bewerber:in hinzufügen
|
BreadcrumbAllocationAddUser: Bewerber:in hinzufügen
|
||||||
|
BreadcrumbAllocationEditUser: Bewerber:in bearbeiten
|
||||||
BreadcrumbMessageHide: Verstecken
|
BreadcrumbMessageHide: Verstecken
|
||||||
BreadcrumbFaq !ident-ok: FAQ
|
BreadcrumbFaq !ident-ok: FAQ
|
||||||
BreadcrumbSheetPersonalisedFiles: Personalisierte Dateien herunterladen
|
BreadcrumbSheetPersonalisedFiles: Personalisierte Dateien herunterladen
|
||||||
|
|||||||
@ -73,6 +73,7 @@ BreadcrumbAllocationPriorities: Central priorities
|
|||||||
BreadcrumbAllocationCompute: Compute allocation
|
BreadcrumbAllocationCompute: Compute allocation
|
||||||
BreadcrumbAllocationAccept: Accept allocation
|
BreadcrumbAllocationAccept: Accept allocation
|
||||||
BreadcrumbAllocationAddUser: Add applicant
|
BreadcrumbAllocationAddUser: Add applicant
|
||||||
|
BreadcrumbAllocationEditUser: Edit applicant
|
||||||
BreadcrumbMessageHide: Hide
|
BreadcrumbMessageHide: Hide
|
||||||
BreadcrumbFaq: FAQ
|
BreadcrumbFaq: FAQ
|
||||||
BreadcrumbSheetPersonalisedFiles: Download personalised sheet files
|
BreadcrumbSheetPersonalisedFiles: Download personalised sheet files
|
||||||
|
|||||||
3
routes
3
routes
@ -161,7 +161,8 @@
|
|||||||
/register ARegisterR POST !time
|
/register ARegisterR POST !time
|
||||||
/course/#CryptoUUIDCourse/apply AApplyR POST !timeANDallocation-registered
|
/course/#CryptoUUIDCourse/apply AApplyR POST !timeANDallocation-registered
|
||||||
/users AUsersR GET POST !allocation-admin
|
/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
|
/priorities APriosR GET POST !allocation-admin
|
||||||
/compute AComputeR GET POST !allocation-admin
|
/compute AComputeR GET POST !allocation-admin
|
||||||
/accept AAcceptR GET POST !allocation-admin
|
/accept AAcceptR GET POST !allocation-admin
|
||||||
|
|||||||
@ -213,6 +213,11 @@ breadcrumb (AllocationR tid ssh ash sRoute) = case sRoute of
|
|||||||
AComputeR -> i18nCrumb MsgBreadcrumbAllocationCompute . Just $ AllocationR tid ssh ash AUsersR
|
AComputeR -> i18nCrumb MsgBreadcrumbAllocationCompute . Just $ AllocationR tid ssh ash AUsersR
|
||||||
AAcceptR -> i18nCrumb MsgBreadcrumbAllocationAccept . Just $ AllocationR tid ssh ash AUsersR
|
AAcceptR -> i18nCrumb MsgBreadcrumbAllocationAccept . Just $ AllocationR tid ssh ash AUsersR
|
||||||
AAddUserR -> i18nCrumb MsgBreadcrumbAllocationAddUser . 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 ParticipantsListR = i18nCrumb MsgBreadcrumbParticipantsList $ Just CourseListR
|
||||||
breadcrumb (ParticipantsR _ _) = i18nCrumb MsgBreadcrumbParticipants $ Just ParticipantsListR
|
breadcrumb (ParticipantsR _ _) = i18nCrumb MsgBreadcrumbParticipants $ Just ParticipantsListR
|
||||||
|
|||||||
@ -9,6 +9,7 @@ import Handler.Allocation.Register as Handler.Allocation
|
|||||||
import Handler.Allocation.List as Handler.Allocation
|
import Handler.Allocation.List as Handler.Allocation
|
||||||
import Handler.Allocation.Users as Handler.Allocation
|
import Handler.Allocation.Users as Handler.Allocation
|
||||||
import Handler.Allocation.AddUser 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.Prios as Handler.Allocation
|
||||||
import Handler.Allocation.Compute as Handler.Allocation
|
import Handler.Allocation.Compute as Handler.Allocation
|
||||||
import Handler.Allocation.Accept as Handler.Allocation
|
import Handler.Allocation.Accept as Handler.Allocation
|
||||||
|
|||||||
@ -4,46 +4,25 @@ module Handler.Allocation.AddUser
|
|||||||
|
|
||||||
import Import
|
import Import
|
||||||
import Handler.Allocation.Application
|
import Handler.Allocation.Application
|
||||||
|
import Handler.Allocation.UserForm
|
||||||
|
|
||||||
import Handler.Utils
|
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 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 :: TermId -> SchoolId -> AllocationShorthand -> Handler Html
|
||||||
getAAddUserR = postAAddUserR
|
getAAddUserR = postAAddUserR
|
||||||
postAAddUserR tid ssh ash = do
|
postAAddUserR tid ssh ash = do
|
||||||
(Entity _ Allocation{..}, (addUserAct, addUserForm, addUserEnctype)) <- runDB $ do
|
(Entity _ Allocation{..}, (addUserAct, addUserForm, addUserEnctype)) <- runDB $ do
|
||||||
alloc@(Entity aId _) <- getBy404 $ TermSchoolAllocationShort tid ssh ash
|
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) <- runFormPost . renderAForm FormStandard $
|
||||||
((addUserRes, addUserForm), addUserEnctype) <- liftHandler . runFormPost . renderAForm FormStandard $ AllocationAddUserForm
|
allocationUserForm aId Nothing
|
||||||
<$> 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
|
addUserAct <- formResultMaybe addUserRes $ \AllocationUserForm{..} -> Just <$> do
|
||||||
now <- liftIO getCurrentTime
|
now <- liftIO getCurrentTime
|
||||||
|
|
||||||
didInsert <- is _Just <$> insertUnique AllocationUser
|
didInsert <- is _Just <$> insertUnique AllocationUser
|
||||||
@ -57,6 +36,7 @@ postAAddUserR tid ssh ash = do
|
|||||||
| didInsert -> do
|
| didInsert -> do
|
||||||
oldApps <- selectList [CourseApplicationUser ==. aauUser, CourseApplicationAllocation ==. Just aId] []
|
oldApps <- selectList [CourseApplicationUser ==. aauUser, CourseApplicationAllocation ==. Just aId] []
|
||||||
forM_ oldApps $ \(Entity appId CourseApplication{..}) -> do
|
forM_ oldApps $ \(Entity appId CourseApplication{..}) -> do
|
||||||
|
deleteWhere [ CourseApplicationFileApplication ==. appId ]
|
||||||
delete appId
|
delete appId
|
||||||
unless (courseApplicationCourse `Map.member` aauApplications) $
|
unless (courseApplicationCourse `Map.member` aauApplications) $
|
||||||
audit $ TransactionCourseApplicationDeleted courseApplicationCourse courseApplicationUser appId
|
audit $ TransactionCourseApplicationDeleted courseApplicationCourse courseApplicationUser appId
|
||||||
@ -103,77 +83,3 @@ postAAddUserR tid ssh ash = do
|
|||||||
, formAnchor = Nothing :: Maybe Text
|
, 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
|
|
||||||
<div .allocation__courses>
|
|
||||||
$forall (Course{courseTerm, courseSchool, courseShorthand, courseName, courseApplicationsInstructions}, AllocationCourse{allocationCourseAcceptSubstitutes}, mApplicationTemplate, ApplicationFormView{afvPriority, afvForm}) <- Map.elems appsViews
|
|
||||||
<div .allocation-course>
|
|
||||||
<div .allocation-course__priority-label .allocation__label>
|
|
||||||
_{MsgAllocationPriority}
|
|
||||||
<div .allocation-course__priority>
|
|
||||||
$maybe prioView <- afvPriority
|
|
||||||
^{fvWidget prioView}
|
|
||||||
<a .allocation-course__name href=@{CourseR courseTerm courseSchool courseShorthand CShowR} target="_blank">
|
|
||||||
#{courseName}
|
|
||||||
<div .allocation-course__admin-info>
|
|
||||||
<p>
|
|
||||||
$maybe deadline <- allocationCourseAcceptSubstitutes
|
|
||||||
_{MsgCourseAllocationCourseAcceptsSubstitutesUntil}: #
|
|
||||||
^{formatTimeW SelFormatDateTime deadline}
|
|
||||||
$nothing
|
|
||||||
_{MsgCourseAllocationCourseAcceptsSubstitutesNever}
|
|
||||||
$if allocationCourseAcceptSubstitutes >= Just now
|
|
||||||
\ ^{iconOK}
|
|
||||||
$if is _Just mApplicationTemplate || is _Just courseApplicationsInstructions
|
|
||||||
<div .allocation-course__instructions-label .allocation__label>
|
|
||||||
_{MsgCourseAllocationApplicationInstructionsApplication}
|
|
||||||
<div .allocation-course__instructions>
|
|
||||||
$maybe aInst <- courseApplicationsInstructions
|
|
||||||
<p>
|
|
||||||
#{aInst}
|
|
||||||
$maybe templateUrl <- mApplicationTemplate
|
|
||||||
<p>
|
|
||||||
<a href=#{templateUrl}>
|
|
||||||
#{iconRegisterTemplate} _{MsgCourseAllocationApplicationTemplateApplication}
|
|
||||||
<div .allocation-course__application-label .interactive-fieldset__target .allocation__label uw-interactive-fieldset data-conditional-input=#{maybe "" fvId afvPriority} data-conditional-value="" data-conditional-negated>
|
|
||||||
_{MsgCourseApplication}
|
|
||||||
<div .allocation-course__application .interactive-fieldset__target uw-interactive-fieldset data-conditional-input=#{maybe "" fvId afvPriority} data-conditional-value="" data-conditional-negated>
|
|
||||||
^{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
|
|
||||||
<ul>
|
|
||||||
$forall err <- errs
|
|
||||||
<li>#{err}
|
|
||||||
|]
|
|
||||||
_other -> Nothing
|
|
||||||
fvId <- maybe newIdent return fsId
|
|
||||||
|
|
||||||
return (appsRes, pure FieldView{..})
|
|
||||||
|
|||||||
90
src/Handler/Allocation/EditUser.hs
Normal file
90
src/Handler/Allocation/EditUser.hs
Normal file
@ -0,0 +1,90 @@
|
|||||||
|
module Handler.Allocation.EditUser
|
||||||
|
( getAEditUserR, postAEditUserR
|
||||||
|
) 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
|
||||||
|
|
||||||
|
|
||||||
|
getAEditUserR, postAEditUserR :: TermId -> SchoolId -> AllocationShorthand -> CryptoUUIDUser -> Handler Html
|
||||||
|
getAEditUserR = postAEditUserR
|
||||||
|
postAEditUserR tid ssh ash cID = do
|
||||||
|
(Entity _ Allocation{..}, User{..}, (editUserAct, editUserForm, editUserEnctype)) <- runDB $ do
|
||||||
|
uid <- decrypt cID
|
||||||
|
user <- get404 uid
|
||||||
|
alloc@(Entity aId _) <- getBy404 $ TermSchoolAllocationShort tid ssh ash
|
||||||
|
Entity auId AllocationUser{..} <- getBy404 $ UniqueAllocationUser aId uid
|
||||||
|
|
||||||
|
((editUserRes, editUserForm), editUserEnctype) <- runFormPost . renderAForm FormStandard $
|
||||||
|
allocationUserForm aId $ Just AllocationUserForm
|
||||||
|
{ aauUser = uid
|
||||||
|
, aauTotalCourses = allocationUserTotalCourses
|
||||||
|
, aauPriority = allocationUserPriority
|
||||||
|
, aauApplications = Map.empty -- form collects existing applications itself
|
||||||
|
}
|
||||||
|
|
||||||
|
editUserAct <- formResultMaybe editUserRes $ \AllocationUserForm{..} -> Just <$> do
|
||||||
|
now <- liftIO getCurrentTime
|
||||||
|
|
||||||
|
replace auId AllocationUser
|
||||||
|
{ allocationUserAllocation = aId
|
||||||
|
, allocationUserUser = aauUser
|
||||||
|
, allocationUserTotalCourses = aauTotalCourses
|
||||||
|
, allocationUserPriority = aauPriority
|
||||||
|
}
|
||||||
|
|
||||||
|
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 AUsersR
|
||||||
|
|
||||||
|
return (alloc, user, (editUserAct, editUserForm, editUserEnctype))
|
||||||
|
|
||||||
|
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 editUserForm FormSettings
|
||||||
|
{ formMethod = POST
|
||||||
|
, formAction = Just . SomeRoute . AllocationR tid ssh ash $ AEditUserR cID
|
||||||
|
, formEncoding = editUserEnctype
|
||||||
|
, formAttrs = []
|
||||||
|
, formSubmit = FormSubmit
|
||||||
|
, formAnchor = Nothing :: Maybe Text
|
||||||
|
}
|
||||||
|
|
||||||
149
src/Handler/Allocation/UserForm.hs
Normal file
149
src/Handler/Allocation/UserForm.hs
Normal file
@ -0,0 +1,149 @@
|
|||||||
|
module Handler.Allocation.UserForm
|
||||||
|
( AllocationUserForm(..)
|
||||||
|
, allocationUserForm
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Import
|
||||||
|
import Handler.Allocation.Application
|
||||||
|
|
||||||
|
import Handler.Utils
|
||||||
|
|
||||||
|
import qualified Database.Esqueleto as E
|
||||||
|
import qualified Data.Map.Strict as Map
|
||||||
|
|
||||||
|
import Text.Blaze (toMarkup)
|
||||||
|
|
||||||
|
|
||||||
|
data AllocationUserForm = AllocationUserForm
|
||||||
|
{ aauUser :: UserId
|
||||||
|
, aauTotalCourses :: Word64
|
||||||
|
, aauPriority :: Maybe AllocationPriority
|
||||||
|
, aauApplications :: Map CourseId ApplicationForm
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
allocationUserForm :: forall m backend.
|
||||||
|
( MonadHandler m, HandlerSite m ~ UniWorX
|
||||||
|
, E.SqlBackendCanRead backend, IsSqlBackend backend
|
||||||
|
)
|
||||||
|
=> AllocationId
|
||||||
|
-> Maybe AllocationUserForm
|
||||||
|
-> AForm (ReaderT backend m) AllocationUserForm
|
||||||
|
allocationUserForm aId mTemplate = wFormToAForm $ do
|
||||||
|
allocCourses <- lift . lift . 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
|
||||||
|
|
||||||
|
userRes <- case aauUser <$> mTemplate of
|
||||||
|
Just u -> do
|
||||||
|
User{..} <- lift . lift $ get404 u
|
||||||
|
fvId <- newIdent
|
||||||
|
lift . tell $ pure FieldView
|
||||||
|
{ fvLabel = toMarkup $ mr MsgAllocationAddUserUser
|
||||||
|
, fvTooltip = Nothing
|
||||||
|
, fvId
|
||||||
|
, fvInput = nameWidget userDisplayName userSurname
|
||||||
|
, fvErrors = Nothing
|
||||||
|
, fvRequired = False
|
||||||
|
}
|
||||||
|
return $ FormSuccess u
|
||||||
|
Nothing -> wreq (checkMap (first $ const MsgAllocationAddUserUserNotFound) Right $ userField False Nothing) (fslpI MsgAllocationAddUserUser (mr MsgAllocationAddUserUserPlaceholder)) Nothing
|
||||||
|
|
||||||
|
totalCoursesRes <- wreq (posIntFieldI MsgAllocationAddUserTotalCoursesLessThanOne) (fslI MsgAllocationAddUserTotalCourses) ((aauTotalCourses <$> mTemplate) <|> Just 1)
|
||||||
|
|
||||||
|
priorityRes <- hoist (hoist liftHandler) $ optionalActionW (allocationPriorityForm (fslI MsgAllocationAddUserPriority) $ aauPriority =<< mTemplate) (fslI MsgAllocationAddUserSetPriority) ((is _Just . aauPriority <$> mTemplate) <|> Just True)
|
||||||
|
|
||||||
|
applicationsRes <- aFormToWForm $ allocationApplicationsForm aId (aauUser <$> mTemplate) (Map.fromList [ (cId, (course, allocationCourse, hasTemplate)) | (Entity cId course, E.Value hasTemplate, Entity _ allocationCourse) <- allocCourses ]) (fslI MsgAllocationAddUserApplications) False
|
||||||
|
|
||||||
|
return $ AllocationUserForm
|
||||||
|
<$> userRes
|
||||||
|
<*> totalCoursesRes
|
||||||
|
<*> priorityRes
|
||||||
|
<*> applicationsRes
|
||||||
|
|
||||||
|
|
||||||
|
allocationApplicationsForm :: forall m.
|
||||||
|
( MonadHandler m, HandlerSite m ~ UniWorX
|
||||||
|
)
|
||||||
|
=> AllocationId
|
||||||
|
-> Maybe UserId
|
||||||
|
-> Map CourseId (Course, AllocationCourse, Bool)
|
||||||
|
-> FieldSettings UniWorX
|
||||||
|
-> Bool
|
||||||
|
-> AForm m (Map CourseId ApplicationForm)
|
||||||
|
allocationApplicationsForm aId muid courses FieldSettings{..} fvRequired = formToAForm . hoist liftHandler $ 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 muid ApplicationFormMode{..} Nothing
|
||||||
|
let appsRes = sequenceA $ view _1 <$> appsRes'
|
||||||
|
appsViews = view _2 <$> appsRes'
|
||||||
|
|
||||||
|
let fvInput =
|
||||||
|
[whamlet|
|
||||||
|
$newline never
|
||||||
|
<div .allocation__courses>
|
||||||
|
$forall (Course{courseTerm, courseSchool, courseShorthand, courseName, courseApplicationsInstructions}, AllocationCourse{allocationCourseAcceptSubstitutes}, mApplicationTemplate, ApplicationFormView{afvPriority, afvForm}) <- Map.elems appsViews
|
||||||
|
<div .allocation-course>
|
||||||
|
<div .allocation-course__priority-label .allocation__label>
|
||||||
|
_{MsgAllocationPriority}
|
||||||
|
<div .allocation-course__priority>
|
||||||
|
$maybe prioView <- afvPriority
|
||||||
|
^{fvWidget prioView}
|
||||||
|
<a .allocation-course__name href=@{CourseR courseTerm courseSchool courseShorthand CShowR} target="_blank">
|
||||||
|
#{courseName}
|
||||||
|
<div .allocation-course__admin-info>
|
||||||
|
<p>
|
||||||
|
$maybe deadline <- allocationCourseAcceptSubstitutes
|
||||||
|
_{MsgCourseAllocationCourseAcceptsSubstitutesUntil}: #
|
||||||
|
^{formatTimeW SelFormatDateTime deadline}
|
||||||
|
$nothing
|
||||||
|
_{MsgCourseAllocationCourseAcceptsSubstitutesNever}
|
||||||
|
$if allocationCourseAcceptSubstitutes >= Just now
|
||||||
|
\ ^{iconOK}
|
||||||
|
$if is _Just mApplicationTemplate || is _Just courseApplicationsInstructions
|
||||||
|
<div .allocation-course__instructions-label .allocation__label>
|
||||||
|
_{MsgCourseAllocationApplicationInstructionsApplication}
|
||||||
|
<div .allocation-course__instructions>
|
||||||
|
$maybe aInst <- courseApplicationsInstructions
|
||||||
|
<p>
|
||||||
|
#{aInst}
|
||||||
|
$maybe templateUrl <- mApplicationTemplate
|
||||||
|
<p>
|
||||||
|
<a href=#{templateUrl}>
|
||||||
|
#{iconRegisterTemplate} _{MsgCourseAllocationApplicationTemplateApplication}
|
||||||
|
<div .allocation-course__application-label .interactive-fieldset__target .allocation__label uw-interactive-fieldset data-conditional-input=#{maybe "" fvId afvPriority} data-conditional-value="" data-conditional-negated>
|
||||||
|
_{MsgCourseApplication}
|
||||||
|
<div .allocation-course__application .interactive-fieldset__target uw-interactive-fieldset data-conditional-input=#{maybe "" fvId afvPriority} data-conditional-value="" data-conditional-negated>
|
||||||
|
^{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
|
||||||
|
<ul>
|
||||||
|
$forall err <- errs
|
||||||
|
<li>#{err}
|
||||||
|
|]
|
||||||
|
_other -> Nothing
|
||||||
|
fvId <- maybe newIdent return fsId
|
||||||
|
|
||||||
|
return (appsRes, pure FieldView{..})
|
||||||
@ -194,7 +194,11 @@ postAUsersR tid ssh ash = do
|
|||||||
<$> view _1 <*> pure feats <*> view _2 <*> view (_3 . _Value) <*> view (_4 . _Value) <*> view (_5 . _Value)
|
<$> view _1 <*> pure feats <*> view _2 <*> view (_3 . _Value) <*> view (_4 . _Value) <*> view (_5 . _Value)
|
||||||
dbtColonnade :: Colonnade Sortable _ _
|
dbtColonnade :: Colonnade Sortable _ _
|
||||||
dbtColonnade = mconcat . catMaybes $
|
dbtColonnade = mconcat . catMaybes $
|
||||||
[ pure $ colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname)
|
[ pure . sortable (Just "user-name") (i18nCell MsgUserDisplayName) $ \(view resultUser -> Entity uid User{..})
|
||||||
|
-> let mkUrl = do
|
||||||
|
cID <- encrypt uid
|
||||||
|
return . AllocationR tid ssh ash $ AEditUserR cID
|
||||||
|
in anchorCellM mkUrl (nameWidget userDisplayName userSurname)
|
||||||
, pure $ colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer)
|
, pure $ colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer)
|
||||||
, pure $ colStudyFeatures resultStudyFeatures
|
, pure $ colStudyFeatures resultStudyFeatures
|
||||||
, pure $ colAllocationRequested (resultAllocationUser . _entityVal . _allocationUserTotalCourses . _Integral)
|
, pure $ colAllocationRequested (resultAllocationUser . _entityVal . _allocationUserTotalCourses . _Integral)
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user