fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore(avs): switch prime company

Browse Source
This commit is contained in:
Steffen Jost 2024-05-06 16:33:57 +02:00
parent e2e5cc7bee
commit 6084f92ad7
2 changed files with 58 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

96
src/Handler/Admin/Avs.hs
View File

@ -28,7 +28,7 @@ import Handler.Utils
import Handler.Utils.Avs import Handler.Utils.Avs
-- import Handler.Utils.Qualification -- import Handler.Utils.Qualification
import Handler.Utils.Users (getUserPrimaryCompany) import Handler.Utils.Users (getUserPrimaryCompany)
import Handler.Utils.Company (switchAvsUserCompany) -- import Handler.Utils.Company (switchAvsUserCompany)
import Database.Esqueleto.Experimental ((:&)(..)) import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Legacy as E 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 -- 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 let compsUsed :: [CI Text] = stripCI <$> mbStatus ^.. _Right . _Wrapped . folded . _avsStatusPersonCardStatus . folded . _avsDataFirm . _Just
runSwitchFrom :: CompanyName -> CompanyId -> Handler Widget -- runSwitchFrom :: CompanyName -> CompanyId -> Handler Widget
runSwitchFrom cname cid = do -- runSwitchFrom cname cid = do
((fres, fraw), fenc) <- runFormPost $ switchCompanyForm uuid cid -- ((fres, fraw), fenc) <- runFormPost $ switchCompanyForm uuid cid
-- formResultModal :: (MonadHandler m, RedirectUrl (HandlerSite m) route) => FormResult a -> route -> (a -> WriterT [Message] m ()) -> m () -- -- formResultModal :: (MonadHandler m, RedirectUrl (HandlerSite m) route) => FormResult a -> route -> (a -> WriterT [Message] m ()) -> m ()
-- formResultModal fres (AdminAvsUserR uuid) (\UserAvsSwitchCompanyData{..} -> do -- -- formResultModal fres (AdminAvsUserR uuid) (\UserAvsSwitchCompanyData{..} -> do
-- problems <- lift . runDB $ do -- -- problems <- lift . runDB $ do
-- (usrUp, problems) <- switchAvsUserCompany True False uid uaaCompany -- -- (usrUp, problems) <- switchAvsUserCompany True False uid uaaCompany
-- update uid usrUp -- -- update uid usrUp
-- mapM_ reportAdminProblem problems -- -- mapM_ reportAdminProblem problems
-- return problems -- -- return problems
-- -- todo tell all problems as well -- -- -- todo tell all problems as well
-- forM_ problems (\p -> tell . pure =<< messageI Error (text2message $ tshow p)) -- todo: better display of errors -- -- forM_ problems (\p -> tell . pure =<< messageI Error (text2message $ tshow p)) -- todo: better display of errors
-- let ok = if null problems then Success else Error -- -- let ok = if null problems then Success else Error
-- tell . pure =<< messageI ok (MsgUserAvsCompanySwitched cname) -- -- tell . pure =<< messageI ok (MsgUserAvsCompanySwitched cname)
-- ) -- -- )
let procRes (UserAvsSwitchCompanyData{..}) = do -- let procRes (UserAvsSwitchCompanyData{..}) = do
$logInfoS "AVS" ("Switch company result " <> tshow fres) -- $logInfoS "AVS" ("Switch company result " <> tshow fres)
problems <- runDB $ do -- problems <- runDB $ do
(usrUp, problems) <- switchAvsUserCompany True False uid uaaCompany -- (usrUp, problems) <- switchAvsUserCompany True False uid uaaCompany
update uid usrUp -- update uid usrUp
mapM_ reportAdminProblem problems -- mapM_ reportAdminProblem problems
return problems -- return problems
forM_ problems (\p -> do -- forM_ problems (\p -> do
$logErrorS "AVS" $ "Switch company problem: " <> tshow p -- $logErrorS "AVS" $ "Switch company problem: " <> tshow p
addMessage Error (text2Html $ tshow p)) -- todo: better display of errors -- addMessage Error (text2Html $ tshow p)) -- todo: better display of errors
let ok = if null problems then Success else Error -- let ok = if null problems then Success else Error
addMessageI ok (MsgUserAvsCompanySwitched cname) -- addMessageI ok (MsgUserAvsCompanySwitched cname)
formResult fres procRes -- formResult fres procRes
let fwgt = wrapForm fraw def{ formAction = Just $ SomeRoute (AdminAvsUserR uuid), formEncoding = fenc, formSubmit = FormNoSubmit, formAttrs = [ asyncSubmitAttr | isModal ]} -- let fwgt = wrapForm fraw def{ formAction = Just $ SomeRoute (AdminAvsUserR uuid), formEncoding = fenc, formSubmit = FormNoSubmit, formAttrs = [ asyncSubmitAttr | isModal ]}
return fwgt -- 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 compDict <- if 1 >= length compsUsed
then return mempty -- switch company only sensible if there is more than one company to choose then return mempty -- switch company only sensible if there is more than one company to choose
else do else do
(primName, compDict) <- runDB $ do (primName, _compDict) <- runDB $ do
mbPrimeUsrComp :: Maybe UserCompany <- getUserPrimaryCompany uid mbPrimeUsrComp :: Maybe UserCompany <- getUserPrimaryCompany uid
mbPrimeComp :: Maybe Company <- traverseJoin (get . userCompanyCompany) mbPrimeUsrComp mbPrimeComp :: Maybe Company <- traverseJoin (get . userCompanyCompany) mbPrimeUsrComp
let fltrCmps = (CompanyName <-. compsUsed) : maybeEmpty mbPrimeComp (\Company{companyShorthand=pShort} -> [CompanyShorthand !=. pShort]) 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 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]) return (companyName <$> mbPrimeComp, Map.fromAscList [(cname,cid) | (Entity{entityKey=cid, entityVal=Company{companyName=cname}}) <- comps])
formDict <- Map.traverseWithKey runSwitchFrom compDict -- formDict <- Map.traverseWithKey runSwitchFrom compDict
return (primName, formDict) swForm <- switchCompForm
return (primName, --formDict,
swForm)
msgWarningTooltip <- messageI Warning MsgMessageWarning msgWarningTooltip <- messageI Warning MsgMessageWarning
let warnBolt = messageTooltip msgWarningTooltip let warnBolt = messageTooltip msgWarningTooltip
@ -831,8 +849,9 @@ postAdminAvsUserR uuid = do
_{MsgAvsNoLicenceGuest} _{MsgAvsNoLicenceGuest}
|] |]
mkCardsWgt :: (Maybe CompanyName, Map CompanyName Widget) -> Set AvsDataPersonCard -> Widget -- mkCardsWgt :: (Maybe CompanyName, Map CompanyName Widget, Widget) -> Set AvsDataPersonCard -> Widget
mkCardsWgt (mbPrimName, compDict) crds mkCardsWgt :: (Maybe CompanyName, Widget) -> Set AvsDataPersonCard -> Widget
mkCardsWgt (mbPrimName, swForm) crds
| null crds = [whamlet|_{MsgAvsCardsEmpty}|] | null crds = [whamlet|_{MsgAvsCardsEmpty}|]
| otherwise = do | 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 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 $maybe primName <- mbPrimName
$if (primName == fci) $if (primName == fci)
_{MsgAvsPrimaryCompany} _{MsgAvsPrimaryCompany}
$else <p>
$maybe wgt <- Map.lookup fci compDict ^{swForm}
^{wgt}
|] |]

2
src/Handler/Admin/Test.hs
View File

@ -112,7 +112,7 @@ postAdminTestR = do
let emailWidget' = wrapForm emailWidget def let emailWidget' = wrapForm emailWidget def
{ formAction = Just . SomeRoute $ AdminTestR { formAction = Just . SomeRoute $ AdminTestR
, formEncoding = emailEnctype , formEncoding = emailEnctype
, formAttrs = [("uw-async-form", "")] , formAttrs = [asyncSubmitAttr] -- equivalent to [("uw-async-form", "")]
} }
now <- liftIO getCurrentTime now <- liftIO getCurrentTime