BIN -> MID Routing Strategy
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324
{-# LANGUAGE OverloadedStrings #-}
module Main where
import System.Random (randomRIO)
import qualified Data.Map as M
import Data.Maybe (fromMaybe)
import Data.List (intercalate, sortBy)
import Data.Function (on)
--------------------------------------------------------------------------------
-- Serializable Types
--------------------------------------------------------------------------------
type BIN = Int
data MID
= Shift4
| Rapyd
| Paysafe
| Valitorpay
| Paynetics
deriving (Show, Read, Eq, Ord)
defaultMID :: MID
defaultMID = Shift4
type Probability = Double
type RND = Double
data Gateway
= Maxpay
| Celeris
deriving (Show, Read, Eq, Ord)
data GatewayResponseType
= FraudZipcode
| FraudIP
| Success
| OtherErrors
deriving (Show, Read, Eq, Ord)
data GatewayResponse = GatewayResponse {
gateway :: Gateway,
response :: GatewayResponseType
} deriving (Show, Read, Eq, Ord)
-- Each BIN can map to one or more MIDs, each with a certain probability.
newtype WeightedMIDs = WeightedMIDs [(MID, Probability)] deriving (Show, Read)
-- Smart constructor to ensure WeightedMIDs are always sorted by probability
mkWeightedMIDs :: [(MID, Probability)] -> WeightedMIDs
mkWeightedMIDs mids = WeightedMIDs (sortBy (flip compare `on` snd) mids)
-- A Rule describes:
-- - A list of BINs it applies to
-- - WeightedMIDs that apply for those BINs
-- - If ruleBINs is empty => fallback for all BINs not otherwise matched
-- - If ruleGatewayResponses is empty => fallback for all GatewayResponses not otherwise matched
-- - If ruleMIDs is empty => fallback for all MIDs not otherwise matched
data Rule =
BinRule
{
ruleBINs :: [BIN]
, ruleMIDs :: WeightedMIDs
}
| GatewayResponseRule
{
ruleGatewayResponses :: [GatewayResponse]
, ruleMIDs :: WeightedMIDs
}
deriving (Show, Read)
-- A NamedRule is a Rule with a human-readable name
-- This can be serialized and stored in a database
data NamedRule = NamedRule {
rName :: String,
rRule :: Rule
} deriving (Show, Read)
--------------------------------------------------------------------------------
-- Building Strategy Data
--------------------------------------------------------------------------------
-- A RoutingStrategy corresponds to a Rule
data RoutingStrategy
= BinMapping (M.Map BIN WeightedMIDs)
| GatewayResponseMapping (M.Map GatewayResponse WeightedMIDs)
| Fallback WeightedMIDs
deriving (Show)
-- A NamedRoutingStrategy is a RoutingStrategy with a human-readable name
-- This corresponds to a NamedRule
data NamedRoutingStrategy = NamedRoutingStrategy
{ nsdName :: String
, nsdStrategy :: RoutingStrategy
} deriving (Show)
-- Update the type to represent a list of strategies
newtype NamedRoutingStrategies
= NamedRoutingStrategies [NamedRoutingStrategy]
deriving (Show)
routingStrategiesName :: NamedRoutingStrategies -> String
routingStrategiesName (NamedRoutingStrategies strats) =
let names = map nsdName strats
in intercalate " ⊕ " names
-- If ruleBINs is empty, interpret it as a fallback that applies to all BINs.
buildStrategyFromRule :: NamedRule -> NamedRoutingStrategies
buildStrategyFromRule nRule =
let rule = rRule nRule
nm = rName nRule
in singleStrategy $ case rule of
BinRule bins wMIDs ->
if null bins
then NamedRoutingStrategy nm (Fallback wMIDs)
else NamedRoutingStrategy nm (BinMapping $ M.fromList [(b, wMIDs) | b <- bins])
GatewayResponseRule responses wMIDs ->
if null responses
then NamedRoutingStrategy nm (Fallback wMIDs)
else NamedRoutingStrategy nm (GatewayResponseMapping $ M.fromList [(r, wMIDs) | r <- responses])
where
-- Helper to create single-strategy NamedRoutingStrategies
singleStrategy :: NamedRoutingStrategy -> NamedRoutingStrategies
singleStrategy nsd = NamedRoutingStrategies [nsd]
--------------------------------------------------------------------------------
-- Combining Strategies
--------------------------------------------------------------------------------
-- | Right-biased merge: if a BIN exists in both, second overrides.
-- Also merges fallback in a right-biased way.
-- The resulting name is the concatenation of both strategy names.
combineStrategies
:: NamedRoutingStrategies
-> NamedRoutingStrategies
-> NamedRoutingStrategies
combineStrategies (NamedRoutingStrategies as) (NamedRoutingStrategies bs) =
NamedRoutingStrategies (as ++ bs)
-- Combine an entire list of NamedRoutingStrategy structures into one,
-- using right-biased merges and concatenating names along the way.
combineAllStrategies :: [NamedRoutingStrategies] -> NamedRoutingStrategies
combineAllStrategies = foldr1 combineStrategies
-- | Define an inline infix operator for combineStrategies
infixr 3 <+>
(<+>) :: NamedRoutingStrategies
-> NamedRoutingStrategies
-> NamedRoutingStrategies
(<+>) = combineStrategies
--------------------------------------------------------------------------------
-- Selecting an MID
--------------------------------------------------------------------------------
-- Given WeightedMIDs and a random number, pick exactly one MID.
stochasticRouter :: WeightedMIDs -> RND -> MID
stochasticRouter (WeightedMIDs []) rnd = error ("No MIDs matched the RND " ++ show rnd)
stochasticRouter (WeightedMIDs ((m, p):rest)) rnd
| rnd <= p = m
| otherwise = stochasticRouter (WeightedMIDs rest) (rnd - p)
-- Look up the BIN:
-- - If found in nsdMap, select from that WeightedMIDs.
-- - Else, if nsdFallback exists, select from fallback WeightedMIDs.
-- - Otherwise "DefaultMID"
-- We return the chosen MID, the combined name, and the matched rule name.
-- Update mkRouter to try strategies in reverse order
mkRouter
:: NamedRoutingStrategies
-> RND
-> GatewayResponse
-> BIN
-> (MID, String)
mkRouter (NamedRoutingStrategies strats) rnd gatewayResponse bin =
-- Try strategies in reverse order, first match wins
fromMaybe
(defaultMID, "NoMatchingRule")
(tryStrategies (reverse strats))
where
tryStrategies [] = Nothing
tryStrategies (NamedRoutingStrategy matchedRuleName strat : rest) =
case strat of
GatewayResponseMapping respMap ->
case M.lookup gatewayResponse respMap of
Just wMIDs ->
Just (stochasticRouter wMIDs rnd, matchedRuleName)
Nothing -> tryStrategies rest
BinMapping binMap ->
case M.lookup bin binMap of
Just wMIDs ->
Just (stochasticRouter wMIDs rnd, matchedRuleName)
Nothing -> tryStrategies rest
Fallback wMIDs ->
Just (stochasticRouter wMIDs rnd, matchedRuleName)
--------------------------------------------------------------------------------
-- Example Rules
--------------------------------------------------------------------------------
-- 1) Base rule: empty bins => fallback
baseRule :: NamedRule
baseRule = NamedRule {
rName = "BaseRule",
rRule = BinRule {
ruleBINs = []
, ruleMIDs = mkWeightedMIDs [(Shift4, 0.45), (Rapyd, 0.40), (Paysafe, 0.05)]
}
}
-- 2) ES rule: for specific BINs
esRule :: NamedRule
esRule = NamedRule {
rName = "ESRule",
rRule = BinRule {
ruleBINs = [222222, 333333]
, ruleMIDs = mkWeightedMIDs [(Valitorpay, 0.5), (Paynetics, 0.5)]
}
}
-- 3) ES Valitorpay override: for other BINs
esValitorpayOverrideRule :: NamedRule
esValitorpayOverrideRule = NamedRule {
rName = "ESValitorpayOverrideRule",
rRule = BinRule {
ruleBINs = [527434, 554014, 554002]
, ruleMIDs = mkWeightedMIDs[(Valitorpay, 1.0)]
}
}
-- 4) ES Celeris override: for certain BINs
esCelerisOverrideRule :: NamedRule
esCelerisOverrideRule = NamedRule {
rName = "ESCelerisOverrideRule",
rRule = BinRule {
ruleBINs = [476664, 476663, 432265, 409013]
, ruleMIDs = mkWeightedMIDs [(Shift4, 0.55), (Rapyd, 0.45)]
}
}
-- 5) ES GatewayResponse rule: for certain GatewayResponses
esGatewayResponseRule :: NamedRule
esGatewayResponseRule = NamedRule {
rName = "ESGatewayResponseRule",
rRule = GatewayResponseRule
{
ruleGatewayResponses = [GatewayResponse Maxpay FraudZipcode, GatewayResponse Maxpay FraudIP]
, ruleMIDs = mkWeightedMIDs [(Shift4, 0.45), (Rapyd, 0.40), (Paysafe, 0.05)]
}
}
-- this can be serialized and stored in a databse
esCampaignsRule :: [NamedRule]
esCampaignsRule =
[
baseRule
, esRule
, esValitorpayOverrideRule
, esCelerisOverrideRule
, esGatewayResponseRule
]
--------------------------------------------------------------------------------
-- Demos
--------------------------------------------------------------------------------
-- Manual combination using <+>
-- this cannot be serialized, but it is here to make a point
--
esCampaignsNsdList1 :: NamedRoutingStrategies
esCampaignsNsdList1 =
buildStrategyFromRule baseRule
<+> buildStrategyFromRule esRule
<+> buildStrategyFromRule esValitorpayOverrideRule
<+> buildStrategyFromRule esCelerisOverrideRule
<+> buildStrategyFromRule esGatewayResponseRule
main :: IO ()
main = do
-- Generate a random number
rnd <- randomRIO (0.0, 1.0)
-- let rnd = 0.41483277627233206
let gatewayResponse = GatewayResponse Celeris FraudZipcode
-- Let's test multiple BINs to show how it picks rules
let testBins = [476664, 222222, 999999] -- 999999 isn't in any specific rule
putStrLn "---- (1) Using manual combination esCampaignsNsdList1 ----"
mapM_ (testNsd esCampaignsNsdList1 rnd gatewayResponse) testBins
putStrLn "------------------------------------"
-- (2) Build from [Rule], then combineAllStrategies
let nsdList2 = map buildStrategyFromRule esCampaignsRule
esCampaignsNsdList2 = foldr1 (<+>) nsdList2 -- combineAllStrategies nsdList2
putStrLn "---- (2) Using combineAllStrategies on esCampaignsRule ----"
mapM_ (testNsd esCampaignsNsdList2 rnd gatewayResponse) testBins
putStrLn "------------------------------------"
--------------------------------------------------------------------------------
-- Helper
--------------------------------------------------------------------------------
testNsd
:: NamedRoutingStrategies
-> RND
-> GatewayResponse
-> BIN
-> IO ()
testNsd nsd rnd gatewayResponse bin = do
let router = mkRouter nsd rnd
let (mid, matchedRule) = router gatewayResponse bin
putStrLn $ "BIN: " ++ show bin
putStrLn $ "RND: " ++ show rnd
putStrLn $ "Selected MID: " ++ show mid
putStrLn $ "Matched Rule: " ++ matchedRule
putStrLn $ "Strategy Used: " ++ routingStrategiesName nsd
putStrLn ""
Haskell
INFO