fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(multi-user-field): improve placeholder

Browse Source 
Remove MassInputTip
This commit is contained in:
Gregor Kleen 2020-05-06 19:01:32 +02:00
parent 75ce911d61
commit 2936eefbd1
16 changed files with 61 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
messages/uniworx/de-de-formal.msg
View File

@ -2149,7 +2149,7 @@ ExamOfficeFieldForced: Forcierte Einsicht
InvalidExamOfficeFieldMode parseErr@Text: Konnte „#{parseErr}“ nicht interpretieren
LdapIdentification: Campus-Kennung
LdapIdentificationOrEmail: Campus-Kennung/E-Mail Addresse
LdapIdentificationOrEmail: Campus-Kennung / E-Mail Addresse
AdminUserTitle: Titel
AdminUserFirstName: Vorname
AdminUserSurname: Nachname

2
src/Database/Esqueleto/Utils.hs
View File

@ -200,6 +200,8 @@ lower = E.unsafeSqlFunction "LOWER"
strip :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s)
strip = E.unsafeSqlFunction "TRIM"
infix 4 `ciEq`
ciEq :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool)
ciEq a b = lower a E.==. lower b

3
src/Handler/Admin/Tokens.hs
View File

@ -29,9 +29,10 @@ data BearerTokenForm = BearerTokenForm
bearerTokenForm :: WForm Handler (FormResult BearerTokenForm)
bearerTokenForm = do
muid <- maybeAuthId
mr <- getMessageRender
btfAuthorityGroups <- aFormToWForm $ HashSet.fromList . map Left <$> massInputListA pathPieceField (const "") (\p -> Just . SomeRoute $ AdminTokensR :#: p) ("token-groups" :: Text) (fslI MsgBearerTokenAuthorityGroups & setTooltip MsgBearerTokenAuthorityGroupsTip) False Nothing
btfAuthorityUsers <- fmap (fmap . ofoldMap $ HashSet.singleton . Right) <$> wopt (checkMap (foldMapM $ fmap Set.singleton . left MsgBearerTokenAuthorityUnknownUser) (Set.map Right) $ multiUserField False Nothing) (fslI MsgBearerTokenAuthorityUsers & setTooltip MsgBearerTokenAuthorityUsersTip) (Just $ Set.singleton <$> muid)
btfAuthorityUsers <- fmap (fmap . ofoldMap $ HashSet.singleton . Right) <$> wopt (checkMap (foldMapM $ fmap Set.singleton . left MsgBearerTokenAuthorityUnknownUser) (Set.map Right) $ multiUserField False Nothing) (fslpI MsgBearerTokenAuthorityUsers (mr MsgLdapIdentificationOrEmail) & setTooltip MsgBearerTokenAuthorityUsersTip) (Just $ Set.singleton <$> muid)
let btfAuthority' :: FormResult (HashSet (Either UserGroupName UserId))
btfAuthority'
= (<>) <$> btfAuthorityGroups <*> ((hoistMaybe =<< btfAuthorityUsers) <|> pure HashSet.empty)

2
src/Handler/Course/Edit.hs
View File

@ -179,7 +179,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
lecturerForm :: AForm Handler [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
lecturerForm = formToAForm . over (mapped._2) pure . over (mapped._1.mapped) (map liftEither . Map.elems) $ massInput
MassInput{..}
(fslI MsgCourseLecturers & setTooltip (UniWorXMessages [SomeMessage MsgCourseLecturerRightsIdentical, SomeMessage MsgMassInputTip]))
(fslI MsgCourseLecturers & setTooltip MsgCourseLecturerRightsIdentical)
True
(Just . Map.fromList . zip [0..] $ maybe [(Right uid, Just CourseLecturer)] (map unliftEither . cfLecturers) template)
mempty

3
src/Handler/Course/ParticipantInvite.hs
View File

@ -130,8 +130,9 @@ postCAddUserR tid ssh csh = do
let submissionGroupOpts = optionsPersist [SubmissionGroupCourse ==. cid] [Asc SubmissionGroupName] submissionGroupName <&> fmap (submissionGroupName . entityVal)
mbGrp <- wopt (textField & cfStrip & cfCI & addDatalist submissionGroupOpts) (fslI MsgSubmissionGroup & setTooltip MsgSubmissionGroupEmptyIsUnsetTip) Nothing
mr <- getMessageRender
users <- wreq (multiUserField (maybe True not $ formResultToMaybe enlist) Nothing)
(fslI MsgCourseParticipantInviteField & setTooltip MsgMultiEmailFieldTip) Nothing
(fslpI MsgCourseParticipantInviteField (mr MsgLdapIdentificationOrEmail) & setTooltip MsgMultiEmailFieldTip) Nothing
return $ Map.fromSet . const <$> mbGrp <*> users

3
src/Handler/Exam/AddUser.hs
View File

@ -70,8 +70,9 @@ postEAddUserR tid ssh csh examn = do
enlist <- wpopt checkBoxField (fslI MsgExamRegistrationEnlistDirectly & setTooltip MsgExamRegistrationEnlistDirectlyTip) (Just False)
registerCourse <- wpopt checkBoxField (fslI MsgExamRegistrationRegisterCourse & setTooltip MsgExamRegistrationRegisterCourseTip) (Just False)
occurrence <- wopt (examOccurrenceField eid) (fslI MsgExamOccurrence) Nothing
mr <- getMessageRender
users <- wreq (multiUserField (maybe True not $ formResultToMaybe enlist) Nothing)
(fslI MsgExamRegistrationInviteField & setTooltip MsgMultiEmailFieldTip) Nothing
(fslpI MsgExamRegistrationInviteField (mr MsgLdapIdentificationOrEmail) & setTooltip MsgMultiEmailFieldTip) Nothing
return $ (,,,) <$> deadline <*> registerCourse <*> occurrence <*> users
formResultModal usersToEnlist (CExamR tid ssh csh examn EUsersR) $ processUsers eEnt

8
src/Handler/Exam/Form.hs
View File

@ -114,7 +114,7 @@ examCorrectorsForm mPrev = wFormToAForm $ do
miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId])
miAdd' nudge submitView csrf = do
(addRes, addView) <- mpreq (multiUserField False $ Just corrUserSuggestions) ("" & addName (nudge "email")) Nothing
(addRes, addView) <- mpreq (multiUserField False $ Just corrUserSuggestions) ("" & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
let
addRes'
| otherwise
@ -147,7 +147,7 @@ examCorrectorsForm mPrev = wFormToAForm $ do
miLayout' :: MassInputLayout ListLength (Either UserEmail UserId) ()
miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examCorrectors/layout")
fmap Set.fromList <$> massInputAccumW miAdd' miCell' miButtonAction' miLayout' ("correctors" :: Text) (fslI MsgExamCorrectors & setTooltip (uniworxMessages [MsgExamCorrectorsTip, MsgMassInputTip])) False (Set.toList <$> mPrev)
fmap Set.fromList <$> massInputAccumW miAdd' miCell' miButtonAction' miLayout' ("correctors" :: Text) (fslI MsgExamCorrectors & setTooltip MsgExamCorrectorsTip) False (Set.toList <$> mPrev)
examOccurrenceForm :: Maybe (Set ExamOccurrenceForm) -> AForm Handler (Set ExamOccurrenceForm)
examOccurrenceForm prev = wFormToAForm $ do
@ -156,7 +156,7 @@ examOccurrenceForm prev = wFormToAForm $ do
miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag
fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamOccurrences & setTooltip MsgMassInputTip) False $ Set.toList <$> prev
fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamOccurrences) False $ Set.toList <$> prev
where
examOccurrenceForm' nudge mPrev csrf = do
(eofIdRes, eofIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ eofId =<< mPrev)
@ -198,7 +198,7 @@ examPartsForm prev = wFormToAForm $ do
miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag
fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamParts & setTooltip MsgMassInputTip) False $ Set.toList <$> prev
fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamParts) False $ Set.toList <$> prev
where
examPartForm' nudge mPrev csrf = do
(epfIdRes, epfIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ epfId =<< mPrev)

