chore(firm): various
- multiSelectField working - section hiding demo working - modal links access rights checking
This commit is contained in:
parent
7fc6e43131
commit
c5c4a62de0
@ -325,7 +325,12 @@ mkFirmAllTable isAdmin uid = do
|
||||
unless isAdmin $ E.where_ $ E.exists $ do -- only show associated companies
|
||||
usrCmpy <- E.from $ E.table @UserCompany
|
||||
E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId
|
||||
E.&&. usrCmpy E.^. UserCompanyUser E.==. E.val uid
|
||||
E.&&. ((usrCmpy E.^. UserCompanyUser E.==. E.val uid E.&&. usrCmpy E.^. UserCompanySupervisor)
|
||||
E.||. E.exists (do
|
||||
usrSpr <- E.from $ E.table @UserSupervisor
|
||||
E.where_ $ usrSpr E.^. UserSupervisorUser E.==. usrCmpy E.^. UserCompanyUser
|
||||
E.&&. usrSpr E.^. UserSupervisorSupervisor E.==. E.val uid
|
||||
))
|
||||
return ( cmpy -- 1
|
||||
, cmpy & firmCountUsers -- 2
|
||||
, cmpy & firmHasSupervisors -- 3
|
||||
@ -598,7 +603,7 @@ mkFirmUserTable isAdmin cid = do
|
||||
dbtRowKey = queryUserUser >>> (E.^. UserId)
|
||||
dbtProj = dbtProjId
|
||||
dbtColonnade = formColonnade $ mconcat
|
||||
[ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey))
|
||||
[ guardMonoid isAdmin $ dbSelect (applying _2) id (return . view (resultUserUser . _entityKey))
|
||||
, colUserNameModalHdr MsgTableCompanyUser ForProfileDataR
|
||||
, sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \(view resultUserUser -> entUsr ) -> cellHasMatrikelnummerLinked entUsr
|
||||
, sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \(view $ resultUserUser . _userCompanyPersonalNumber -> t) -> foldMap textCell t
|
||||
@ -676,7 +681,7 @@ mkFirmUserTable isAdmin cid = do
|
||||
dbtFilterUI mPrev = mconcat
|
||||
[ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev
|
||||
, prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor)
|
||||
-- , prismAForm (multiFilter "supervisors-are" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor)
|
||||
, prismAForm (multiFilter "supervisors-are" . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor)
|
||||
, 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)
|
||||
@ -785,17 +790,19 @@ postFirmUsersR fsh = do
|
||||
, formSubmit = FormSubmit
|
||||
, formAnchor = Just addFormAnchor
|
||||
}
|
||||
formResult fucrRes $ \FirmUserChangeRequest{..} -> when (isJust fucrPostalPref || isJust fucrPostalAddr) $ do
|
||||
let changes = foldMap (\pp -> [UserPrefersPostal E.=. E.val pp]) fucrPostalPref <>
|
||||
foldMap (\pa -> [UserPostAddress E.=. E.justVal pa]) fucrPostalAddr -- seems weird, but: Nothing means no change, and not delete address!
|
||||
nrChanged <- runDB $ E.updateCount $ \usr -> do
|
||||
E.set usr changes
|
||||
E.where_ $ E.exists $ do
|
||||
usrCmpy <- E.from $ E.table @UserCompany
|
||||
E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. E.val cid
|
||||
E.&&. usrCmpy E.^. UserCompanyUser E.==. usr E.^. UserId
|
||||
addMessageI Info $ MsgFirmUserChanges nrChanged
|
||||
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
||||
formResult fucrRes $ \FirmUserChangeRequest{fucrPostalPref=fucrPPref, fucrPostalAddr=fucrPAddr} -> do
|
||||
-- let fucrPAddr = canonical fucrPAddr' TODO
|
||||
when (isJust fucrPPref || isJust fucrPAddr) $ do
|
||||
let changes = foldMap (\pp -> [UserPrefersPostal E.=. E.val pp]) fucrPPref <>
|
||||
foldMap (\pa -> [UserPostAddress E.=. E.justVal pa]) fucrPAddr -- seems weird, but: Nothing means no change, and not delete address!
|
||||
nrChanged <- runDB $ E.updateCount $ \usr -> do
|
||||
E.set usr changes
|
||||
E.where_ $ E.exists $ do
|
||||
usrCmpy <- E.from $ E.table @UserCompany
|
||||
E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. E.val cid
|
||||
E.&&. usrCmpy E.^. UserCompanyUser E.==. usr E.^. UserId
|
||||
addMessageI Info $ MsgFirmUserChanges nrChanged
|
||||
reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes
|
||||
|
||||
siteLayout (citext2widget companyName) $ do
|
||||
setTitle $ toHtml $ CI.original companyShorthand <> "-" <> tshow companyAvsId
|
||||
|
||||
@ -226,7 +226,7 @@ cellHasUserModal toLink user =
|
||||
nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^. _entityVal . _userSurname)
|
||||
lWdgt = do
|
||||
uuid <- liftHandler $ encrypt uid
|
||||
modal nWdgt (Left $ SomeRoute $ toLink uuid)
|
||||
modalAccess False nWdgt nWdgt $ toLink uuid
|
||||
in cell lWdgt
|
||||
|
||||
-- | like `cellHasUserModal` but with fixed route and showing an edit icon instead
|
||||
@ -234,10 +234,10 @@ cellEditUserModal :: (IsDBTable m c, HasEntity u User) => u -> DBCell m c
|
||||
cellEditUserModal user =
|
||||
let userEntity = user ^. hasEntityUser
|
||||
uid = userEntity ^. _entityKey
|
||||
nWdgt = toWidget $ icon IconUserEdit
|
||||
nWdgt = toWidget $ icon IconUserEdit
|
||||
lWdgt = do
|
||||
uuid <- liftHandler $ encrypt uid
|
||||
modal nWdgt (Left $ SomeRoute $ ForProfileR uuid)
|
||||
modalAccess True nWdgt mempty $ ForProfileR uuid
|
||||
in cell lWdgt
|
||||
cellHasMatrikelnummer :: (IsDBTable m a, HasUser u) => u -> DBCell m a
|
||||
cellHasMatrikelnummer = maybe mempty textCell . view _userMatrikelnummer
|
||||
@ -246,7 +246,7 @@ cellHasMatrikelnummerLinked :: (IsDBTable m a, HasEntity u User) => u -> DBCell
|
||||
cellHasMatrikelnummerLinked usr
|
||||
| Just matNr <- usrEntity ^. _userMatrikelnummer = cell $ do
|
||||
uuid <- liftHandler $ encrypt $ usrEntity ^. _entityKey
|
||||
modal (text2widget matNr) (Left $ SomeRoute $ AdminAvsUserR uuid)
|
||||
modalAccess False (text2widget matNr) mempty (AdminAvsUserR uuid)
|
||||
| otherwise = mempty
|
||||
where
|
||||
usrEntity = usr ^. hasEntityUser
|
||||
@ -364,7 +364,7 @@ qualificationValidUntilCell' mbToLink d qb qu = cell $ case mbToLink of
|
||||
Nothing -> headWgt <> dateWgt
|
||||
Just toLink -> do
|
||||
uuid <- liftHandler $ encrypt $ qu ^. hasQualificationUser . _qualificationUserUser
|
||||
let modalWgt = modal dateWgt (Left $ SomeRoute $ toLink uuid)
|
||||
let modalWgt = modalAccess False dateWgt dateWgt $ toLink uuid
|
||||
headWgt <> modalWgt
|
||||
where
|
||||
dateWgt = formatTimeW SelFormatDate (qu ^. hasQualificationUser . _qualificationUserValidUntil)
|
||||
@ -385,7 +385,8 @@ qualificationValidReasonCell' mbToLink showReason d qb qu = ic <> foldMap blc qb
|
||||
dc tstamp
|
||||
| Just toLink <- mbToLink = cell $ do
|
||||
uuid <- liftHandler $ encrypt uid
|
||||
modal (formatTimeW SelFormatDate tstamp) (Left $ SomeRoute $ toLink uuid)
|
||||
let dWgt = formatTimeW SelFormatDate tstamp
|
||||
modalAccess False dWgt dWgt $ toLink uuid
|
||||
-- anchorCellM (toLink <$> encrypt uid)
|
||||
| otherwise = dateCell tstamp
|
||||
uid = qu ^. hasQualificationUser . _qualificationUserUser
|
||||
@ -403,7 +404,8 @@ qualificationValidReasonCell'' mbToLink showReason d qb qu extValid = ic <> icEr
|
||||
dc tstamp
|
||||
| Just toLink <- mbToLink = cell $ do
|
||||
uuid <- liftHandler $ encrypt uid
|
||||
modal (formatTimeW SelFormatDate tstamp) (Left $ SomeRoute $ toLink uuid)
|
||||
let dWgt = formatTimeW SelFormatDate tstamp
|
||||
modalAccess False dWgt dWgt $ toLink uuid
|
||||
-- anchorCellM (toLink <$> encrypt uid)
|
||||
| otherwise = dateCell tstamp
|
||||
uid = qu ^. hasQualificationUser . _qualificationUserUser
|
||||
@ -463,7 +465,8 @@ avsPersonNoCell = numCell . view _userAvsNoPerson
|
||||
avsPersonNoLinkedCell :: (IsDBTable m c, HasUserAvs a) => a -> DBCell m c
|
||||
avsPersonNoLinkedCell a = cell $ do
|
||||
uuid <- liftHandler $ encrypt $ a ^. _userAvsUser
|
||||
modal (toWgt $ toMessage $ a ^. _userAvsNoPerson) (Left $ SomeRoute $ AdminAvsUserR uuid)
|
||||
let nWgt = toWgt $ toMessage $ a ^. _userAvsNoPerson
|
||||
modalAccess False nWgt nWgt $ AdminAvsUserR uuid
|
||||
|
||||
avsPersonCardCell :: (IsDBTable m c) => Set AvsDataPersonCard -> DBCell m c
|
||||
avsPersonCardCell cards = wgtCell
|
||||
|
||||
@ -123,6 +123,15 @@ editedByW fmt tm usr = do
|
||||
[whamlet|_{MsgUtilEditedBy usr ft}|]
|
||||
|
||||
|
||||
-- | like `modal`, but checks access rights to the link
|
||||
modalAccess :: Bool -> Widget -> Widget -> Route UniWorX -> Widget
|
||||
modalAccess writeAccess wdgtYes wdgtNo route = do
|
||||
authOk <- liftHandler $ bool hasReadAccessTo hasWriteAccessTo writeAccess route
|
||||
if authOk
|
||||
then modal wdgtYes (Left $ SomeRoute route)
|
||||
else wdgtNo
|
||||
|
||||
|
||||
----------
|
||||
-- HEAT --
|
||||
----------
|
||||
|
||||
@ -38,7 +38,7 @@ customModal Modal{..} = do
|
||||
route <- traverse toTextUrl $ modalContent ^? _Left
|
||||
modalTrigger route triggerId'
|
||||
|
||||
-- | Create a link to a modal
|
||||
-- | Create a link to a modal, does not check link, see `Handler.Utils.Widget.modalAccess` for a checking variant
|
||||
modal :: WidgetFor site () -- ^ Widget that represents the link
|
||||
-> Either (SomeRoute site) (WidgetFor site ()) -- ^ Modal contant: either dynamic link or static widget
|
||||
-> WidgetFor site () -- ^ result widget
|
||||
|
||||
Loading…
Reference in New Issue
Block a user