diff --git a/messages/uniworx/categories/user/de-de-formal.msg b/messages/uniworx/categories/user/de-de-formal.msg index 1f6900a20..f2471f4dc 100644 --- a/messages/uniworx/categories/user/de-de-formal.msg +++ b/messages/uniworx/categories/user/de-de-formal.msg @@ -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 diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index ae4dd7aa4..53c5d6116 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -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] \ No newline at end of file diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index fa1ca7837..1a6bdaf19 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -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 diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 4648cf647..8043737de 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -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) \ No newline at end of file + 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] \ No newline at end of file diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs index f20089255..a5d90c0cb 100644 --- a/src/Handler/Utils/Company.hs +++ b/src/Handler/Utils/Company.hs @@ -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 ()