6
src/Handler/ExternalExam/Form.hs
View File

@ -70,13 +70,13 @@ externalExamForm template = validateForm validateExternalExam $ \html -> do
miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "external-exam/schoolMassInput/layout")
miIdent :: Text
miIdent = "external-exams-school"
fSettings = fslI MsgExternalExamExamOfficeSchools & setTooltip (UniWorXMessages [SomeMessage MsgExternalExamExamOfficeSchoolsTip, SomeMessage MsgMassInputTip])
fSettings = fslI MsgExternalExamExamOfficeSchools & setTooltip MsgExternalExamExamOfficeSchoolsTip
fRequired = False
staffForm cRoute = massInputAccumA miAdd miCell miButtonAction miLayout miIdent fSettings fRequired
where
miAdd mkUnique submitView csrf = do
MsgRenderer mr <- getMsgRenderer
(usersRes, addView) <- mpreq (multiUserField False Nothing) ("" & addName (mkUnique "email")) Nothing
(usersRes, addView) <- mpreq (multiUserField False Nothing) ("" & addName (mkUnique "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
let
usersRes' = usersRes <&> \newDat oldDat -> if
| existing <- newDat `Set.intersection` Set.fromList oldDat
@ -97,7 +97,7 @@ externalExamForm template = validateForm validateExternalExam $ \html -> do
miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "external-exam/staffMassInput/layout")
miIdent :: Text
miIdent = "external-exams-staff"
fSettings = fslI MsgExternalExamStaff & setTooltip (UniWorXMessages [SomeMessage MsgExternalExamStaffTip, SomeMessage MsgMassInputTip])
fSettings = fslI MsgExternalExamStaff & setTooltip MsgExternalExamStaffTip
fRequired = True
validateExternalExam :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => FormValidator ExternalExamForm m ()

4
src/Handler/Sheet.hs
View File

@ -745,7 +745,7 @@ correctorForm loads' = wFormToAForm $ do
-> FieldView UniWorX
-> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
miAdd _ _ nudge submitView = Just $ \csrf -> do
(addRes, addView) <- mpreq (multiUserField False $ Just previousCorrectors) (fslpI MsgCorrector (mr MsgEMail) & setTooltip MsgMultiEmailFieldTip & addName (nudge "corrector")) Nothing
(addRes, addView) <- mpreq (multiUserField False $ Just previousCorrectors) (fslpI MsgCorrector (mr MsgLdapIdentificationOrEmail) & setTooltip MsgMultiEmailFieldTip & addName (nudge "corrector")) Nothing
let addRes' = addRes <&> \nCorrs oldData@(maybe 0 (succ . fst) . Map.lookupMax -> kStart) -> if
| existing <- Set.intersection nCorrs . Set.fromList $ Map.elems oldData
, not $ null existing
@ -821,7 +821,7 @@ correctorForm loads' = wFormToAForm $ do
filledData :: Maybe (Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)))
filledData = Just . Map.fromList . zip [0..] $ Map.toList loads -- TODO orderBy Name?!
fmap postProcess <$> massInputW MassInput{..} (fslI MsgCorrectors & setTooltip MsgMassInputTip) False filledData
fmap postProcess <$> massInputW MassInput{..} (fslI MsgCorrectors) False filledData
instance IsInvitableJunction SheetCorrector where

