Merge branch 'fradrive/cr3' of ssh://gitlab.uniworx.de/fradrive/fradrive into fradrive/cr3
This commit is contained in:
commit
32a79ee2c9
@ -96,7 +96,7 @@ UserSetSupervisor: Ansprechpartner ersetzen
|
||||
UserRemoveSupervisor: Alle Ansprechpartner entfernen
|
||||
UserIsSupervisor: Ist Ansprechpartner
|
||||
UserAvsSwitchCompany: Als Primärfirma verwenden
|
||||
UserAvsCompanySwitched c@CompanyName: Primärfirma gewechselt zu #{tshow c}
|
||||
UserAvsCompanySwitched c@CompanyShorthand: Primärfirma gewechselt zu #{tshow c}
|
||||
AllUsersLdapSync: Alle LDAP-Synchronisieren
|
||||
AllUsersAvsSync: Alle AVS-Synchronisieren
|
||||
AuthKindLDAP: Fraport AG Kennung
|
||||
|
||||
@ -26,6 +26,7 @@ import qualified Database.Esqueleto.Utils as E
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Avs
|
||||
import Handler.Utils.Users
|
||||
-- import Handler.Utils.Company
|
||||
import Handler.Health.Interface
|
||||
|
||||
import Handler.Admin.Test as Handler.Admin
|
||||
@ -374,15 +375,28 @@ mkProblemLogTable = over _1 postprocess <$> dbTable validator DBTable{..}
|
||||
let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
|
||||
return (act, usrSet)
|
||||
|
||||
adminProblemCell :: IsDBTable m a => AdminProblem -> DBCell m a
|
||||
-- note that adminProblemCompany/adminProblemCompanyOld and adminProblemUser are automatically displayed within their own columns
|
||||
adminProblemCell AdminProblemNewCompany{}
|
||||
= i18nCell MsgAdminProblemNewCompany
|
||||
adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminProblemSupervisorReroute}
|
||||
= i18nCell (MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute) <> companyIdCell adminProblemCompanyNew
|
||||
adminProblemCell AdminProblemSupervisorLeftCompany{adminProblemSupervisorReroute}
|
||||
= i18nCell (MsgAdminProblemSupervisorLeftCompany adminProblemSupervisorReroute)
|
||||
adminProblemCell AdminProblemNewlyUnsupervised{adminProblemCompanyNew}
|
||||
= i18nCell MsgAdminProblemNewlyUnsupervised <> companyIdCell adminProblemCompanyNew
|
||||
adminProblemCell AdminProblemUnknown{adminProblemText}
|
||||
= textCell $ "Problem: " <> adminProblemText
|
||||
-- adminProblemCell :: IsDBTable m a => AdminProblem -> DBCell m a
|
||||
-- -- note that adminProblemCompany/adminProblemCompanyOld and adminProblemUser are automatically displayed within their own columns
|
||||
-- adminProblemCell AdminProblemNewCompany{}
|
||||
-- = i18nCell MsgAdminProblemNewCompany
|
||||
-- adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminProblemSupervisorReroute}
|
||||
-- = i18nCell (MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute) <> companyIdCell adminProblemCompanyNew
|
||||
-- adminProblemCell AdminProblemSupervisorLeftCompany{adminProblemSupervisorReroute}
|
||||
-- = i18nCell (MsgAdminProblemSupervisorLeftCompany adminProblemSupervisorReroute)
|
||||
-- adminProblemCell AdminProblemNewlyUnsupervised{adminProblemCompanyNew}
|
||||
-- = i18nCell MsgAdminProblemNewlyUnsupervised <> companyIdCell adminProblemCompanyNew
|
||||
-- adminProblemCell AdminProblemUnknown{adminProblemText}
|
||||
-- = textCell $ "Problem: " <> adminProblemText
|
||||
|
||||
|
||||
-- msgAdminProblem :: AdminProblem -> DB (SomeMessages UniWorX)
|
||||
-- msgAdminProblem AdminProblemNewCompany{adminProblemCompany=comp} = return $
|
||||
-- SomeMessages [SomeMessage MsgAdminProblemNewCompany, text2message ": ", company2msg comp]
|
||||
-- msgAdminProblem AdminProblemSupervisorNewCompany{adminProblemCompany=comp, adminProblemCompanyNew=newComp} = return $
|
||||
-- SomeMessages [SomeMessage MsgAdminProblemSupervisorNewCompany, text2message ": ", company2msg comp, text2message " -> ", company2msg newComp]
|
||||
-- msgAdminProblem AdminProblemSupervisorLeftCompany{adminProblemCompany=comp} = return $
|
||||
-- SomeMessages [SomeMessage MsgAdminProblemSupervisorLeftCompany, text2message ": ", company2msg comp]
|
||||
-- msgAdminProblem AdminProblemNewlyUnsupervised{adminProblemCompanyOld=comp, adminProblemCompanyNew=newComp} = return $
|
||||
-- SomeMessages [SomeMessage MsgAdminProblemNewlyUnsupervised, text2message ": ", maybe (text2message "???") company2msg comp, text2message " -> ", company2msg newComp]
|
||||
-- msgAdminProblem AdminProblemUnknown{adminProblemText=err} = return $
|
||||
-- someMessages ["Problem: ", err]
|
||||
@ -28,7 +28,7 @@ import Handler.Utils
|
||||
import Handler.Utils.Avs
|
||||
-- import Handler.Utils.Qualification
|
||||
import Handler.Utils.Users (getUserPrimaryCompany)
|
||||
-- import Handler.Utils.Company (switchAvsUserCompany)
|
||||
import Handler.Utils.Company (switchAvsUserCompany)
|
||||
|
||||
import Database.Esqueleto.Experimental ((:&)(..))
|
||||
import qualified Database.Esqueleto.Legacy as E
|
||||
@ -687,19 +687,6 @@ instance Button UniWorX UserAvsAction where
|
||||
btnClasses UserAvsSwitchCompany = [BCIsButton, BCDefault]
|
||||
|
||||
|
||||
data UserAvsActionData = UserAvsSwitchCompanyData { uaaUser :: CryptoUUIDUser, uaaCompany :: CompanyId }
|
||||
deriving (Eq, Ord, Read, Show, Generic)
|
||||
-- derivePathPiece ''UserAvsActionData (camelToPathPiece' 1) "--"
|
||||
-- instance Button UniWorX UserAvsActionData where
|
||||
-- btnLabel UserAvsSwitchCompanyData{uaaCompany=cmp} = [whamlet|_{MsgUserAvsSwitchCompany} #{tshow cmp}|]
|
||||
|
||||
switchCompanyForm :: CryptoUUIDUser -> CompanyId -> Form UserAvsActionData
|
||||
switchCompanyForm uuid cid html = flip (renderAForm FormStandard) html $ UserAvsSwitchCompanyData
|
||||
<$> apopt hiddenField "" (Just uuid)
|
||||
<*> apopt hiddenField "" (Just cid)
|
||||
<* aopt (buttonField UserAvsSwitchCompany) "" Nothing
|
||||
|
||||
|
||||
getAdminAvsUserR, postAdminAvsUserR :: CryptoUUIDUser -> Handler Html
|
||||
getAdminAvsUserR = postAdminAvsUserR
|
||||
postAdminAvsUserR uuid = do
|
||||
@ -713,68 +700,47 @@ postAdminAvsUserR uuid = do
|
||||
mbContact <- try $ fmap fltrIdContact $ avsQuery $ AvsQueryContact $ Set.singleton $ AvsObjPersonId userAvsPersonId
|
||||
mbStatus <- try $ fmap fltrIdStatus $ avsQuery $ AvsQueryStatus $ Set.singleton userAvsPersonId
|
||||
-- mbStatus <- try $ queryAvsFullStatus userAvsPersonId -- TODO: delete Handler.Utils.Avs.lookupAvsUser if no longer needed -- NOTE: currently needed to provide card firms that are missing in AVS status query responses
|
||||
let compsUsed :: [CI Text] = stripCI <$> mbStatus ^.. _Right . _Wrapped . folded . _avsStatusPersonCardStatus . folded . _avsDataFirm . _Just
|
||||
|
||||
-- runSwitchFrom :: CompanyName -> CompanyId -> Handler Widget
|
||||
-- runSwitchFrom cname cid = do
|
||||
-- ((fres, fraw), fenc) <- runFormPost $ switchCompanyForm uuid cid
|
||||
-- -- formResultModal :: (MonadHandler m, RedirectUrl (HandlerSite m) route) => FormResult a -> route -> (a -> WriterT [Message] m ()) -> m ()
|
||||
-- -- formResultModal fres (AdminAvsUserR uuid) (\UserAvsSwitchCompanyData{..} -> do
|
||||
-- -- problems <- lift . runDB $ do
|
||||
-- -- (usrUp, problems) <- switchAvsUserCompany True False uid uaaCompany
|
||||
-- -- update uid usrUp
|
||||
-- -- mapM_ reportAdminProblem problems
|
||||
-- -- return problems
|
||||
-- -- -- todo tell all problems as well
|
||||
-- -- forM_ problems (\p -> tell . pure =<< messageI Error (text2message $ tshow p)) -- todo: better display of errors
|
||||
-- -- let ok = if null problems then Success else Error
|
||||
-- -- tell . pure =<< messageI ok (MsgUserAvsCompanySwitched cname)
|
||||
-- -- )
|
||||
-- let procRes (UserAvsSwitchCompanyData{..}) = do
|
||||
-- $logInfoS "AVS" ("Switch company result " <> tshow fres)
|
||||
-- problems <- runDB $ do
|
||||
-- (usrUp, problems) <- switchAvsUserCompany True False uid uaaCompany
|
||||
-- update uid usrUp
|
||||
-- mapM_ reportAdminProblem problems
|
||||
-- return problems
|
||||
-- forM_ problems (\p -> do
|
||||
-- $logErrorS "AVS" $ "Switch company problem: " <> tshow p
|
||||
-- addMessage Error (text2Html $ tshow p)) -- todo: better display of errors
|
||||
-- let ok = if null problems then Success else Error
|
||||
-- addMessageI ok (MsgUserAvsCompanySwitched cname)
|
||||
-- formResult fres procRes
|
||||
-- let fwgt = wrapForm fraw def{ formAction = Just $ SomeRoute (AdminAvsUserR uuid), formEncoding = fenc, formSubmit = FormNoSubmit, formAttrs = [ asyncSubmitAttr | isModal ]}
|
||||
-- return fwgt
|
||||
|
||||
-- TODO: make it optional, if there are eligible companies only
|
||||
switchCompForm :: Handler Widget
|
||||
switchCompForm = do
|
||||
let switchAllCompForm :: AForm (HandlerFor UniWorX) (CryptoUUIDUser,CompanyName)
|
||||
switchAllCompForm = (,)
|
||||
<$> areq hiddenField "user-id" (Just uuid)
|
||||
<*> areq (selectFieldList [(ciOriginal c, c) | c <- compsUsed]) "new primary company" Nothing
|
||||
<* aopt (buttonField UserAvsSwitchCompany) "" Nothing
|
||||
((spRes, spWgt), spEnc) <- runFormPost . identifyForm ("switch-primary-company"::Text) $ renderAForm FormStandard switchAllCompForm
|
||||
formResultModal spRes (AdminAvsUserR uuid) (\(_,c) -> do
|
||||
lift $ $logInfoS "AVS" ("Switch company option result " <> tshow spRes)
|
||||
tell . pure $ Message Success [shamlet|TODO #{c} received|] Nothing
|
||||
)
|
||||
return $ wrapForm spWgt
|
||||
def { formAction = Just $ SomeRoute (AdminAvsUserR uuid), formEncoding = spEnc, formSubmit = FormNoSubmit, formAttrs = [ asyncSubmitAttr | isModal ]}
|
||||
|
||||
let compsUsed :: [CompanyName] = stripCI <$> mbStatus ^.. _Right . _Wrapped . folded . _avsStatusPersonCardStatus . folded . _avsDataFirm . _Just
|
||||
compDict <- if 1 >= length compsUsed
|
||||
then return mempty -- switch company only sensible if there is more than one company to choose
|
||||
else do
|
||||
(primName, _compDict) <- runDB $ do
|
||||
else do
|
||||
let switchCompFormHandler :: [(CompanyName,CompanyId)] -> Maybe CompanyId -> Handler Widget
|
||||
switchCompFormHandler availComps _ | 1 >= length availComps = return mempty -- don't offer a form if there is only one company
|
||||
switchCompFormHandler availComps mbPrime = do
|
||||
let switchCompForm :: AForm (HandlerFor UniWorX) (CryptoUUIDUser,CompanyId)
|
||||
switchCompForm = (,)
|
||||
<$> apopt hiddenField "" (Just uuid)
|
||||
<*> areq (selectFieldList [(ciOriginal cn, cid) | (cn, cid) <- availComps]) "new primary company" mbPrime
|
||||
<* aopt (buttonField UserAvsSwitchCompany) "" Nothing
|
||||
switchCompValidate :: FormValidator (CryptoUUIDUser,CompanyId) Handler ()
|
||||
switchCompValidate = do
|
||||
(uuid_rcvd,_) <- State.get
|
||||
guardValidation MsgWrongButtonValue $ uuid_rcvd == uuid
|
||||
((spRes, spWgt), spEnc) <- runFormPost . validateForm switchCompValidate . identifyForm ("switch-primary-company"::Text) $ renderAForm FormStandard switchCompForm
|
||||
formResultModal spRes (AdminAvsUserR uuid) (\(_,cid) -> do
|
||||
lift $ $logInfoS "AVS" ("Switch company option result " <> tshow spRes)
|
||||
problems <- liftHandler . runDB $ do
|
||||
(usrUp, problems) <- switchAvsUserCompany True False uid cid
|
||||
update uid usrUp
|
||||
forM problems $ \p -> reportAdminProblem p >> msgAdminProblem p
|
||||
forM_ problems (\p -> do
|
||||
-- lift $ $logErrorS "AVS" $ "Switch company problem: " <> tshow p -- no instance Show for SomeMessages
|
||||
tell . pure =<< messageI Warning p
|
||||
)
|
||||
let ok = if null problems then Success else Error
|
||||
tell . pure =<< messageI ok (MsgUserAvsCompanySwitched $ unCompanyKey cid)
|
||||
)
|
||||
return $ wrapForm spWgt
|
||||
def { formAction = Just $ SomeRoute (AdminAvsUserR uuid), formEncoding = spEnc, formSubmit = FormNoSubmit, formAttrs = [ asyncSubmitAttr | isModal ]}
|
||||
(availComps, primName, primId) <- runDB $ do
|
||||
mbPrimeUsrComp :: Maybe UserCompany <- getUserPrimaryCompany uid
|
||||
mbPrimeComp :: Maybe Company <- traverseJoin (get . userCompanyCompany) mbPrimeUsrComp
|
||||
let fltrCmps = (CompanyName <-. compsUsed) : maybeEmpty mbPrimeComp (\Company{companyShorthand=pShort} -> [CompanyShorthand !=. pShort])
|
||||
comps :: [Entity Company] <- selectList fltrCmps [Asc CompanyName, Asc CompanyAvsId] -- company name is already unique, but AVS sometimes contains uses whitespace
|
||||
return (companyName <$> mbPrimeComp, Map.fromAscList [(cname,cid) | (Entity{entityKey=cid, entityVal=Company{companyName=cname}}) <- comps])
|
||||
-- let fltrCmps = (CompanyName <-. compsUsed) : maybeEmpty mbPrimeComp (\Company{companyShorthand=pShort} -> [CompanyShorthand !=. pShort])
|
||||
comps :: [Entity Company] <- selectList [CompanyName <-. compsUsed] [Asc CompanyName, Asc CompanyAvsId] -- company name is already unique, but AVS sometimes contains uses whitespace
|
||||
return ([(companyName v, k) | (Entity k v) <- comps], companyName <$> mbPrimeComp, CompanyKey . companyShorthand <$> mbPrimeComp)
|
||||
-- formDict <- Map.traverseWithKey runSwitchFrom compDict
|
||||
swForm <- switchCompForm
|
||||
return (primName, --formDict,
|
||||
swForm)
|
||||
swForm <- switchCompFormHandler availComps primId
|
||||
return (primName, swForm)
|
||||
|
||||
msgWarningTooltip <- messageI Warning MsgMessageWarning
|
||||
let warnBolt = messageTooltip msgWarningTooltip
|
||||
|
||||
@ -161,4 +161,33 @@ reloadKeepGetParams r = liftHandler $ do
|
||||
redirectKeepGetParams :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route (HandlerSite m) -> m a
|
||||
redirectKeepGetParams route = liftHandler $ do
|
||||
getps <- reqGetParams <$> getRequest
|
||||
redirect (route, getps)
|
||||
redirect (route, getps)
|
||||
|
||||
|
||||
adminProblemCell :: IsDBTable m a => AdminProblem -> DBCell m a
|
||||
-- note that adminProblemCompany/adminProblemCompanyOld and adminProblemUser are automatically displayed within their own columns
|
||||
adminProblemCell AdminProblemNewCompany{}
|
||||
= i18nCell MsgAdminProblemNewCompany
|
||||
adminProblemCell AdminProblemSupervisorNewCompany{adminProblemCompanyNew, adminProblemSupervisorReroute}
|
||||
= i18nCell (MsgAdminProblemSupervisorNewCompany adminProblemSupervisorReroute) <> companyIdCell adminProblemCompanyNew
|
||||
adminProblemCell AdminProblemSupervisorLeftCompany{adminProblemSupervisorReroute}
|
||||
= i18nCell (MsgAdminProblemSupervisorLeftCompany adminProblemSupervisorReroute)
|
||||
adminProblemCell AdminProblemNewlyUnsupervised{adminProblemCompanyNew}
|
||||
= i18nCell MsgAdminProblemNewlyUnsupervised <> companyIdCell adminProblemCompanyNew
|
||||
adminProblemCell AdminProblemUnknown{adminProblemText}
|
||||
= textCell $ "Problem: " <> adminProblemText
|
||||
|
||||
company2msg :: CompanyId -> SomeMessage UniWorX
|
||||
company2msg = text2message . ciOriginal . unCompanyKey
|
||||
|
||||
msgAdminProblem :: AdminProblem -> DB (SomeMessages UniWorX)
|
||||
msgAdminProblem AdminProblemNewCompany{adminProblemCompany=comp} = return $
|
||||
SomeMessages [SomeMessage MsgAdminProblemNewCompany, text2message ": ", company2msg comp]
|
||||
msgAdminProblem AdminProblemSupervisorNewCompany{adminProblemCompany=comp, adminProblemCompanyNew=newComp, adminProblemSupervisorReroute=rer} = return $
|
||||
SomeMessages [SomeMessage $ MsgAdminProblemSupervisorNewCompany rer, text2message ": ", company2msg comp, text2message " -> ", company2msg newComp]
|
||||
msgAdminProblem AdminProblemSupervisorLeftCompany{adminProblemCompany=comp, adminProblemSupervisorReroute=rer} = return $
|
||||
SomeMessages [SomeMessage $ MsgAdminProblemSupervisorLeftCompany rer, text2message ": ", company2msg comp]
|
||||
msgAdminProblem AdminProblemNewlyUnsupervised{adminProblemCompanyOld=comp, adminProblemCompanyNew=newComp} = return $
|
||||
SomeMessages [SomeMessage MsgAdminProblemNewlyUnsupervised, text2message ": ", maybe (text2message "???") company2msg comp, text2message " -> ", company2msg newComp]
|
||||
msgAdminProblem AdminProblemUnknown{adminProblemText=err} = return $
|
||||
someMessages ["Problem: ", err]
|
||||
@ -20,8 +20,12 @@ import qualified Database.Esqueleto.PostgreSQL as E
|
||||
|
||||
import Handler.Utils.Users
|
||||
|
||||
-- TODO: use this function in company view Handler.Firm #157
|
||||
|
||||
company2msg :: CompanyId -> SomeMessage UniWorX
|
||||
company2msg = text2message . ciOriginal . unCompanyKey
|
||||
|
||||
|
||||
-- TODO: use this function in company view Handler.Firm #157
|
||||
-- | add all company supervisors for a given users
|
||||
addCompanySupervisors :: (MonadIO m, BackendCompatible SqlBackend backend, PersistQueryWrite backend, PersistUniqueWrite backend)
|
||||
=> Key Company -> Key User -> ReaderT backend m ()
|
||||
|
||||
Loading…
Reference in New Issue
Block a user