From 6084f92ad7f6f62188cb0a1b319629b9c89469c0 Mon Sep 17 00:00:00 2001 From: Steffen Date: Mon, 6 May 2024 16:33:57 +0200 Subject: [PATCH] chore(avs): switch prime company --- src/Handler/Admin/Avs.hs | 96 +++++++++++++++++++++++---------------- src/Handler/Admin/Test.hs | 2 +- 2 files changed, 58 insertions(+), 40 deletions(-) diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 953c08d5a..fa1ca7837 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 @@ -715,48 +715,66 @@ postAdminAvsUserR uuid = do -- 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 + -- 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 ]} 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 + (primName, _compDict) <- 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]) - formDict <- Map.traverseWithKey runSwitchFrom compDict - return (primName, formDict) + -- formDict <- Map.traverseWithKey runSwitchFrom compDict + swForm <- switchCompForm + return (primName, --formDict, + swForm) msgWarningTooltip <- messageI Warning MsgMessageWarning let warnBolt = messageTooltip msgWarningTooltip @@ -831,8 +849,9 @@ postAdminAvsUserR uuid = do _{MsgAvsNoLicenceGuest} |] - mkCardsWgt :: (Maybe CompanyName, Map CompanyName Widget) -> Set AvsDataPersonCard -> Widget - mkCardsWgt (mbPrimName, compDict) crds + -- mkCardsWgt :: (Maybe CompanyName, Map CompanyName Widget, Widget) -> Set AvsDataPersonCard -> Widget + mkCardsWgt :: (Maybe CompanyName, Widget) -> Set AvsDataPersonCard -> Widget + mkCardsWgt (mbPrimName, swForm) crds | null crds = [whamlet|_{MsgAvsCardsEmpty}|] | otherwise = do let hasCompany = isJust $ Set.foldr ((<|>) . avsDataFirm) Nothing crds -- some if, since a true AVS status query never delivers values for these fields, but queryAvsFullStatus-workaround does @@ -885,9 +904,8 @@ postAdminAvsUserR uuid = do $maybe primName <- mbPrimName $if (primName == fci) _{MsgAvsPrimaryCompany} - $else - $maybe wgt <- Map.lookup fci compDict - ^{wgt} +

+ ^{swForm} |] diff --git a/src/Handler/Admin/Test.hs b/src/Handler/Admin/Test.hs index 50b670d2e..dc235ac3f 100644 --- a/src/Handler/Admin/Test.hs +++ b/src/Handler/Admin/Test.hs @@ -112,7 +112,7 @@ postAdminTestR = do let emailWidget' = wrapForm emailWidget def { formAction = Just . SomeRoute $ AdminTestR , formEncoding = emailEnctype - , formAttrs = [("uw-async-form", "")] + , formAttrs = [asyncSubmitAttr] -- equivalent to [("uw-async-form", "")] } now <- liftIO getCurrentTime