11
src/Handler/Submission.hs
View File

@ -178,9 +178,10 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident
| isAdmin -> courseUsers
| otherwise -> previousCoSubmittors uid
addFieldSettings, submittorSettings, singleSubSettings :: FieldSettings UniWorX
addFieldSettings = fslI MsgSubmissionMembers
submittorSettings = fslI MsgSubmissionMembers & setTooltip MsgMassInputTip
addFieldSettings :: (forall msg. RenderMessage UniWorX msg => msg -> Text) -> FieldSettings UniWorX
addFieldSettings mr = fslpI MsgSubmissionMembers $ mr MsgLdapIdentificationOrEmail
submittorSettings, singleSubSettings :: FieldSettings UniWorX
submittorSettings = fslI MsgSubmissionMembers
singleSubSettings = fslI MsgSubmissionMember
maxSize | Arbitrary{..} <- grouping = Just maxParticipants
@ -201,7 +202,7 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident
miAdd :: (Text -> Text) -> FieldView UniWorX -> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId])
miAdd nudge btn csrf = do
MsgRenderer mr <- getMsgRenderer
(addRes, addView) <- mpreq (addFieldLecturer uid) (addFieldSettings & addName (nudge "emails")) Nothing
(addRes, addView) <- mpreq (addFieldLecturer uid) (addFieldSettings mr & addName (nudge "emails")) Nothing
let addRes' = addRes <&> \newData oldData -> if
| existing <- newData `Set.intersection` Set.fromList oldData
, not $ Set.null existing
@ -228,7 +229,7 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident
-> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
miAdd _ _ nudge btn = Just $ \csrf -> do
MsgRenderer mr <- getMsgRenderer
(addRes, addView) <- mpreq (addField uid) (addFieldSettings & addName (nudge "emails")) Nothing
(addRes, addView) <- mpreq (addField uid) (addFieldSettings mr & addName (nudge "emails")) Nothing
let addRes' = addRes <&> \newData oldData -> if
| existing <- newData `Set.intersection` setOf folded oldData
, not $ Set.null existing

