BIN -> MID  Routing Strategy

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