chore(avs): switch prime company
This commit is contained in:
parent
e2e5cc7bee
commit
6084f92ad7
@ -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}
|
||||
<p>
|
||||
^{swForm}
|
||||
|]
|
||||
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user