2
src/Handler/Term.hs
View File

@ -245,7 +245,7 @@ newTermForm template = validateForm validateTerm $ \html -> do
(const $ "" & addPlaceholder (mr MsgTermHolidayPlaceholder))
(const Nothing)
("holidays" :: Text)
(fslI MsgTermHolidays & setTooltip MsgMassInputTip)
(fslI MsgTermHolidays)
True
(tftHolidays template)
flip (renderAForm FormStandard) html $ Term

4
src/Handler/Tutorial/Form.hs
View File

@ -36,11 +36,11 @@ tutorialForm cid template html = do
uid <- liftHandler requireAuthId
let
tutorForm = Set.fromList <$> massInputAccumA miAdd' miCell' (\p -> Just . SomeRoute $ cRoute :#: p) miLayout' ("tutors" :: Text) (fslI MsgTutorialTutors & setTooltip MsgMassInputTip) False (Set.toList . tfTutors <$> template)
tutorForm = Set.fromList <$> massInputAccumA miAdd' miCell' (\p -> Just . SomeRoute $ cRoute :#: p) miLayout' ("tutors" :: Text) (fslI MsgTutorialTutors) False (Set.toList . tfTutors <$> template)
where
miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId])
miAdd' nudge submitView csrf = do
(addRes, addView) <- mpreq (multiUserField False . Just $ tutUserSuggestions uid) ("" & addName (nudge "email")) Nothing
(addRes, addView) <- mpreq (multiUserField False . Just $ tutUserSuggestions uid) ("" & addName (nudge "email") & addPlaceholder (mr MsgLdapIdentificationOrEmail)) Nothing
let
addRes'
| otherwise

4
src/Handler/Users.hs
View File

@ -613,10 +613,12 @@ postAdminNewFunctionaryInviteR = do
_other -> UTCTime (utctDay now) 0
defDeadline = beginToday{ utctDay = 14 `addDays` utctDay beginToday }
mr <- getMessageRender
function <- wreq (selectField optionsFinite) (fslI MsgFunctionaryInviteFunction) Nothing
school <- wreq (schoolFieldFor $ map E.unValue userSchools) (fslI MsgFunctionaryInviteSchool) Nothing
deadline <- wreq utcTimeField (fslI MsgExamRegistrationInviteDeadline) (Just defDeadline)
users <- wreq (multiUserField False Nothing) (fslI MsgFunctionaryInviteField & setTooltip MsgMultiEmailFieldTip) Nothing
users <- wreq (multiUserField False Nothing) (fslpI MsgFunctionaryInviteField (mr MsgLdapIdentificationOrEmail) & setTooltip MsgMultiEmailFieldTip) Nothing
return $ (,,,) <$> function <*> school <*> deadline <*> users
formResultModal invitesResult UsersR $ \(function, schoolId, deadline, users) -> do

