feat(allocations): ui for adding applicants
This commit is contained in:
Gregor Kleen
parent
7f0177f4e4
commit
7b7f11e728
@ -776,6 +776,9 @@ section
|
||||
.allocation__courses
|
||||
margin: 20px 0 0 40px
|
||||
|
||||
.form-group__input > &
|
||||
margin: 0
|
||||
|
||||
.allocation-course
|
||||
display: grid
|
||||
grid-template-columns: minmax(105px, 1fr) 9fr
|
||||
|
||||
@ -1375,6 +1375,7 @@ MenuAllocationUsers: Bewerber
|
||||
MenuAllocationPriorities: Zentrale Dringlichkeiten
|
||||
MenuAllocationCompute: Platzvergabe berechnen
|
||||
MenuAllocationAccept: Platzvergabe akzeptieren
|
||||
MenuAllocationAddUser: Bewerber hinzufügen
|
||||
MenuFaq: FAQ
|
||||
MenuSheetPersonalisedFiles: Personalisierte Dateien herunterladen
|
||||
MenuCourseSheetPersonalisedFiles: Vorlage für personalisierte Übungsblatt-Dateien herunterladen
|
||||
@ -1449,6 +1450,7 @@ BreadcrumbAllocationUsers: Bewerber
|
||||
BreadcrumbAllocationPriorities: Zentrale Dringlichkeiten
|
||||
BreadcrumbAllocationCompute: Platzvergabe berechnen
|
||||
BreadcrumbAllocationAccept: Platzvergabe akzeptieren
|
||||
BreadcrumbAllocationAddUser: Bewerber hinzufügen
|
||||
BreadcrumbMessageHide: Verstecken
|
||||
BreadcrumbFaq: FAQ
|
||||
BreadcrumbSheetPersonalisedFiles: Personalisierte Dateien herunterladen
|
||||
@ -2707,12 +2709,34 @@ AllocationUsersCsvName tid@TermId ssh@SchoolId ash@AllocationShorthand: #{foldCa
|
||||
AllocationPrioritiesMode: Modus
|
||||
AllocationPrioritiesNumeric: Numerische Dringlichkeiten
|
||||
AllocationPrioritiesOrdinal: Dringlichkeiten durch Sortierung
|
||||
AllocationPriorityNumeric': Numerisch
|
||||
AllocationPriorityOrdinal': Nach Sortierung
|
||||
AllocationPriorityNumericValues: Numerische Werte
|
||||
AllocationPriorityNumericValuesTip: Komma-separierte ganze Zahlen
|
||||
AllocationPriorityNumericNoValues: Es wurden keine numerischen Werte angegeben
|
||||
AllocationPriorityNumericNoParse val@Text: Ganze Zahl konnte nicht geparst werden: „#{val}“
|
||||
AllocationPriorityOrdinalValueNegative: Sortier-Index darf nicht negativ sein
|
||||
AllocationPriorityOrdinalValue: Sortier-Index
|
||||
AllocationPriorityOrdinalValueTip: Null entspricht dem ersten Eintrag der Liste, höhere Indizes entsprechen später in der sortierten Liste vorkommenden Bewerbern und damit einer höheren Dringlichkeit
|
||||
AllocationPrioritiesTitle tid@TermId ssh@SchoolId ash@AllocationShorthand: #{tid}-#{ssh}-#{ash}: Zentrale Dringlichkeiten
|
||||
AllocationPrioritiesFile: CSV-Datei
|
||||
AllocationPrioritiesSunk num@Int64: Zentrale Prioritäten für #{num} Bewerber erfolgreich hinterlegt
|
||||
AllocationPrioritiesMissing num@Int64: Für #{num} Bewerber ist keine zentrale Priorität hinterlegt, da in der hochgeladenen CSV-Datei die #{pluralDE num "entsprechende Matrikelnummer" "entsprechenden Matrikelnummern"} nicht gefunden #{pluralDE num "wurde" "wurden"}
|
||||
AllocationMissingPrioritiesIgnored: Bewerber, für die keine zentrale Priorität angegeben wird, werden bei der Vergabe ignoriert!
|
||||
|
||||
AllocationAddUserUserNotFound: E-Mail Adresse konnte keinem Benutzer zugeordnet werden
|
||||
AllocationAddUserUser: Benutzer
|
||||
AllocationAddUserUserPlaceholder: E-Mail
|
||||
AllocationAddUserTotalCoursesLessThanOne: Anzahl angefragter Plätze muss größer null sein
|
||||
AllocationAddUserTotalCourses: Angefragte Plätze
|
||||
AllocationAddUserSetPriority: Zentrale Dringlichkeit eintragen?
|
||||
AllocationAddUserPriority: Zentrale Dringlichkeit
|
||||
AllocationAddUserApplications: Bewerbungen/Bewertungen
|
||||
AllocationAddUserTitle termText@Text ssh'@SchoolShorthand allocation@AllocationName: #{termText} - #{ssh'} - #{allocation}: Bewerber hinzufügen
|
||||
AllocationAddUserShortTitle tid@TermId ssh@SchoolId ash@AllocationShorthand: #{tid}-#{ssh}-#{ash}: Bewerber hinzufügen
|
||||
AllocationAddUserUserAdded: Bewerber erfolgreich zur Zentralanmeldung hinzugefügt
|
||||
AllocationAddUserUserExists: Der angegebene Benutzer ist bereits ein Bewerber zur Zentralanmeldung
|
||||
|
||||
ExampleUser1FirstName: Max ZweiterName
|
||||
ExampleUser1Surname: Mustermann
|
||||
ExampleUser1DisplayName: Max Mustermann
|
||||
|
||||
@ -1375,6 +1375,7 @@ MenuAllocationUsers: Applicants
|
||||
MenuAllocationPriorities: Central priorities
|
||||
MenuAllocationCompute: Compute allocation
|
||||
MenuAllocationAccept: Accept allocation
|
||||
MenuAllocationAddUser: Add applicant
|
||||
MenuFaq: FAQ
|
||||
MenuSheetPersonalisedFiles: Download personalised sheet files
|
||||
MenuCourseSheetPersonalisedFiles: Download template for personalised sheet files
|
||||
@ -1449,6 +1450,7 @@ BreadcrumbAllocationUsers: Applicants
|
||||
BreadcrumbAllocationPriorities: Central priorities
|
||||
BreadcrumbAllocationCompute: Compute allocation
|
||||
BreadcrumbAllocationAccept: Accept allocation
|
||||
BreadcrumbAllocationAddUser: Add applicant
|
||||
BreadcrumbMessageHide: Hide
|
||||
BreadcrumbFaq: FAQ
|
||||
BreadcrumbSheetPersonalisedFiles: Download personalised sheet files
|
||||
@ -2707,12 +2709,34 @@ AllocationUsersCsvName tid ssh ash: #{foldCase (termToText (unTermKey tid))}-#{f
|
||||
AllocationPrioritiesMode: Mode
|
||||
AllocationPrioritiesNumeric: Numeric priorities
|
||||
AllocationPrioritiesOrdinal: Priorities based on sorted list
|
||||
AllocationPriorityNumeric': Numerical
|
||||
AllocationPriorityOrdinal': Based on sorted list
|
||||
AllocationPriorityNumericValues: Numerical values
|
||||
AllocationPriorityNumericValuesTip: Comma separated whole numbers
|
||||
AllocationPriorityNumericNoValues: No numerical values were provided
|
||||
AllocationPriorityNumericNoParse val: Whole number could not be parsed: “#{val}”
|
||||
AllocationPriorityOrdinalValueNegative: Sorting index may not be negative
|
||||
AllocationPriorityOrdinalValue: Sorting index
|
||||
AllocationPriorityOrdinalValueTip: Zero corresponds to the first entry in the list; higher indices correspond to applicants occurring later in the sorted list and thus to higher central priorities
|
||||
AllocationPrioritiesTitle tid ssh ash: #{tid}-#{ssh}-#{ash}: Central priorities
|
||||
AllocationPrioritiesFile: CSV file
|
||||
AllocationPrioritiesSunk num: Successfully registered central priorities for #{num} #{pluralEN num "applicant" "applicants"}
|
||||
AllocationPrioritiesMissing num: Could not register central priorities for #{num} #{pluralEN num "applicant" "applicants"} because their matriculation was not found in the uploaded CSV file
|
||||
AllocationMissingPrioritiesIgnored: Applicants for whom no central priority has been registered will be ignored during assignment!
|
||||
|
||||
AllocationAddUserUserNotFound: Email could not be resolved to an user
|
||||
AllocationAddUserUser: User
|
||||
AllocationAddUserUserPlaceholder: Email
|
||||
AllocationAddUserTotalCoursesLessThanOne: Number of requested courses needs to be greater than zero
|
||||
AllocationAddUserTotalCourses: Requested courses
|
||||
AllocationAddUserSetPriority: Set central priority?
|
||||
AllocationAddUserPriority: Central priority
|
||||
AllocationAddUserApplications: Applications/Ratings
|
||||
AllocationAddUserTitle termText ssh' allocation: #{termText} - #{ssh'} - #{allocation}: Add applicant
|
||||
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
|
||||
|
||||
ExampleUser1FirstName: Max SecondName
|
||||
ExampleUser1Surname: Mustermann
|
||||
ExampleUser1DisplayName: Max Mustermann
|
||||
|
||||
1
routes
1
routes
@ -113,6 +113,7 @@
|
||||
/register ARegisterR POST !time
|
||||
/course/#CryptoUUIDCourse/apply AApplyR POST !timeANDallocation-registered
|
||||
/users AUsersR 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
|
||||
|
||||
@ -159,6 +159,7 @@ instance BearerAuthSite UniWorX => YesodBreadcrumbs UniWorX where
|
||||
APriosR -> i18nCrumb MsgBreadcrumbAllocationPriorities . Just $ AllocationR tid ssh ash AUsersR
|
||||
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
|
||||
|
||||
breadcrumb ParticipantsListR = i18nCrumb MsgBreadcrumbParticipantsList $ Just CourseListR
|
||||
breadcrumb (ParticipantsR _ _) = i18nCrumb MsgBreadcrumbParticipants $ Just ParticipantsListR
|
||||
@ -1332,6 +1333,17 @@ pageActions (AllocationR tid ssh ash AUsersR) = return
|
||||
}
|
||||
, navChildren = []
|
||||
}
|
||||
, NavPageActionPrimary
|
||||
{ navLink = NavLink
|
||||
{ navLabel = MsgMenuAllocationAddUser
|
||||
, navRoute = AllocationR tid ssh ash AAddUserR
|
||||
, navAccess' = return True
|
||||
, navType = NavTypeLink { navModal = False }
|
||||
, navQuick' = mempty
|
||||
, navForceActive = False
|
||||
}
|
||||
, navChildren = []
|
||||
}
|
||||
]
|
||||
pageActions CourseListR = do
|
||||
participantsSecondary <- pageQuickActions NavQuickViewPageActionSecondary ParticipantsListR
|
||||
|
||||
@ -8,6 +8,7 @@ import Handler.Allocation.Application as Handler.Allocation
|
||||
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.Prios as Handler.Allocation
|
||||
import Handler.Allocation.Compute as Handler.Allocation
|
||||
import Handler.Allocation.Accept as Handler.Allocation
|
||||
|
||||
162
src/Handler/Allocation/AddUser.hs
Normal file
162
src/Handler/Allocation/AddUser.hs
Normal file
@ -0,0 +1,162 @@
|
||||
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 :: Natural
|
||||
, 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
|
||||
)
|
||||
|
||||
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, hasTemplate)) | (Entity cId course, E.Value hasTemplate) <- 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, Bool)
|
||||
-> FieldSettings UniWorX
|
||||
-> Bool
|
||||
-> AForm Handler (Map CourseId ApplicationForm)
|
||||
allocationApplicationsForm aId courses FieldSettings{..} fvRequired = formToAForm $ do
|
||||
let afmApplicant = True
|
||||
afmApplicantEdit = True
|
||||
afmLecturer = True
|
||||
|
||||
appsRes' <- iforM courses $ \cId (course, hasApplicationTemplate) -> over _2 (course, hasApplicationTemplate, ) <$> 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}, hasApplicationTemplate, 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}
|
||||
$if hasApplicationTemplate || is _Just courseApplicationsInstructions
|
||||
<div .allocation-course__instructions-label .allocation__label>
|
||||
_{MsgCourseApplicationInstructionsApplication}
|
||||
<div .allocation-course__instructions>
|
||||
$maybe aInst <- courseApplicationsInstructions
|
||||
<p>
|
||||
#{aInst}
|
||||
$if hasApplicationTemplate
|
||||
<p>
|
||||
<a href=@{CourseR courseTerm courseSchool courseShorthand CRegisterTemplateR}>
|
||||
#{iconRegisterTemplate} _{MsgCourseApplicationTemplateApplication}
|
||||
<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{..})
|
||||
@ -71,16 +71,17 @@ instance Exception ApplicationFormException
|
||||
|
||||
applicationForm :: Maybe AllocationId
|
||||
-> CourseId
|
||||
-> UserId
|
||||
-> Maybe UserId
|
||||
-> ApplicationFormMode -- ^ Which parts of the shared form to display
|
||||
-> Html -> MForm Handler (FormResult ApplicationForm, ApplicationFormView)
|
||||
applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf = do
|
||||
-> Maybe Html -- ^ If @Just@ also include action buttons for usage as standalone form
|
||||
-> MForm Handler (FormResult ApplicationForm, ApplicationFormView)
|
||||
applicationForm maId@(is _Just -> isAlloc) cid muid ApplicationFormMode{..} mcsrf = do
|
||||
|
||||
(mApp, coursesNum, Course{..}, maxPrio) <- liftHandler . runDB $ do
|
||||
mApplication <- listToMaybe <$> selectList [CourseApplicationAllocation ==. maId, CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid] [LimitTo 1]
|
||||
mApplication <- fmap join . for muid $ \uid -> listToMaybe <$> selectList [CourseApplicationAllocation ==. maId, CourseApplicationUser ==. uid, CourseApplicationCourse ==. cid] [LimitTo 1]
|
||||
coursesNum <- fromIntegral . fromMaybe 1 <$> for maId (\aId -> count [AllocationCourseAllocation ==. aId])
|
||||
course <- getJust cid
|
||||
(fromMaybe 0 -> maxPrio) <- fmap (E.unValue <=< listToMaybe) . E.select . E.from $ \courseApplication -> do
|
||||
(fromMaybe 0 -> maxPrio) <- fmap join . for muid $ \uid -> fmap (E.unValue <=< listToMaybe) . E.select . E.from $ \courseApplication -> do
|
||||
E.where_ $ courseApplication E.^. CourseApplicationUser E.==. E.val uid
|
||||
E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.val maId
|
||||
E.&&. E.not_ (E.isNothing $ courseApplication E.^. CourseApplicationAllocationPriority)
|
||||
@ -202,7 +203,9 @@ applicationForm maId@(is _Just -> isAlloc) cid uid ApplicationFormMode{..} csrf
|
||||
, guardOn ( afmApplicantEdit && is _Nothing mApp ) BtnAllocationApply
|
||||
, guardOn ( afmApplicantEdit && is _Just mApp ) BtnAllocationApplicationRetract
|
||||
]
|
||||
(actionRes, buttonsView) <- buttonForm' buttons csrf
|
||||
(actionRes, buttonsView) <- case mcsrf of
|
||||
Just csrf -> buttonForm' buttons csrf
|
||||
Nothing -> return (pure BtnAllocationApplicationEdit, mempty)
|
||||
|
||||
ratingSection <- if
|
||||
| afmLecturer
|
||||
@ -251,7 +254,7 @@ editApplicationR :: Maybe AllocationId
|
||||
editApplicationR maId uid cid mAppId afMode allowAction postAction = do
|
||||
Course{..} <- runDB $ get404 cid
|
||||
|
||||
((appRes, appView), appEnc) <- runFormPost $ applicationForm maId cid uid afMode
|
||||
((appRes, appView), appEnc) <- runFormPost $ applicationForm maId cid (Just uid) afMode . Just
|
||||
|
||||
formResult appRes $ \ApplicationForm{..} -> do
|
||||
if
|
||||
|
||||
@ -150,7 +150,7 @@ postAShowR tid ssh ash = do
|
||||
mayApply <- hasWriteAccessTo . AllocationR tid ssh ash $ AApplyR cID
|
||||
mayEdit <- hasWriteAccessTo $ CourseR tid ssh courseShorthand CEditR
|
||||
isLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR
|
||||
mApplyFormView <- liftHandler . for muid $ \uid -> generateFormPost . applicationForm (Just aId) cid uid $ ApplicationFormMode True mayApply isLecturer
|
||||
mApplyFormView <- liftHandler . for muid $ \uid -> generateFormPost $ applicationForm (Just aId) cid (Just uid) (ApplicationFormMode True mayApply isLecturer) . Just
|
||||
tRoute <- case mApp of
|
||||
Nothing -> return . AllocationR tid ssh ash $ AApplyR cID
|
||||
Just (Entity appId _) -> CApplicationR courseTerm courseSchool courseShorthand <$> encrypt appId <*> pure CAEditR
|
||||
|
||||
@ -44,6 +44,8 @@ import qualified Data.Set as Set
|
||||
import Data.Map ((!), (!?))
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import qualified Data.Vector as Vector
|
||||
|
||||
import qualified Data.HashMap.Lazy as HashMap
|
||||
|
||||
import Control.Monad.Writer.Class
|
||||
@ -488,7 +490,7 @@ termsAllowedField = selectField $ do
|
||||
optionsPersistKey termFilter [Desc TermStart] termName
|
||||
|
||||
termField :: Field Handler TermId
|
||||
termField = selectField $ optionsPersistKey [] [Asc TermName] termName
|
||||
termField = selectField $ optionsPersistKey [] [Desc TermStart] termName
|
||||
|
||||
termsSetField :: [TermId] -> Field Handler TermId
|
||||
termsSetField tids = selectField $ optionsPersistKey [TermName <-. (unTermKey <$> tids)] [Desc TermStart] termName
|
||||
@ -1608,6 +1610,96 @@ multiUserField onlySuggested suggestions = Field{..}
|
||||
)
|
||||
Nothing -> E.true
|
||||
|
||||
userField :: forall m.
|
||||
( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
)
|
||||
=> Bool -- ^ Only resolve suggested users?
|
||||
-> Maybe (E.SqlQuery (E.SqlExpr (Entity User))) -- ^ Suggested users
|
||||
-> Field m (Either UserEmail UserId)
|
||||
userField onlySuggested suggestions = Field{..}
|
||||
where
|
||||
lookupExpr
|
||||
| onlySuggested = suggestions
|
||||
| otherwise = Just $ E.from return
|
||||
|
||||
fieldEnctype = UrlEncoded
|
||||
fieldView theId name attrs val isReq = do
|
||||
val' <- case val of
|
||||
Left t -> return t
|
||||
Right v -> case v of
|
||||
Right uid -> case lookupExpr of
|
||||
Nothing -> return mempty
|
||||
Just lookupExpr' -> do
|
||||
dbRes <- liftHandler . runDB . E.select $ do
|
||||
user <- lookupExpr'
|
||||
E.where_ $ user E.^. UserId E.==. E.val uid
|
||||
return $ user E.^. UserEmail
|
||||
case dbRes of
|
||||
[E.Value email] -> return $ CI.original email
|
||||
_other -> return mempty
|
||||
Left email -> return $ CI.original email
|
||||
|
||||
datalistId <- maybe (return $ error "Not to be used") (const newIdent) suggestions
|
||||
|
||||
[whamlet|
|
||||
$newline never
|
||||
<input id="#{theId}" name="#{name}" *{attrs} type="email" :isReq:required="" value="#{val'}" :isJust suggestions:list=#{datalistId}>
|
||||
|]
|
||||
|
||||
whenIsJust suggestions $ \suggestions' -> do
|
||||
suggestedEmails <- fmap (Map.assocs . Map.fromListWith min . map (over _2 E.unValue . over _1 E.unValue)) . liftHandler . runDB . E.select $ do
|
||||
user <- suggestions'
|
||||
return ( E.case_
|
||||
[ E.when_ (unique UserDisplayEmail user)
|
||||
E.then_ (user E.^. UserDisplayEmail)
|
||||
, E.when_ (unique UserEmail user)
|
||||
E.then_ (user E.^. UserEmail)
|
||||
]
|
||||
( E.else_ $ user E.^. UserIdent)
|
||||
, user E.^. UserDisplayName
|
||||
)
|
||||
[whamlet|
|
||||
$newline never
|
||||
<datalist id=#{datalistId}>
|
||||
$forall (email, dName) <- suggestedEmails
|
||||
<option value=#{email}>
|
||||
#{email} (#{dName})
|
||||
|]
|
||||
fieldParse (filter (not . Text.null) -> t : _) _ = runExceptT . fmap Just $ do
|
||||
email <- either (\errStr -> throwE . SomeMessage $ MsgInvalidEmail [st|#{t} (#{errStr})|]) (return . CI.mk . decodeUtf8 . Email.toByteString) $ Email.validate (encodeUtf8 t)
|
||||
case lookupExpr of
|
||||
Nothing -> return $ Left email
|
||||
Just lookupExpr' -> do
|
||||
dbRes <- fmap (setOf $ folded . _Value). liftHandler . runDB . E.select $ do
|
||||
user <- lookupExpr'
|
||||
E.where_ $ user E.^. UserIdent `E.ciEq` E.val email
|
||||
E.||. ( user E.^. UserDisplayEmail `E.ciEq` E.val email
|
||||
E.&&. unique UserDisplayEmail user
|
||||
)
|
||||
E.||. ( user E.^. UserEmail `E.ciEq` E.val email
|
||||
E.&&. unique UserEmail user
|
||||
)
|
||||
return $ user E.^. UserId
|
||||
if | Set.null dbRes
|
||||
-> return $ Left email
|
||||
| [uid] <- Set.toList dbRes
|
||||
-> return $ Right uid
|
||||
| otherwise
|
||||
-> throwE $ SomeMessage MsgAmbiguousEmail
|
||||
fieldParse _ _ = return $ Right Nothing
|
||||
|
||||
unique field user = case lookupExpr of
|
||||
Just lookupExpr' -> E.not_ . E.exists $ do
|
||||
user' <- lookupExpr'
|
||||
E.where_ $ user' E.^. UserId E.!=. user E.^. UserId
|
||||
E.&&. ( user' E.^. UserIdent `E.ciEq` user E.^. field
|
||||
E.||. user' E.^. UserEmail `E.ciEq` user E.^. field
|
||||
E.||. user' E.^. UserDisplayEmail `E.ciEq` user E.^. field
|
||||
)
|
||||
Nothing -> E.true
|
||||
|
||||
|
||||
examResultField :: forall m res.
|
||||
( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
@ -2032,3 +2124,30 @@ examModeForm mPrev = examMode
|
||||
examRequiredEquipmentToEither (ExamRequiredEquipmentCustom c) = Left c
|
||||
examRequiredEquipmentFromEither (Right p) = ExamRequiredEquipmentPreset p
|
||||
examRequiredEquipmentFromEither (Left c) = ExamRequiredEquipmentCustom c
|
||||
|
||||
|
||||
data AllocationPriority' = AllocationPriorityNumeric' | AllocationPriorityOrdinal'
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
deriving anyclass (Universe, Finite)
|
||||
nullaryPathPiece ''AllocationPriority' $ camelToPathPiece' 2 . dropSuffix "'"
|
||||
embedRenderMessage ''UniWorX ''AllocationPriority' id
|
||||
|
||||
classifyAllocationPriority :: AllocationPriority -> AllocationPriority'
|
||||
classifyAllocationPriority = \case
|
||||
AllocationPriorityNumeric{} -> AllocationPriorityNumeric'
|
||||
AllocationPriorityOrdinal{} -> AllocationPriorityOrdinal'
|
||||
|
||||
allocationPriorityForm :: FieldSettings UniWorX
|
||||
-> Maybe AllocationPriority
|
||||
-> AForm Handler AllocationPriority
|
||||
allocationPriorityForm fs mPrev = multiActionA opts fs $ classifyAllocationPriority <$> mPrev
|
||||
where
|
||||
opts = flip Map.fromSet (Set.fromList universeF) $ \case
|
||||
AllocationPriorityNumeric' -> AllocationPriorityNumeric <$> apreq (checkMap toInts fromInts textField) (fslI MsgAllocationPriorityNumericValues & setTooltip MsgAllocationPriorityNumericValuesTip) (mPrev ^? _Just . _AllocationPriorityNumeric)
|
||||
AllocationPriorityOrdinal' -> AllocationPriorityOrdinal <$> apreq (natFieldI MsgAllocationPriorityOrdinalValueNegative) (fslI MsgAllocationPriorityOrdinalValue & setTooltip MsgAllocationPriorityOrdinalValueTip) (mPrev ^? _Just . _AllocationPriorityOrdinal)
|
||||
|
||||
toInts t = fmap Vector.fromList . runExcept $ do
|
||||
let ts = filter (not . Text.null) . map Text.strip $ Text.splitOn "," t
|
||||
whenExceptT (null ts) MsgAllocationPriorityNumericNoValues
|
||||
forM ts $ \t' -> maybeExceptT (MsgAllocationPriorityNumericNoParse t') . return $ readMay t'
|
||||
fromInts = Text.intercalate ", " . map tshow . Vector.toList
|
||||
|
||||
@ -233,6 +233,8 @@ makeLenses_ ''Rating'
|
||||
|
||||
makeLenses_ ''FallbackPersonalisedSheetFilesKey
|
||||
|
||||
makePrisms ''AllocationPriority
|
||||
|
||||
-- makeClassy_ ''Load
|
||||
|
||||
--------------------------
|
||||
|
||||
Loading…
Reference in New Issue
Block a user