From a15862ea72bc374af870ef3a23f86ae32c2c67a9 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 4 Dec 2023 16:03:31 +0100 Subject: [PATCH 01/28] fix(print): keep print jobs on user merge and lms id deletion --- models/print.model | 4 ++-- src/Handler/Utils/Users.hs | 4 ++++ 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/models/print.model b/models/print.model index ee3f1ea7c..ee22cf922 100644 --- a/models/print.model +++ b/models/print.model @@ -9,11 +9,11 @@ PrintJob file ByteString -- stores plain pdf; otherwise use FileContentReference Maybe created UTCTime acknowledged UTCTime Maybe - recipient UserId Maybe OnDeleteCascade OnUpdateCascade -- optional as some letters may contain just an address + recipient UserId Maybe OnDeleteSetNull OnUpdateCascade -- optional as some letters may contain just an address sender UserId Maybe OnDeleteSetNull OnUpdateCascade -- senders and associations are optional course CourseId Maybe OnDeleteCascade OnUpdateCascade qualification QualificationId Maybe OnDeleteCascade OnUpdateCascade - lmsUser LmsIdent Maybe OnDeleteCascade OnUpdateCascade -- allows tracking if recipient has been notified; must be unique + lmsUser LmsIdent Maybe OnDeleteSetNull OnUpdateCascade -- allows tracking if recipient has been notified; must be unique -- UniquePrintJobLmsUser lmsUser -- Note that in fact multiple print jobs per LMS user are possible! -- UniquePrintJobApcIdent apcIdent -- TODO: not yet enforced, since LmsIdent is currently used deriving Generic diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 1e4a28487..5c85c9c73 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -847,6 +847,10 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do delete oldQKey -- deleteWhere [ QualificationUserUser ==. oldUserId ] -- no longer needed + -- PrintJobs + updateWhere [ PrintJobRecipient ==. Just oldUserId ] [ PrintJobRecipient =. Just newUserId ] + updateWhere [ PrintJobSender ==. Just oldUserId ] [ PrintJobSender =. Just newUserId ] + -- Supervision is fully merged E.insertSelectWithConflict UniqueUserSupervisor -- 2.39.2 From 3acb847915010d10358ea02000c231dbba7cba26 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 5 Dec 2023 11:52:13 +0100 Subject: [PATCH 02/28] fix(firm): supervisor filter --- src/Handler/Firm.hs | 22 +++++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 370e30467..194eea1dc 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -507,7 +507,7 @@ mkFirmAllTable isAdmin uid = do dbtFilter = mconcat [ single $ fltrCompanyNameNr queryAllCompany , single ("company-number", FilterColumn $ E.mkExactFilterWithComma readMay (queryAllCompany >>> (E.^. CompanyAvsId))) - , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do + , single ("is-associate" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do (usr :& usrCmp) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser) @@ -517,6 +517,25 @@ mkFirmAllTable isAdmin uid = do E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion) ) ) + , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do + (usr :& usrCmp) <- E.from $ E.table @User + `E.leftJoin` E.table @UserCompany + `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser) + E.where_ $ ((usr E.^. UserDisplayName `E.hasInfix` E.val criterion) + E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion)) + E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion) + ) E.&&. ((E.isTrue (usrCmp E.?. UserCompanySupervisor) E.&&. usrCmp E.? . UserCompanyCompany E.?=. queryAllCompany row E.^. CompanyId) + E.||. E.exists (do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId + E.&& E.exists (do + usrSub <- E.from $ E.table @UserCompany + E.where_ $ usrSub E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser + E.&&. usrSub E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId + ) + ) + ) + ) , single ("foreign-supervisor", FilterColumn $ \row (getLast -> criterion) -> -- let checkSuper = do -- expensive -- usrSpr <- E.from $ E.table @UserSupervisor @@ -552,6 +571,7 @@ mkFirmAllTable isAdmin uid = do [ fltrCompanyNameUI mPrev , prismAForm (singletonFilter "company-number") mPrev $ aopt textField (fslI MsgTableCompanyNo) , prismAForm (singletonFilter "is-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor) + , prismAForm (singletonFilter "is-associate") mPrev $ aopt textField (fslI MsgTableCompanyUser) , prismAForm (singletonFilter "foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterForeignSupervisor) , prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern) ] -- 2.39.2 From 9878956716b04c7ae88989cb9b059d3edcb923dc Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 5 Dec 2023 12:12:51 +0100 Subject: [PATCH 03/28] fix(firm): set supervisor field not all fields required --- src/Handler/Firm.hs | 22 +++++++++++----------- src/Utils.hs | 1 + 2 files changed, 12 insertions(+), 11 deletions(-) diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 194eea1dc..c6d77abc1 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -520,15 +520,15 @@ mkFirmAllTable isAdmin uid = do , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do (usr :& usrCmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany - `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser) + `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser) E.where_ $ ((usr E.^. UserDisplayName `E.hasInfix` E.val criterion) E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion)) E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion) - ) E.&&. ((E.isTrue (usrCmp E.?. UserCompanySupervisor) E.&&. usrCmp E.? . UserCompanyCompany E.?=. queryAllCompany row E.^. CompanyId) + ) E.&&. ((E.isTrue (usrCmp E.?. UserCompanySupervisor) E.&&. usrCmp E.?. UserCompanyCompany E.?=. queryAllCompany row E.^. CompanyId) E.||. E.exists (do usrSpr <- E.from $ E.table @UserSupervisor E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId - E.&& E.exists (do + E.&&. E.exists (do usrSub <- E.from $ E.table @UserCompany E.where_ $ usrSub E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser E.&&. usrSub E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId @@ -638,8 +638,8 @@ data FirmUserActionData = FirmUserActNotifyData -- , firmUserActResetMutualSupervision :: Maybe Bool } | FirmUserActSetSupervisorData - { firmUserActSetSuperNames :: Set Text - , firmUserActSetSuperIds :: [UserId] + { firmUserActSetSuperNames :: Maybe (Set Text) + , firmUserActSetSuperIds :: Maybe [UserId] , firmUserActSetSuperReroute :: Bool , firmUserActSetSuperKeep :: Bool } @@ -798,10 +798,10 @@ mkFirmUserTable isAdmin cid = do <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) -- <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) , singletonMap FirmUserActSetSupervisor $ FirmUserActSetSupervisorData - <$> apopt (textField & cfAnySeparatedSet) (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing - <*> apopt supervisorsField (fslI MsgFirmSetSupervisor) Nothing - <*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False) - <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just False) + <$> aopt (textField & cfAnySeparatedSet) (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing + <*> aopt supervisorsField (fslI MsgFirmSetSupervisor) Nothing + <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False) + <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just False) , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData <$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True) , singletonMap FirmUserActChangeContact $ FirmUserActChangeContactData @@ -887,10 +887,10 @@ postFirmUsersR fsh = do addMessageI Info $ MsgFirmResetSupervision delSupers newSupers reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes (FirmUserActSetSupervisorData{..}, set2NonEmpty (error "Unexpected empty user list in getFirmUserR action handler.") -> uids) -> do - avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmUserActSetSuperNames + avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser $ maybeMonoid firmUserActSetSuperNames let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers usersFound = mapMaybe snd usersFound' - newSupers = Set.toList $ Set.fromList firmUserActSetSuperIds <> Set.fromList usersFound + newSupers = Set.toList $ Set.fromList (maybeMonoid firmUserActSetSuperIds) <> Set.fromList usersFound nrSupers = fromIntegral $ length newSupers nrUsers = fromIntegral $ length uids unless (null usersNotFound) $ diff --git a/src/Utils.hs b/src/Utils.hs index a2b35c37a..2093da8b2 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -626,6 +626,7 @@ guardMonoid True x = x assertMonoid :: Monoid m => (m -> Bool) -> m -> m assertMonoid f x = guardMonoid (f x) x +-- fold would also do, but is more risky if the Folable isn't Maybe maybeMonoid :: Monoid m => Maybe m -> m -- ^ Identify `Nothing` with `mempty` maybeMonoid = fromMaybe mempty -- 2.39.2 From fc0ca7b854a686cf395dadf81b7423e530fd26b8 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 5 Dec 2023 18:39:59 +0100 Subject: [PATCH 04/28] fix(firm): group multi select field supervisor However, grouped multi select does not work for some reason. --- .../uniworx/categories/firm/de-de-formal.msg | 3 ++ messages/uniworx/categories/firm/en-eu.msg | 3 ++ messages/uniworx/misc/de-de-formal.msg | 2 +- messages/uniworx/misc/en-eu.msg | 2 +- src/Handler/Firm.hs | 38 ++++++++++++------- 5 files changed, 33 insertions(+), 15 deletions(-) diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index f938dbaa9..c7a92efb3 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -2,6 +2,9 @@ # # SPDX-License-Identifier: AGPL-3.0-or-later +FirmSuperDefault: Standardansprechpartner +FirmSuperForeign: Firmenfremde Ansprechpartner +FirmSuperIrregular: Irreguläre Ansprechpartner FirmAssociates: Firmenangehörige FirmContact: Firmenkontakt FirmNoContact: Keine allgemeinen Kontaktinformationen bekannt. diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 747900397..043312a20 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -2,6 +2,9 @@ # # SPDX-License-Identifier: AGPL-3.0-or-later +FirmSuperDefault: Default supervisor +FirmSuperForeign: External supervisor +FirmSuperIrregular: Irregular supervisor FirmAssociates: Company associated users FirmContact: Company Contact FirmNoContact: No general contact information known. diff --git a/messages/uniworx/misc/de-de-formal.msg b/messages/uniworx/misc/de-de-formal.msg index eaa02c0fa..3fcd6ffe6 100644 --- a/messages/uniworx/misc/de-de-formal.msg +++ b/messages/uniworx/misc/de-de-formal.msg @@ -10,7 +10,7 @@ BoolIrrelevant !ident-ok: — FieldPrimary: Hauptfach FieldSecondary: Nebenfach MultiEmailFieldTip: Es sind mehrere, Komma-separierte, E-Mail-Adressen möglich -MultiSelectTip: Mehrfachauswahl mit Strg-Klick +MultiSelectTip: Mehrfachauswahl und Abwählen mit Strg-Klick WeekDay: Wochentag LdapIdentificationOrEmail: Fraport AG-Kennung / E-Mail-Adresse Months num@Int64: #{num} #{pluralDE num "Monat" "Monate"} diff --git a/messages/uniworx/misc/en-eu.msg b/messages/uniworx/misc/en-eu.msg index 5b6b15f5b..ed8bda4db 100644 --- a/messages/uniworx/misc/en-eu.msg +++ b/messages/uniworx/misc/en-eu.msg @@ -10,7 +10,7 @@ BoolIrrelevant: — FieldPrimary: Major FieldSecondary: Minor MultiEmailFieldTip: Multiple emails addresses may be specified (comma-separated) -MultiSelectTip: Multiple selection via Ctrl-Click +MultiSelectTip: Multiple selection and desection via Ctrl-Click WeekDay: Day of the week LdapIdentificationOrEmail: Fraport AG-Kennung / email address Months num: #{num} #{pluralEN num "Month" "Months"} diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index c6d77abc1..fabb20538 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -380,14 +380,14 @@ firmCountForeignSupervisors cmpy = E.subSelectCountDistinct $ do -- firmCountActiveReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) -- firmCountActiveReroutes cmpy = E.subSelectCountDistinct $ do -- usrSuper <- E.from $ E.table @UserSupervisor --- E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) +-- E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) -- E.&&. usrSuper E.^. UserSupervisorRerouteNotifications -- pure $ usrSuper E.^. UserSupervisorSupervisor firmCountActiveReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) firmCountActiveReroutes cmpy = E.subSelectCount $ do usrSuper <- E.from $ E.table @UserSupervisor - E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) + E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) E.&&. usrSuper E.^. UserSupervisorRerouteNotifications firmQuerySupervisedBy :: CompanyId -> Maybe (E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity User) -> E.SqlQuery () @@ -682,20 +682,32 @@ instance HasUser UserCompanyTableData where mkFirmUserTable :: Bool -> CompanyId -> DB (FormResult (FirmUserActionData, Set UserId), Widget) mkFirmUserTable isAdmin cid = do + mr <- getMessageRender let - mkSprOption (E.Value uid, E.Value udn) = do + mkSprOption (E.Value uid, E.Value udn, E.Value mbSpr) = do uuid <- toPathPiece <$> encryptUser uid - return Option{ optionDisplay = udn, optionInternalValue = uid, optionExternalValue = uuid } - procOptions = fmap mkOptionList . traverse mkSprOption + return (Option{ optionDisplay = udn, optionInternalValue = uid, optionExternalValue = uuid }, mbSpr) + + procOptions rawSupers = do + procSupers <- traverse mkSprOption rawSupers + return $ mkOptionListGrouped $ filter (notNull . snd) + [ (mr MsgFirmSuperDefault , [opt | (opt, Just True ) <- procSupers]) + , (mr MsgFirmSuperIrregular, [opt | (opt, Just False) <- procSupers]) + , (mr MsgFirmSuperForeign , [opt | (opt, Nothing ) <- procSupers]) + ] rawSupers <- E.select $ do - usr <- E.from $ E.table @User - E.where_ $ E.exists $ firmQuerySupervisedBy cid Nothing usr - return (usr E.^. UserId, usr E.^. UserDisplayName) + (usr :& usrCmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany + `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser E.&&. usrCmp E.?. UserCompanyCompany E.==. E.justVal cid) + E.where_ $ E.isTrue (usrCmp E.?. UserCompanySupervisor) + E.||. E.exists (firmQuerySupervisedBy cid Nothing usr) + return (usr E.^. UserId, usr E.^. UserDisplayName, usrCmp E.?. UserCompanySupervisor) let -- supervisorField :: Field Handler UserId - -- supervisorField = selectField $ procOptions rawSupers - supervisorsField = multiSelectField $ procOptions rawSupers + supervisorField = selectField $ procOptions rawSupers + -- TODO: Markieren Alien/Standard/Irregulär + -- supervisorsField = multiSelectField $ procOptions rawSupers + -- supervisorsField = convertField pure head supervisorField fsh = unCompanyKey cid resultDBTable = DBTable{..} @@ -784,8 +796,8 @@ mkFirmUserTable isAdmin cid = do -- superField = selectField $ ???? dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev - -- , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor) - , prismAForm (multiFilter "supervisors-are" . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor & setTooltip MsgMultiSelectTip ) + , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor) + -- , prismAForm (multiFilter "supervisors-are" . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor & setTooltip MsgMultiSelectTip ) , prismAForm (singletonFilter "has-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterSupervisor) , prismAForm (singletonFilter "has-company-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorCompany fsh) , prismAForm (singletonFilter "has-foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorForeign fsh) @@ -799,7 +811,7 @@ mkFirmUserTable isAdmin cid = do -- <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) , singletonMap FirmUserActSetSupervisor $ FirmUserActSetSupervisorData <$> aopt (textField & cfAnySeparatedSet) (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing - <*> aopt supervisorsField (fslI MsgFirmSetSupervisor) Nothing + <*> fmap (fmap pure) (aopt supervisorField (fslI MsgFirmSetSupervisor) Nothing) <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False) <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just False) , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData -- 2.39.2 From 3aa89019a8b4393da0eca715871a3793c1e3abb2 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 6 Dec 2023 11:50:08 +0100 Subject: [PATCH 05/28] fix(form): multiSelectField working with grouped options --- messages/uniworx/utils/utils/de-de-formal.msg | 1 + messages/uniworx/utils/utils/en-eu.msg | 1 + src/Handler/Firm.hs | 21 ++++---- src/Utils/Form.hs | 48 +++++++++++++++++++ 4 files changed, 60 insertions(+), 11 deletions(-) diff --git a/messages/uniworx/utils/utils/de-de-formal.msg b/messages/uniworx/utils/utils/de-de-formal.msg index 067b7ba11..5ff122fb1 100644 --- a/messages/uniworx/utils/utils/de-de-formal.msg +++ b/messages/uniworx/utils/utils/de-de-formal.msg @@ -98,6 +98,7 @@ RoomReferenceLinkInstructions: Anweisungen RoomReferenceLinkInstructionsPlaceholder: Anweisungen UtilEmptyChoice: Auswahl war leer UtilEmptyNoChangeTip: Eine leere Eingabe belässt den vorherigen Wert unverändert. +MultiNoSelection: Keine Auswahl #invitation.hs InvitationAction: Aktion diff --git a/messages/uniworx/utils/utils/en-eu.msg b/messages/uniworx/utils/utils/en-eu.msg index cafb5fac8..f65004cd1 100644 --- a/messages/uniworx/utils/utils/en-eu.msg +++ b/messages/uniworx/utils/utils/en-eu.msg @@ -98,6 +98,7 @@ RoomReferenceLinkInstructions: Instructions RoomReferenceLinkInstructionsPlaceholder: Instructions UtilEmptyChoice: Empty selection UtilEmptyNoChangeTip: Existing values remain unchanged if this field is left empty. +MultiNoSelection: No selection #invitation.hs InvitationAction: Action diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index fabb20538..53914269e 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -94,7 +94,7 @@ firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts) <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) mkAct _ FirmActAddSupersvisors = singletonMap FirmActAddSupersvisors $ FirmActAddSupersvisorsData <$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing - <*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (Just True) + <*> areq checkBoxField (fslI MsgTableIsDefaultReroute) (Just True) <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing mkAct _ FirmActChangeContactFirm = singletonMap FirmActChangeContactFirm $ FirmActChangeContactFirmData <$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing @@ -704,10 +704,9 @@ mkFirmUserTable isAdmin cid = do return (usr E.^. UserId, usr E.^. UserDisplayName, usrCmp E.?. UserCompanySupervisor) let -- supervisorField :: Field Handler UserId - supervisorField = selectField $ procOptions rawSupers - -- TODO: Markieren Alien/Standard/Irregulär - -- supervisorsField = multiSelectField $ procOptions rawSupers - -- supervisorsField = convertField pure head supervisorField + -- supervisorField = selectField' (Just $ SomeMessage MsgMultiNoSelection) $ procOptions rawSupers + supervisorsField = multiSelectField' (Just $ SomeMessage MsgMultiNoSelection) $ procOptions rawSupers + fsh = unCompanyKey cid resultDBTable = DBTable{..} @@ -796,8 +795,8 @@ mkFirmUserTable isAdmin cid = do -- superField = selectField $ ???? dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev - , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor) - -- , prismAForm (multiFilter "supervisors-are" . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor & setTooltip MsgMultiSelectTip ) + -- , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor) + , prismAForm (multiFilter "supervisors-are" . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor & setTooltip MsgMultiSelectTip) , prismAForm (singletonFilter "has-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterSupervisor) , prismAForm (singletonFilter "has-company-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorCompany fsh) , prismAForm (singletonFilter "has-foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorForeign fsh) @@ -810,10 +809,10 @@ mkFirmUserTable isAdmin cid = do <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) -- <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) , singletonMap FirmUserActSetSupervisor $ FirmUserActSetSupervisorData - <$> aopt (textField & cfAnySeparatedSet) (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing - <*> fmap (fmap pure) (aopt supervisorField (fslI MsgFirmSetSupervisor) Nothing) - <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False) - <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just False) + <$> aopt (textField & cfAnySeparatedSet) (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing + <*> aopt supervisorsField (fslI MsgFirmSetSupervisor & setTooltip MsgMultiSelectTip) Nothing + <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False) + <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just False) , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData <$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True) , singletonMap FirmUserActChangeContact $ FirmUserActChangeContactData diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 39107331e..1a4bc3aa9 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -950,6 +950,54 @@ selectField' optMsg mkOpts = Field{..} #{optionDisplay opt} |] +multiSelectField' :: ( Eq a + , RenderMessage (HandlerSite m) FormMessage + , MonadHandler m + ) + => Maybe (SomeMessage (HandlerSite m)) -- ^ Caption used for @Nothing@-Option, if Field is optional and whether to show such an option + -> HandlerT (HandlerSite m) IO (OptionList a) + -> Field m [a] +-- ^ Like @multiSelectField@, but it can handle OptionListGrouped and also offers more control over the @Nothing@-Option, if Field is optional +multiSelectField' optMsg mkOpts = Field{..} + where + fieldEnctype = UrlEncoded + + fieldParse [] _ = return $ Right Nothing + fieldParse optlist _ = do + let optlist' = filter notNull optlist + readExternal <- view _olReadExternal <$> liftHandler mkOpts + return . maybe (Left . SomeMessage $ MsgInvalidEntry $ T.intercalate ", " optlist') (Right . Just) $ mapM readExternal optlist' + -- case mapM readExternal optlist' of + -- Nothing -> return $ Left $ SomeMessage $ MsgInvalidEntry $ T.intercalate ", " optlist' + -- res -> return $ Right res + + fieldView theId name attrs val isReq = do + opts <- liftHandler mkOpts + let + rendered = case val of + Left _ -> [] + Right xs -> [optionExternalValue o | o <- opts ^.. _olOptions, x <- xs, x == optionInternalValue o] + isSel Nothing = ClassyPrelude.Yesod.null rendered + isSel (Just opt) = optionExternalValue opt `elem` rendered + [whamlet| + $newline never +