2
src/Handler/Utils/Communication.hs
View File

@ -127,7 +127,7 @@ commR CommunicationRoute{..} = do
recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients & setTooltip MsgCommRecipientsTip) True (Just chosenRecipients')
where
miAdd (EnumPosition RecipientCustom, 0) 1 nudge submitView = Just $ \csrf -> do
(addRes, addView) <- mpreq (multiUserField True Nothing) (fslpI MsgEMail (mr MsgEMail) & setTooltip MsgMultiEmailFieldTip & addName (nudge "email")) Nothing
(addRes, addView) <- mpreq (multiUserField True Nothing) (fslpI MsgEMail (mr MsgLdapIdentificationOrEmail) & setTooltip MsgMultiEmailFieldTip & addName (nudge "email")) Nothing
let
addRes' = addRes <&> \(Set.toList -> nEmails) (maybe 0 (succ . snd . fst) . Map.lookupMax . Map.filterWithKey (\(EnumPosition c, _) _ -> c == RecipientCustom) -> kStart) -> FormSuccess . Map.fromList $ zip (map (EnumPosition RecipientCustom, ) [kStart..]) nEmails
return (addRes', $(widgetFile "widgets/communication/recipientAdd"))

30
src/Handler/Utils/Form.hs
View File

@ -610,7 +610,7 @@ uploadModeForm prev = multiActionA actions (fslI MsgSheetUploadMode) (classifyUp
currentRoute <- currentRoute'
return . SomeRoute $ currentRoute :#: frag
miIdent <- ("specific-files--" <>) <$> newIdent
postProcess =<< massInputW MassInput{..} (fslI MsgUploadSpecificFiles & setTooltip MsgMassInputTip) True (preProcess <$> prev ^? _Just . _specificFiles)
postProcess =<< massInputW MassInput{..} (fslI MsgUploadSpecificFiles) True (preProcess <$> prev ^? _Just . _specificFiles)
where
preProcess :: NonNull (Set UploadSpecificFile) -> Map ListPosition (UploadSpecificFile, UploadSpecificFile)
preProcess = Map.fromList . zip [0..] . map (\x -> (x, x)) . Set.toList . toNullable
@ -1529,7 +1529,15 @@ multiUserField onlySuggested suggestions = Field{..}
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 $ (user E.^. UserEmail, user E.^. UserDisplayName)
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}>
@ -1546,7 +1554,13 @@ multiUserField onlySuggested suggestions = Field{..}
Just lookupExpr' -> do
dbRes <- fmap (setOf $ folded . _Value). liftHandler . runDB . E.select $ do
user <- lookupExpr'
E.where_ $ user E.^. UserEmail E.==. E.val email
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
@ -1555,6 +1569,16 @@ multiUserField onlySuggested suggestions = Field{..}
| otherwise
-> throwE $ SomeMessage MsgAmbiguousEmail
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

4
src/Handler/Utils/Form/Occurrences.hs
View File

@ -44,7 +44,7 @@ occurrencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do
(\p -> Just . SomeRoute $ cRoute :#: p)
miLayout'
(miIdent' <> "__scheduled" :: Text)
(fslI MsgScheduleRegular & setTooltip MsgMassInputTip)
(fslI MsgScheduleRegular)
False
(Set.toList . occurrencesScheduled <$> mPrev)
where
@ -80,7 +80,7 @@ occurrencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do
(\p -> Just . SomeRoute $ cRoute :#: p)
miLayout'
(miIdent' <> "__exceptions" :: Text)
(fslI MsgScheduleExceptions & setTooltip (UniWorXMessages [SomeMessage MsgScheduleExceptionsTip, SomeMessage MsgMassInputTip]))
(fslI MsgScheduleExceptions & setTooltip MsgScheduleExceptionsTip)
False
(Set.toList . occurrencesExceptions <$> mPrev)
where