{-# 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 ""