From b00df768d2a331593decea30d602f1bad71df621 Mon Sep 17 00:00:00 2001 From: yellowbean Date: Sun, 23 Aug 2026 23:52:29 +0800 Subject: [PATCH 01/40] add .gitignore --- .gitignore | 1 + 1 file changed, 1 insertion(+) create mode 100644 .gitignore diff --git a/.gitignore b/.gitignore new file mode 100644 index 00000000..c33954f5 --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +dist-newstyle/ From 391afe927968ed3477fbd354f1a94ffba88e622a Mon Sep 17 00:00:00 2001 From: Samuel Naughton Baldwin Date: Sun, 16 Aug 2026 15:23:48 +0100 Subject: [PATCH 02/40] feat: fix pool-level DefaultByAmt allocation across multiple assets --- Hastructure.cabal | 1 + src/Pool.hs | 35 +++++++++++++++++++++-- test/MainTest.hs | 3 +- test/UT/PoolTest.hs | 70 +++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 105 insertions(+), 4 deletions(-) create mode 100644 test/UT/PoolTest.hs diff --git a/Hastructure.cabal b/Hastructure.cabal index e958482e..86c2ef24 100644 --- a/Hastructure.cabal +++ b/Hastructure.cabal @@ -193,6 +193,7 @@ test-suite Hastructure-test UT.ExpTest UT.InterestRateTest UT.LibTest + UT.PoolTest UT.QueryTest UT.RateHedgeTest UT.StmtTest diff --git a/src/Pool.hs b/src/Pool.hs index 4f65918b..ed6e31da 100644 --- a/src/Pool.hs +++ b/src/Pool.hs @@ -14,7 +14,7 @@ module Pool (Pool(..),aggPool import Lib (Period(..) ,Ts(..),periodRateFromAnnualRate,toDate ,getIntervalDays,zipWith9,mkTs,periodsBetween - ,mkRateTs,daysBetween, ) + ,mkRateTs,daysBetween, prorataFactors) import Control.Parallel.Strategies import qualified Cashflow as CF -- (Cashflow,Amount,Interests,Principals) @@ -206,8 +206,13 @@ runPool (Pool as _ _ asof _ _) Nothing mRates return [ (x, Map.empty) | x <- cf ] -- asset cashflow with credit stress ---- By pool level -runPool (Pool as _ Nothing asof _ _) (Just (A.PoolLevel assumps)) mRates - = sequenceA $ parMap rdeepseq (\x -> projCashflow x asof assumps mRates) as +runPool (Pool as _ Nothing asof _ _) (Just (A.PoolLevel assumps)) mRates = + sequenceA $ parMap rdeepseq + (\(x, assump) -> projCashflow x asof assump mRates) (zip as assetAssumps) + where + assetAssumps = allocateDefaultByAmt balances assumps + balances = getCurrentBal <$> as + ---- By index runPool (Pool as _ Nothing asof _ _) (Just (A.ByIndex idxAssumps)) mRates = let @@ -299,5 +304,29 @@ runPool (Pool as _ Nothing asof _ _) (Just (A.ByObligor obligorRules)) mRates = runPool _a _b _c = Left $ "[Run Pool]: Failed to match" ++ show _a ++ show _b ++ show _c +allocateDefaultByAmt :: [Balance] -> A.AssetPerf -> [A.AssetPerf] +allocateDefaultByAmt + balances + ( A.MortgageAssump + (Just (A.DefaultByAmt (total, rates))) + prepay + recovery + extra + , delinqAssump + , defaultAssump + ) = + [ (A.MortgageAssump + (Just (A.DefaultByAmt (amount, rates))) + prepay + recovery + extra + , delinqAssump + , defaultAssump + ) + | amount <- prorataFactors balances total + ] +allocateDefaultByAmt balances assumps = + replicate (length balances) assumps + $(deriveJSON defaultOptions ''Pool) diff --git a/test/MainTest.hs b/test/MainTest.hs index 21729d67..3b4d2ecc 100644 --- a/test/MainTest.hs +++ b/test/MainTest.hs @@ -20,7 +20,7 @@ import qualified UT.InterestRateTest as IRT import qualified UT.RateHedgeTest as RHT import qualified UT.CeTest as CET import qualified UT.LedgerTest as LeT - +import qualified UT.PoolTest as PT import qualified DealTest.DealTest as DealTest import qualified DealTest.RevolvingTest as RevolvingTest @@ -119,4 +119,5 @@ tests = testGroup "Tests" [AT.mortgageTests ,RHT.capRateTests ,CET.liqTest ,LeT.bookTest + ,PT.poolTest ] diff --git a/test/UT/PoolTest.hs b/test/UT/PoolTest.hs new file mode 100644 index 00000000..8e4a30b5 --- /dev/null +++ b/test/UT/PoolTest.hs @@ -0,0 +1,70 @@ +module UT.PoolTest (poolTest) +where + +import Test.Tasty +import Test.Tasty.HUnit + +import qualified AssetClass.AssetBase as AB +import qualified Assumptions as A +import qualified Cashflow as CF +import qualified Lib as L +import qualified Pool as P + +import InterestRate (RateType (Fix)) +import Types (DayCount (DC_ACT_365F)) + +poolTest :: TestTree +poolTest = + testGroup + "Pool test" + [ testCase "pool DefaultByAmt is allocated proportional to current balance" $ + case P.runPool pool (Just defaultAss) Nothing of + Left err -> assertFailure err + Right proj -> + assertEqual + "a total default of 40 (25% and 75%) across the asets" + [10, 30] + (totalDefaults <$> proj) + ] + where + pool = + P.Pool + { P.assets = [mortgage 100, mortgage 300] + , P.futureCf = Nothing + , P.futureScheduleCf = Nothing + , P.asOfDate = L.toDate "20240101" + , P.issuanceStat = Nothing + , P.extendPeriods = Nothing + } + + defaultAss = + A.PoolLevel + ( A.MortgageAssump + (Just (A.DefaultByAmt (40, [1]))) + Nothing + Nothing + Nothing + , A.DummyDelinqAssump + , A.DummyDefaultAssump + ) + + mortgage balance = + AB.Mortgage + ( AB.MortgageOriginalInfo + balance + (Fix DC_ACT_365F 0.08) + 12 + L.Monthly + (L.toDate "20240101") + AB.Level + Nothing + Nothing + ) + balance + 0.08 + 12 + Nothing + AB.Current + + totalDefaults (CF.CashFlowFrame _ txns, _) = + sum (CF.mflowDefault <$> txns) From 9d87a968e47c054c2d14a98e9a052b6adbb61da7 Mon Sep 17 00:00:00 2001 From: yellowbean Date: Mon, 31 Aug 2026 15:59:20 +0800 Subject: [PATCH 03/40] fix: fee double-count in FeeFlowByPoolPeriod/FeeFlowByBondPeriod --- src/Deal/DealAction.hs | 4 ++-- test/MainTest.hs | 1 + test/UT/ExpTest.hs | 28 +++++++++++++++++++++++++++- 3 files changed, 30 insertions(+), 3 deletions(-) diff --git a/src/Deal/DealAction.hs b/src/Deal/DealAction.hs index 2be13e8c..13b4e459 100644 --- a/src/Deal/DealAction.hs +++ b/src/Deal/DealAction.hs @@ -208,7 +208,7 @@ calcDueFee t rc calcDay f@(F.Fee fn (F.FeeFlowByPoolPeriod pc) fs fd fdday fa lp currentPoolPeriod <- queryCompound t rc calcDay (DealStatInt PoolCollectedPeriod) feePaidAmt <- queryCompound t rc calcDay (FeePaidAmt [fn]) let dueAmt = fromMaybe 0 $ getValFromPerCurve pc Past Inc (succ (floor (fromRational currentPoolPeriod))) - return f {F.feeDue = max 0 (dueAmt - fromRational feePaidAmt) + fd, F.feeDueDate = Just calcDay} + return f {F.feeDue = max 0 (dueAmt - fromRational feePaidAmt), F.feeDueDate = Just calcDay} -- ^ fee based on a bond period number calcDueFee t rc calcDay f@(F.Fee fn (F.FeeFlowByBondPeriod pc) fs fd fdday fa lpd stmt) @@ -216,7 +216,7 @@ calcDueFee t rc calcDay f@(F.Fee fn (F.FeeFlowByBondPeriod pc) fs fd fdday fa lp currentBondPeriod <- queryCompound t rc calcDay (DealStatInt BondPaidPeriod) feePaidAmt <- queryCompound t rc calcDay (FeePaidAmt [fn]) let dueAmt = fromMaybe 0 $ getValFromPerCurve pc Past Inc (succ (floor (fromRational currentBondPeriod))) - return f {F.feeDue = max 0 (dueAmt - fromRational feePaidAmt) + fd, F.feeDueDate = Just calcDay} + return f {F.feeDue = max 0 (dueAmt - fromRational feePaidAmt), F.feeDueDate = Just calcDay} disableLiqProvider :: Ast.Asset a => TestDeal a -> Date -> CE.LiqFacility -> CE.LiqFacility diff --git a/test/MainTest.hs b/test/MainTest.hs index 3b4d2ecc..db8a5f3e 100644 --- a/test/MainTest.hs +++ b/test/MainTest.hs @@ -74,6 +74,7 @@ tests = testGroup "Tests" [AT.mortgageTests ,LT.tsOperationTests ,ET.expTests ,ET.expPayTest + ,ET.expFlowByPeriodTest ,DT.queryTests ,DT.triggerTests ,DT.dateTests diff --git a/test/UT/ExpTest.hs b/test/UT/ExpTest.hs index c910df47..75aab64d 100644 --- a/test/UT/ExpTest.hs +++ b/test/UT/ExpTest.hs @@ -1,10 +1,11 @@ -module UT.ExpTest(expTests,expPayTest) +module UT.ExpTest(expTests,expPayTest,expFlowByPeriodTest) where import Test.Tasty import Test.Tasty.HUnit import qualified Data.Time as T +import qualified Data.Map as Map import qualified Lib as L import qualified Asset as P import qualified Deal as D @@ -64,6 +65,31 @@ expTests = testGroup "Expense Tests" ] +expFlowByPeriodTest = + let + pc = CurrentVal [PerPoint 1 10.0, PerPoint 2 20.0, PerPoint 3 30.0, PerPoint 4 40.0] + ctx = RunContext {} + calcDay = L.toDate "20220401" + partialPayStmt = Just (S.Statement (DL.fromList [ExpTxn (L.toDate "20220201") 35.0 10.0 0.0 (PayFee "feePool")])) + fullPayStmt = Just (S.Statement (DL.fromList [ExpTxn (L.toDate "20220201") 0.0 40.0 0.0 (PayFee "feePool")])) + poolFee = Fee "feePool" (FeeFlowByPoolPeriod pc) (L.toDate "20220101") 5 Nothing 0 Nothing partialPayStmt + poolFeeFull = Fee "feePool" (FeeFlowByPoolPeriod pc) (L.toDate "20220101") 5 Nothing 0 Nothing fullPayStmt + bondFee = Fee "feeBond" (FeeFlowByBondPeriod pc) (L.toDate "20220101") 5 Nothing 0 Nothing partialPayStmt + dealWithFee f = DT.td2 { fees = Map.fromList [(feeName f, f)] + , stats = (Map.empty, Map.empty, Map.empty, Map.fromList [(PoolCollectedPeriod, 3), (BondPaidPeriod, 3)]) } + in + testGroup "Fee flow by period tests" + [ testCase "pool period fee: due = cumulative due - paid, no double count" $ + assertEqual "" (Right 30.0) + (feeDue <$> DA.calcDueFee (dealWithFee poolFee) ctx calcDay poolFee) + , testCase "pool period fee: fully paid yields zero due" $ + assertEqual "" (Right 0.0) + (feeDue <$> DA.calcDueFee (dealWithFee poolFeeFull) ctx calcDay poolFeeFull) + , testCase "bond period fee: due = cumulative due - paid, no double count" $ + assertEqual "" (Right 30.0) + (feeDue <$> DA.calcDueFee (dealWithFee bondFee) ctx calcDay bondFee) + ] + expPayTest = let f1 = Fee "FeeName1" (FixFee 100) (L.toDate "20220101") 100 Nothing 0 Nothing Nothing From 639b85ffc8c5869ae4f69a9983a2fa72a1c5a9b4 Mon Sep 17 00:00:00 2001 From: yellowbean Date: Tue, 1 Sep 2026 10:45:41 +0800 Subject: [PATCH 04/40] Revert "fix: fee double-count in FeeFlowByPoolPeriod/FeeFlowByBondPeriod" This reverts commit 9d87a968e47c054c2d14a98e9a052b6adbb61da7. --- src/Deal/DealAction.hs | 4 ++-- test/MainTest.hs | 1 - test/UT/ExpTest.hs | 28 +--------------------------- 3 files changed, 3 insertions(+), 30 deletions(-) diff --git a/src/Deal/DealAction.hs b/src/Deal/DealAction.hs index 13b4e459..2be13e8c 100644 --- a/src/Deal/DealAction.hs +++ b/src/Deal/DealAction.hs @@ -208,7 +208,7 @@ calcDueFee t rc calcDay f@(F.Fee fn (F.FeeFlowByPoolPeriod pc) fs fd fdday fa lp currentPoolPeriod <- queryCompound t rc calcDay (DealStatInt PoolCollectedPeriod) feePaidAmt <- queryCompound t rc calcDay (FeePaidAmt [fn]) let dueAmt = fromMaybe 0 $ getValFromPerCurve pc Past Inc (succ (floor (fromRational currentPoolPeriod))) - return f {F.feeDue = max 0 (dueAmt - fromRational feePaidAmt), F.feeDueDate = Just calcDay} + return f {F.feeDue = max 0 (dueAmt - fromRational feePaidAmt) + fd, F.feeDueDate = Just calcDay} -- ^ fee based on a bond period number calcDueFee t rc calcDay f@(F.Fee fn (F.FeeFlowByBondPeriod pc) fs fd fdday fa lpd stmt) @@ -216,7 +216,7 @@ calcDueFee t rc calcDay f@(F.Fee fn (F.FeeFlowByBondPeriod pc) fs fd fdday fa lp currentBondPeriod <- queryCompound t rc calcDay (DealStatInt BondPaidPeriod) feePaidAmt <- queryCompound t rc calcDay (FeePaidAmt [fn]) let dueAmt = fromMaybe 0 $ getValFromPerCurve pc Past Inc (succ (floor (fromRational currentBondPeriod))) - return f {F.feeDue = max 0 (dueAmt - fromRational feePaidAmt), F.feeDueDate = Just calcDay} + return f {F.feeDue = max 0 (dueAmt - fromRational feePaidAmt) + fd, F.feeDueDate = Just calcDay} disableLiqProvider :: Ast.Asset a => TestDeal a -> Date -> CE.LiqFacility -> CE.LiqFacility diff --git a/test/MainTest.hs b/test/MainTest.hs index db8a5f3e..3b4d2ecc 100644 --- a/test/MainTest.hs +++ b/test/MainTest.hs @@ -74,7 +74,6 @@ tests = testGroup "Tests" [AT.mortgageTests ,LT.tsOperationTests ,ET.expTests ,ET.expPayTest - ,ET.expFlowByPeriodTest ,DT.queryTests ,DT.triggerTests ,DT.dateTests diff --git a/test/UT/ExpTest.hs b/test/UT/ExpTest.hs index 75aab64d..c910df47 100644 --- a/test/UT/ExpTest.hs +++ b/test/UT/ExpTest.hs @@ -1,11 +1,10 @@ -module UT.ExpTest(expTests,expPayTest,expFlowByPeriodTest) +module UT.ExpTest(expTests,expPayTest) where import Test.Tasty import Test.Tasty.HUnit import qualified Data.Time as T -import qualified Data.Map as Map import qualified Lib as L import qualified Asset as P import qualified Deal as D @@ -65,31 +64,6 @@ expTests = testGroup "Expense Tests" ] -expFlowByPeriodTest = - let - pc = CurrentVal [PerPoint 1 10.0, PerPoint 2 20.0, PerPoint 3 30.0, PerPoint 4 40.0] - ctx = RunContext {} - calcDay = L.toDate "20220401" - partialPayStmt = Just (S.Statement (DL.fromList [ExpTxn (L.toDate "20220201") 35.0 10.0 0.0 (PayFee "feePool")])) - fullPayStmt = Just (S.Statement (DL.fromList [ExpTxn (L.toDate "20220201") 0.0 40.0 0.0 (PayFee "feePool")])) - poolFee = Fee "feePool" (FeeFlowByPoolPeriod pc) (L.toDate "20220101") 5 Nothing 0 Nothing partialPayStmt - poolFeeFull = Fee "feePool" (FeeFlowByPoolPeriod pc) (L.toDate "20220101") 5 Nothing 0 Nothing fullPayStmt - bondFee = Fee "feeBond" (FeeFlowByBondPeriod pc) (L.toDate "20220101") 5 Nothing 0 Nothing partialPayStmt - dealWithFee f = DT.td2 { fees = Map.fromList [(feeName f, f)] - , stats = (Map.empty, Map.empty, Map.empty, Map.fromList [(PoolCollectedPeriod, 3), (BondPaidPeriod, 3)]) } - in - testGroup "Fee flow by period tests" - [ testCase "pool period fee: due = cumulative due - paid, no double count" $ - assertEqual "" (Right 30.0) - (feeDue <$> DA.calcDueFee (dealWithFee poolFee) ctx calcDay poolFee) - , testCase "pool period fee: fully paid yields zero due" $ - assertEqual "" (Right 0.0) - (feeDue <$> DA.calcDueFee (dealWithFee poolFeeFull) ctx calcDay poolFeeFull) - , testCase "bond period fee: due = cumulative due - paid, no double count" $ - assertEqual "" (Right 30.0) - (feeDue <$> DA.calcDueFee (dealWithFee bondFee) ctx calcDay bondFee) - ] - expPayTest = let f1 = Fee "FeeName1" (FixFee 100) (L.toDate "20220101") 100 Nothing 0 Nothing Nothing From 0c3bfcddf8c0788b62fca39f6cb2283a01249b35 Mon Sep 17 00:00:00 2001 From: yellowbean Date: Sun, 27 Sep 2026 01:19:15 +0800 Subject: [PATCH 05/40] fix prorata calc & enable apply default by amount to scheduleMortgage --- src/AssetClass/Mortgage.hs | 4 ++++ src/Lib.hs | 37 ++++++++++++++--------------- test/UT/LibTest.hs | 26 +++++++++++++++++++++ test/UT/PoolTest.hs | 48 +++++++++++++++++++++++++++++++++++++- 4 files changed, 94 insertions(+), 21 deletions(-) diff --git a/src/AssetClass/Mortgage.hs b/src/AssetClass/Mortgage.hs index 008c503b..08684968 100644 --- a/src/AssetClass/Mortgage.hs +++ b/src/AssetClass/Mortgage.hs @@ -325,6 +325,10 @@ instance Ast.Asset Mortgage where getCurrentBal (Mortgage _ _bal _ _ _ _) = _bal getCurrentBal (AdjustRateMortgage _ _ _bal _ _ _ _) = _bal + getCurrentBal (ScheduleMortgageFlow _ flows _) = + case flows of + [] -> 0 + (f:_) -> CF.mflowBegBalance f getOriginBal (Mortgage (MortgageOriginalInfo _bal _ _ _ _ _ _ _) _ _ _ _ _ ) = _bal getOriginBal (AdjustRateMortgage (MortgageOriginalInfo _bal _ _ _ _ _ _ _) _ _ _ _ _ _ ) = _bal diff --git a/src/Lib.hs b/src/Lib.hs index 7b36a309..ed23ba27 100644 --- a/src/Lib.hs +++ b/src/Lib.hs @@ -20,6 +20,7 @@ module Lib import qualified Data.Time as T import qualified Data.Time.Format as TF import Data.List +import Data.Ord (Down) -- import qualified Data.Scientific as SCI import qualified Data.Map as M import Language.Haskell.TH @@ -30,9 +31,6 @@ import Data.Aeson hiding (json) import Data.Fixed (Fixed(..), HasResolution,Centi, resolution) import Data.Ratio import Types -import Control.Lens -import Data.List.Lens -import Control.Lens.TH import Data.Decimal import Debug.Trace debug = flip trace @@ -62,24 +60,23 @@ getIntervalFactors ds = (\x -> toRational x / 365) <$> getIntervalDays ds -- `de centiToDecimal :: Centi -> Decimal centiToDecimal c = Decimal 2 (round c * 100) --- | +-- | Allocate amt across balances pro-rata using the largest remainder +-- method: every allocation is non-negative and allocations sum exactly to +-- min (sum of balances) amt (to the cent). Residual cents go to the elements +-- with the largest fractional remainders, ties broken by index order. prorataFactors :: [Balance] -> Balance -> [Balance] -prorataFactors bals amt = - let - s = toRational $ sum bals - amtToPay = toRational $ min s (toRational amt) - in - case s of - 0.0 -> replicate (length bals) 0.0 - _ -> let - weights = map (\x -> toRational x / s) bals - outPut = (\y -> fromRational (y * amtToPay)) <$> weights - eps = amt - sum outPut - in - if eps == 0.00 then - outPut - else - over (ix 0) (+ eps) outPut +prorataFactors bals amt + | totalCents <= 0 = replicate (length bals) 0 + | otherwise = map (toEnum . fromInteger) $ zipWith (+) baseAdds extraCents + where + centList = toInteger . fromEnum <$> bals + totalCents = sum centList + payCents = max 0 $ min totalCents (toInteger $ fromEnum amt) + baseAdds = [ b * payCents `div` totalCents | b <- centList ] + residual = payCents - sum baseAdds + order = sortOn (Down . snd) $ zip [0..] [ b * payCents `mod` totalCents | b <- centList ] + extraIdx = fst <$> take (fromInteger residual) order + extraCents = [ if i `elem` extraIdx then 1 else 0 | i <- [0 .. length bals - 1] ] -- diff --git a/test/UT/LibTest.hs b/test/UT/LibTest.hs index 39d9ecc8..b10fe19f 100644 --- a/test/UT/LibTest.hs +++ b/test/UT/LibTest.hs @@ -134,6 +134,32 @@ prorataTests = testGroup "prorata Test" assertEqual "" [20,40,0] (prorataFactors bals2 60) + , + let + bals3 = [100,100,100] + in + testCase "residual goes to first on tie" $ + assertEqual "" + [13.34,13.33,13.33] + (prorataFactors bals3 40) + , + let + bals4 = replicate 12 0.01 + alloc4 = prorataFactors bals4 0.10 + in + testCase "many small bals has no negative allocation" $ do + assertBool "all allocations non-negative" (all (>= 0) alloc4) + assertEqual "allocations sum to requested amount" 0.10 (sum alloc4) + , + testCase "amt greater than total balance is capped" $ + assertEqual "" + [100,200] + (prorataFactors [100,200] 500) + , + testCase "zero total balance gives zeros" $ + assertEqual "" + [0,0] + (prorataFactors [0,0] 40) ] tsOperationTests = diff --git a/test/UT/PoolTest.hs b/test/UT/PoolTest.hs index 8e4a30b5..22ca8c58 100644 --- a/test/UT/PoolTest.hs +++ b/test/UT/PoolTest.hs @@ -11,7 +11,7 @@ import qualified Lib as L import qualified Pool as P import InterestRate (RateType (Fix)) -import Types (DayCount (DC_ACT_365F)) +import Types (DayCount (DC_ACT_365F), DatePattern (MonthEnd)) poolTest :: TestTree poolTest = @@ -25,6 +25,25 @@ poolTest = "a total default of 40 (25% and 75%) across the asets" [10, 30] (totalDefaults <$> proj) + , testCase "pool DefaultByAmt with many small balances allocates no negative amounts" $ + case P.runPool smallPool (Just smallDefaultAss) Nothing of + Left err -> assertFailure err + Right proj -> + let defaults = totalDefaults <$> proj + in do + assertBool "no negative default allocations" (all (>= 0) defaults) + assertEqual + "a total default of 0.10 across 12 assets of 0.01 balance" + (replicate 10 0.01 ++ replicate 2 0) + defaults + , testCase "pool DefaultByAmt with ScheduleMortgageFlow assets" $ + case P.runPool schedulePool (Just defaultAss) Nothing of + Left err -> assertFailure err + Right proj -> + assertEqual + "a total default of 40 (25% and 75%) across the schedule assets" + [10, 30] + (totalDefaults <$> proj) ] where pool = @@ -37,6 +56,14 @@ poolTest = , P.extendPeriods = Nothing } + smallPool = pool {P.assets = replicate 12 (mortgage 0.01)} + + schedulePool = + pool + { P.assets = [scheduleMortgage 100, scheduleMortgage 300] + , P.asOfDate = L.toDate "20240101" + } + defaultAss = A.PoolLevel ( A.MortgageAssump @@ -48,6 +75,17 @@ poolTest = , A.DummyDefaultAssump ) + smallDefaultAss = + A.PoolLevel + ( A.MortgageAssump + (Just (A.DefaultByAmt (0.10, [1]))) + Nothing + Nothing + Nothing + , A.DummyDelinqAssump + , A.DummyDefaultAssump + ) + mortgage balance = AB.Mortgage ( AB.MortgageOriginalInfo @@ -66,5 +104,13 @@ poolTest = Nothing AB.Current + scheduleMortgage balance = + AB.ScheduleMortgageFlow + (L.toDate "20240101") + [ CF.MortgageFlow (L.toDate d) balance 0 0 0 0 0 0 0.08 Nothing Nothing Nothing + | d <- ["20240101", "20240201", "20240301"] + ] + MonthEnd + totalDefaults (CF.CashFlowFrame _ txns, _) = sum (CF.mflowDefault <$> txns) From 023a2af0178c9536911a6431962784216d51624a Mon Sep 17 00:00:00 2001 From: yellowbean Date: Sun, 27 Sep 2026 02:26:17 +0800 Subject: [PATCH 06/40] fix: error when pool DefaultByAmt exceeds total current balance runPool now returns a Left from allocateDefaultByAmt when the pool-level DefaultByAmt total is greater than the sum of current balances, instead of silently dropping the excess. Also fixes the Data.Ord Down/Direction name clash in prorataFactors that broke compilation. --- src/Lib.hs | 3 +-- src/Pool.hs | 37 ++++++++++++++++++++++--------------- test/UT/PoolTest.hs | 41 +++++++++++++++++++++++++++++++++++++++++ 3 files changed, 64 insertions(+), 17 deletions(-) diff --git a/src/Lib.hs b/src/Lib.hs index ed23ba27..2f06dce0 100644 --- a/src/Lib.hs +++ b/src/Lib.hs @@ -20,7 +20,6 @@ module Lib import qualified Data.Time as T import qualified Data.Time.Format as TF import Data.List -import Data.Ord (Down) -- import qualified Data.Scientific as SCI import qualified Data.Map as M import Language.Haskell.TH @@ -74,7 +73,7 @@ prorataFactors bals amt payCents = max 0 $ min totalCents (toInteger $ fromEnum amt) baseAdds = [ b * payCents `div` totalCents | b <- centList ] residual = payCents - sum baseAdds - order = sortOn (Down . snd) $ zip [0..] [ b * payCents `mod` totalCents | b <- centList ] + order = sortOn (negate . snd) $ zip [0..] [ b * payCents `mod` totalCents | b <- centList ] extraIdx = fst <$> take (fromInteger residual) order extraCents = [ if i `elem` extraIdx then 1 else 0 | i <- [0 .. length bals - 1] ] diff --git a/src/Pool.hs b/src/Pool.hs index ed6e31da..47ef190c 100644 --- a/src/Pool.hs +++ b/src/Pool.hs @@ -206,11 +206,11 @@ runPool (Pool as _ _ asof _ _) Nothing mRates return [ (x, Map.empty) | x <- cf ] -- asset cashflow with credit stress ---- By pool level -runPool (Pool as _ Nothing asof _ _) (Just (A.PoolLevel assumps)) mRates = +runPool (Pool as _ Nothing asof _ _) (Just (A.PoolLevel assumps)) mRates = do + assetAssumps <- allocateDefaultByAmt balances assumps sequenceA $ parMap rdeepseq (\(x, assump) -> projCashflow x asof assump mRates) (zip as assetAssumps) where - assetAssumps = allocateDefaultByAmt balances assumps balances = getCurrentBal <$> as ---- By index @@ -304,7 +304,7 @@ runPool (Pool as _ Nothing asof _ _) (Just (A.ByObligor obligorRules)) mRates = runPool _a _b _c = Left $ "[Run Pool]: Failed to match" ++ show _a ++ show _b ++ show _c -allocateDefaultByAmt :: [Balance] -> A.AssetPerf -> [A.AssetPerf] +allocateDefaultByAmt :: [Balance] -> A.AssetPerf -> Either ErrorRep [A.AssetPerf] allocateDefaultByAmt balances ( A.MortgageAssump @@ -314,19 +314,26 @@ allocateDefaultByAmt extra , delinqAssump , defaultAssump - ) = - [ (A.MortgageAssump - (Just (A.DefaultByAmt (amount, rates))) - prepay - recovery - extra - , delinqAssump - , defaultAssump - ) - | amount <- prorataFactors balances total - ] + ) + | total > sumBalances = + Left $ "[Run Pool]: DefaultByAmt total " ++ show total + ++ " exceeds total current balance " ++ show sumBalances + | otherwise = + Right + [ (A.MortgageAssump + (Just (A.DefaultByAmt (amount, rates))) + prepay + recovery + extra + , delinqAssump + , defaultAssump + ) + | amount <- prorataFactors balances total + ] + where + sumBalances = sum balances allocateDefaultByAmt balances assumps = - replicate (length balances) assumps + Right (replicate (length balances) assumps) $(deriveJSON defaultOptions ''Pool) diff --git a/test/UT/PoolTest.hs b/test/UT/PoolTest.hs index 22ca8c58..7f927c61 100644 --- a/test/UT/PoolTest.hs +++ b/test/UT/PoolTest.hs @@ -4,6 +4,8 @@ where import Test.Tasty import Test.Tasty.HUnit +import Data.List (isInfixOf) + import qualified AssetClass.AssetBase as AB import qualified Assumptions as A import qualified Cashflow as CF @@ -44,6 +46,23 @@ poolTest = "a total default of 40 (25% and 75%) across the schedule assets" [10, 30] (totalDefaults <$> proj) + , testCase "pool DefaultByAmt greater than total balance fails with Left" $ + case P.runPool pool (Just overDefaultAss) Nothing of + Left err -> + assertBool + ("error should mention the pool total: " ++ err) + ("exceeds total current balance" `isInfixOf` err) + Right _ -> + assertFailure + "expected Left when DefaultByAmt total exceeds total current balance" + , testCase "pool DefaultByAmt equal to total balance is allowed" $ + case P.runPool pool (Just exactDefaultAss) Nothing of + Left err -> assertFailure err + Right proj -> + assertEqual + "each asset defaults its full current balance" + [100, 300] + (totalDefaults <$> proj) ] where pool = @@ -86,6 +105,28 @@ poolTest = , A.DummyDefaultAssump ) + overDefaultAss = + A.PoolLevel + ( A.MortgageAssump + (Just (A.DefaultByAmt (500, [1]))) + Nothing + Nothing + Nothing + , A.DummyDelinqAssump + , A.DummyDefaultAssump + ) + + exactDefaultAss = + A.PoolLevel + ( A.MortgageAssump + (Just (A.DefaultByAmt (400, [1]))) + Nothing + Nothing + Nothing + , A.DummyDelinqAssump + , A.DummyDefaultAssump + ) + mortgage balance = AB.Mortgage ( AB.MortgageOriginalInfo From 52b58bfd0d5871780117e430be04671f2ffaca5a Mon Sep 17 00:00:00 2001 From: yellowbean Date: Sun, 27 Sep 2026 22:22:16 +0800 Subject: [PATCH 07/40] expose PrepaymentABS (only for monthly) --- src/Asset.hs | 24 +++++++++++++++++++++++- src/Assumptions.hs | 2 ++ src/Lib.hs | 18 ++++++++---------- src/Pool.hs | 2 +- test/MainTest.hs | 1 + test/UT/AssetTest.hs | 30 +++++++++++++++++++++++++++++- 6 files changed, 64 insertions(+), 13 deletions(-) diff --git a/src/Asset.hs b/src/Asset.hs index cfcca12b..a532eb3b 100644 --- a/src/Asset.hs +++ b/src/Asset.hs @@ -19,7 +19,7 @@ import Text.Read (readMaybe) import Lib (Period(..) ,Ts(..),periodRateFromAnnualRate,toDate - ,getIntervalDays,zipWith9,mkTs,periodsBetween + ,getIntervalDays,zipWith9,mkTs,monthsBetween ,mkRateTs,daysBetween, getIntervalFactors) import qualified Cashflow as CF -- (Cashflow,Amount,Interests,Principals) @@ -174,6 +174,8 @@ cpr2smm r = toRational $ 1 - (1 - fromRational r :: Double) ** (1/12) normalPerfVector :: [Rate] -> [Rate] normalPerfVector = floorWith 0.0 . capWith 1.0 + +-- ^ Given a prerpayment assumption , convert it to based prepayment rate buildPrepayRates :: Asset b => b -> [Date] -> Maybe A.AssetPrepayAssumption -> Either ErrorRep [Rate] buildPrepayRates _ ds Nothing = return $ replicate ((pred . length) ds) 0.0 buildPrepayRates a ds (Just (A.PrepaymentConstant r)) @@ -184,21 +186,40 @@ buildPrepayRates a ds (Just (A.PrepaymentCPR r)) | r < 0 || r > 1.0 = Left $ "buildPrepayRates: prepayment CPR rate should be between 0 and 1, got " ++ show r | otherwise = return $ Util.toPeriodRateByInterval r <$> getIntervalDays ds + +-- TODO: can be generlized to irregular payments +buildPrepayRates a ds (Just (A.PrepaymentABS r)) + | r < 0 || r > 1.0 = Left $ "buildPrepayRates: prepayment ABS rate should be between 0 and 1, got " ++ show r + | otherwise + = let + originDate = getOriginDate a + pojectedMonthAges = (monthsBetween originDate) <$> ds + smm m = r / (1 - r * fromIntegral (pred m)) + smmVector = smm <$> pojectedMonthAges + in + case period (getOriginInfo a) of + Monthly -> return smmVector + _ -> Left $ "prepayment ABS is only supported for monthly payment but got "++ show (period (getOriginInfo a)) + -- buildPrepayRates a ds (Just (A.PrepaymentVec smmVector)) + buildPrepayRates a ds (Just (A.PrepaymentVec vs)) | any (> 1.0) vs || any (< 0.0) vs = Left $ "buildPrepayRates: prepayment vector should be between 0 and 1, got " ++ show vs | otherwise = return $ zipWith Util.toPeriodRateByInterval (paddingDefault 0.0 vs (pred (length ds))) (getIntervalDays ds) + buildPrepayRates a ds (Just (A.PrepaymentVecPadding vs)) | any (> 1.0) vs || any (< 0.0) vs = Left $ "buildPrepayRates: prepayment vector should be between 0 and 1, got " ++ show vs | otherwise = return $ zipWith Util.toPeriodRateByInterval (paddingDefault (last vs) vs (pred (length ds))) (getIntervalDays ds) + buildPrepayRates a ds (Just (A.PrepayStressByTs ts x)) | any (< 0.0) (getTsVals ts) = Left $ "buildPrepayRates: prepayment vector by ts should be non-negative, got " ++ show (getTsVals ts) | otherwise = do rs <- buildPrepayRates a ds (Just x) return $ getTsVals $ multiplyTs Exc (zipTs (tail ds) rs) ts + buildPrepayRates a ds (Just (A.PrepaymentPSA r)) | r < 0 = Left $ "buildPrepayRates: PSA rate should be non-negative, got " ++ show r | otherwise = let @@ -210,6 +231,7 @@ buildPrepayRates a ds (Just (A.PrepaymentPSA r)) case period (getOriginInfo a) of Monthly -> return $ cpr2smm <$> vectorUsed _ -> Left $ "PSA is only supported for monthly payment but got "++ show (period (getOriginInfo a)) + buildPrepayRates a ds (Just (A.PrepaymentByTerm rs)) | any (< 0.0) (concat rs) = Left $ "buildPrepayRates: prepayment by term vector should be non-negative, got " ++ show rs | any (> 1.0) (concat rs) = Left $ "buildPrepayRates: prepayment by term vector should be between 0 and 1, got " ++ show rs diff --git a/src/Assumptions.hs b/src/Assumptions.hs index c46fa122..59372c7e 100644 --- a/src/Assumptions.hs +++ b/src/Assumptions.hs @@ -178,6 +178,7 @@ stressDefaultAssump x (DefaultByTerm rss) = DefaultByTerm $ ((capWith 1.0) <$> ( stressPrepaymentAssump :: Rate -> AssetPrepayAssumption -> AssetPrepayAssumption stressPrepaymentAssump x (PrepaymentConstant r) = PrepaymentConstant $ min 1.0 (r*x) stressPrepaymentAssump x (PrepaymentCPR r) = PrepaymentCPR $ min 1.0 (r*x) +stressPrepaymentAssump x (PrepaymentABS r) = PrepaymentABS $ min 1.0 (r*x) stressPrepaymentAssump x (PrepaymentVec rs) = PrepaymentVec $ capWith 1.0 ((x*) <$> rs) stressPrepaymentAssump x (PrepaymentVecPadding rs) = PrepaymentVecPadding $ capWith 1.0 ((x*) <$> rs) stressPrepaymentAssump x (PrepayByAmt (b,rs)) = PrepayByAmt (max (mulBR b x) 0, rs) @@ -188,6 +189,7 @@ stressPrepaymentAssump x (PrepaymentByTerm rss) = PrepaymentByTerm $ (capWith 1. data AssetPrepayAssumption = PrepaymentConstant Rate | PrepaymentCPR Rate + | PrepaymentABS Rate | PrepaymentVec [Rate] | PrepaymentVecPadding [Rate] | PrepayByAmt (Balance,[Rate]) diff --git a/src/Lib.hs b/src/Lib.hs index 2f06dce0..6534ccb2 100644 --- a/src/Lib.hs +++ b/src/Lib.hs @@ -7,7 +7,7 @@ module Lib ,StartDate,EndDate,daysBetween,daysBetweenI ,Spread,Date ,paySeqLiabilities,prorataFactors - ,afterNPeriod,Ts(..),periodsBetween + ,afterNPeriod,Ts(..),monthsBetween ,periodRateFromAnnualRate ,Floor,Cap,TsPoint(..) ,toDate,toDates,genDates,nextDate @@ -113,15 +113,13 @@ afterNPeriod d i p = SemiAnnually -> 6 Annually -> 12 -periodsBetween :: T.Day -> T.Day -> Period -> Integer -periodsBetween t1 t2 p - = case p of - Weekly -> div (T.diffDays t1 t2) 7 - Monthly -> _diff - Annually -> div _diff 12 - Quarterly -> div _diff 4 - where - _diff = T.cdMonths $ T.diffGregorianDurationClip t1 t2 +-- | Number of whole calendar months between two dates, i.e. how many complete +-- months have elapsed from @t1@ to @t2@. Partial months are clipped, so e.g. +-- 2021-01-31 -> 2021-02-01 is 0 months. Returns a negative value when @t2@ is +-- earlier than @t1@ and 0 when both dates are equal. +monthsBetween :: Date -> Date -> Integer +monthsBetween t1 t2 + = T.cdMonths $ T.diffGregorianDurationClip t2 t1 mkTs :: [(Date,Rational)] -> Ts diff --git a/src/Pool.hs b/src/Pool.hs index 47ef190c..d4f36d90 100644 --- a/src/Pool.hs +++ b/src/Pool.hs @@ -13,7 +13,7 @@ module Pool (Pool(..),aggPool import Lib (Period(..) ,Ts(..),periodRateFromAnnualRate,toDate - ,getIntervalDays,zipWith9,mkTs,periodsBetween + ,getIntervalDays,zipWith9,mkTs,monthsBetween ,mkRateTs,daysBetween, prorataFactors) import Control.Parallel.Strategies diff --git a/test/MainTest.hs b/test/MainTest.hs index 3b4d2ecc..881f7f6a 100644 --- a/test/MainTest.hs +++ b/test/MainTest.hs @@ -45,6 +45,7 @@ tests = testGroup "Tests" [AT.mortgageTests ,AT.installmentTest ,AT.armTest ,AT.ppyTest + ,AT.ppyVectorTest -- ,AT.delinqScheduleCFTest ,AT.delinqMortgageTest ,AT.nonPayMortgageTest diff --git a/test/UT/AssetTest.hs b/test/UT/AssetTest.hs index 09874e20..e3fa1c4e 100644 --- a/test/UT/AssetTest.hs +++ b/test/UT/AssetTest.hs @@ -1,4 +1,4 @@ -module UT.AssetTest(mortgageTests,mortgageCalcTests,loanTests,leaseTests,installmentTest,armTest,ppyTest +module UT.AssetTest(mortgageTests,mortgageCalcTests,loanTests,leaseTests,installmentTest,armTest,ppyTest,ppyVectorTest ,delinqScheduleCFTest,delinqMortgageTest,btlMortgageTest,nonPayMortgageTest,receivableTest,fixedAssetTest) where @@ -620,6 +620,34 @@ ppyTest = (CF.cfAt ppy_cf_5 4) ] +ppyVectorTest :: TestTree +ppyVectorTest = + let + -- tm origin date is 2021-01-01 + absDsFirst = L.toDate <$> ["20210201","20210301","20210401","20210501"] + absDs = L.toDate <$> ["20210701","20210801","20210901","20211001"] + absRatesFirst r = Ast.buildPrepayRates tm absDsFirst (Just (A.PrepaymentABS r)) + absRates r = Ast.buildPrepayRates tm absDs (Just (A.PrepaymentABS r)) + in + testGroup "Prepayment vector tests" [ + testCase "PrepaymentABS 2% => SMM by month age | fisth 4 months" $ + assertEqual "abs vector" + (Right [1/50,1/49,1/48,1/47]) + (absRatesFirst 0.02) + ,testCase "PrepaymentABS 2% => SMM by month age" $ + assertEqual "abs vector" + (Right [1/45,1/44,1/43,1/42]) + (absRates 0.02) + ,testCase "PrepaymentABS 0% => all zero" $ + assertEqual "abs zero" + (Right [0,0,0,0]) + (absRates 0.0) + ,testCase "PrepaymentABS rejects rate > 1" $ + assertBool "rate > 1 should be Left" (isLeft (absRates 1.5)) + ,testCase "PrepaymentABS rejects negative rate" $ + assertBool "negative rate should be Left" (isLeft (absRates (-0.1))) + ] + delinqScheduleCFTest = let cfs = [CF.MortgageDelinqFlow (L.toDate "20230901") 1000 0 0 0 0 0 0 0 0.08 Nothing Nothing Nothing From 225b1526063480d40e580f284390bee9633c915e Mon Sep 17 00:00:00 2001 From: yellowbean Date: Sun, 27 Sep 2026 23:01:26 +0800 Subject: [PATCH 08/40] bump version to-> < 0.52.6 > --- CHANGELOG.md | 5 +++++ Hastructure.cabal | 2 +- app/Main.hs | 2 +- 3 files changed, 7 insertions(+), 2 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index e6c588d2..07fa5e96 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,11 @@ # Changelog for Hastructure +## 0.52.6 +### 2026-09-27 +* NEW: add new prepayment assumption `PrepaymentABS`, an ABS / absolute prepayment model driven by the asset's seasoning (months elapsed since origin). Supported for `Monthly` assets only. +* FIX: pool-level `DefaultByAmt` is now allocated across multiple assets proportionally to their current balance. + ## 0.52.5 ### 2026-08-23 diff --git a/Hastructure.cabal b/Hastructure.cabal index 86c2ef24..f4c7d79d 100644 --- a/Hastructure.cabal +++ b/Hastructure.cabal @@ -5,7 +5,7 @@ cabal-version: 3.0 -- see: https://github.com/sol/hpack name: Hastructure -version: 0.52.5 +version: 0.52.6 synopsis: Cashflow modeling library for structured finance description: Please see the README on GitHub at category: StructuredFinance,Securitisation,Cashflow diff --git a/app/Main.hs b/app/Main.hs index bb33b33d..ca4609ea 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -100,7 +100,7 @@ debug = flip Debug.Trace.trace version1 :: Version -version1 = Version "0.52.5" +version1 = Version "0.52.6" wrapRun :: [D.ExpectReturn] -> DealType -> Maybe AP.ApplyAssumptionType -> AP.NonPerfAssumption -> RunResp From 1742d6517076e6089f0296c0220c2ca07049173d Mon Sep 17 00:00:00 2001 From: yellowbean Date: Mon, 28 Sep 2026 12:40:13 +0800 Subject: [PATCH 09/40] update dockerfile & workflow to cover arm64 --- .github/workflows/docker-image-dev-by-tag.yml | 7 +++-- Dockerfile | 28 +++++++++---------- 2 files changed, 19 insertions(+), 16 deletions(-) diff --git a/.github/workflows/docker-image-dev-by-tag.yml b/.github/workflows/docker-image-dev-by-tag.yml index 065a100e..97af02cf 100644 --- a/.github/workflows/docker-image-dev-by-tag.yml +++ b/.github/workflows/docker-image-dev-by-tag.yml @@ -49,9 +49,12 @@ jobs: uses: docker/build-push-action@v3 with: platforms: linux/amd64,linux/arm64 - push: true + push: true + build-args: | + CFLAGS=-march=armv8-a + CPPFLAGS=-march=armv8-a tags: ${{ secrets.DOCKER_HUB_USERNAME }}/hastructure:dev, ${{ steps.meta.outputs.tags }} cache-from: type=registry,ref=${{ secrets.DOCKER_HUB_USERNAME }}/hastructure:buildcache cache-to: type=registry,ref=${{ secrets.DOCKER_HUB_USERNAME }}/hastructure:buildcache,mode=max - \ No newline at end of file + diff --git a/Dockerfile b/Dockerfile index 0461a30e..c4fdeabe 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,21 +1,21 @@ -FROM haskell:9.8.4-slim-bullseye as build -RUN mkdir /opt/build -COPY . /opt/build -RUN cd /opt/build && cabal update && cabal install - +FROM --platform=$BUILDPLATFORM haskell:9.8.4-slim-bullseye AS build -FROM --platform=linux/amd64 ubuntu:25.04 -RUN mkdir -p /opt/myapp -ARG BINARY_PATH -WORKDIR /opt/myapp -RUN apt-get update && apt-get install -y \ - ca-certificates \ - libgmp-dev -# NOTICE THIS LINE +ARG TARGETPLATFORM +RUN case "$TARGETPLATFORM" in \ + linux/arm64) \ + export CFLAGS="-march=armv8-a" \ + export CPPFLAGS="-march=armv8-a" ;; \ + *) ;; \ + esac +WORKDIR /opt/build +COPY . /opt/build +RUN cabal update && cabal install +FROM ubuntu:25.04 +WORKDIR /opt/myapp +RUN apt-get update && apt-get install -y ca-certificates libgmp-dev COPY --from=build /root/.local/bin/Hastructure-exe . COPY --from=build /opt/build/config.yml . COPY --from=build /opt/build/swagger.json . -#COPY config.yml /opt/myapp CMD ["/opt/myapp/Hastructure-exe"] From aa5ec3312c4f3697a2be6ac3948508981a701e85 Mon Sep 17 00:00:00 2001 From: yellowbean Date: Mon, 28 Sep 2026 12:41:10 +0800 Subject: [PATCH 10/40] bump version to-> < 0.52.7 > --- Hastructure.cabal | 2 +- app/Main.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/Hastructure.cabal b/Hastructure.cabal index f4c7d79d..56626b1c 100644 --- a/Hastructure.cabal +++ b/Hastructure.cabal @@ -5,7 +5,7 @@ cabal-version: 3.0 -- see: https://github.com/sol/hpack name: Hastructure -version: 0.52.6 +version: 0.52.7 synopsis: Cashflow modeling library for structured finance description: Please see the README on GitHub at category: StructuredFinance,Securitisation,Cashflow diff --git a/app/Main.hs b/app/Main.hs index ca4609ea..badd3e83 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -100,7 +100,7 @@ debug = flip Debug.Trace.trace version1 :: Version -version1 = Version "0.52.6" +version1 = Version "0.52.7" wrapRun :: [D.ExpectReturn] -> DealType -> Maybe AP.ApplyAssumptionType -> AP.NonPerfAssumption -> RunResp From 8d1209cc4749e15b83857924768d1216fdaaf17e Mon Sep 17 00:00:00 2001 From: yellowbean Date: Wed, 14 Oct 2026 00:04:17 +0800 Subject: [PATCH 11/40] fix #327 --- shell.nix | 8 +++++++- src/Deal.hs | 14 +++++++++----- test/MainTest.hs | 1 + test/UT/DealTest.hs | 20 +++++++++++++++++++- 4 files changed, 36 insertions(+), 7 deletions(-) diff --git a/shell.nix b/shell.nix index f708e7a5..24698ac4 100644 --- a/shell.nix +++ b/shell.nix @@ -1,10 +1,16 @@ { pkgs ? import {} }: +let + # HLS must be built for the same GHC as the project (ghc912 = 9.12.3). + # pkgs.haskell-language-server targets the nixpkgs default GHC (9.10.x) + # and will refuse to load this project. + hls = pkgs.haskell.packages.ghc912.haskell-language-server; +in pkgs.mkShell { buildInputs = with pkgs ; [ cabal-install cabal2nix haskell.compiler.ghc912 - haskell-language-server + hls python313Packages.towncrier ghciwatch just diff --git a/src/Deal.hs b/src/Deal.hs index 6ce5f192..781fb9f6 100644 --- a/src/Deal.hs +++ b/src/Deal.hs @@ -12,6 +12,7 @@ module Deal (run,getInits,runDeal,ExpectReturn(..) ,populateDealDates ,calcTargetAmount,updateLiqProvider ,projAssetUnion,priceAssetUnion + ,priceBonds ,runPoolType,PoolType ,ActionOnDate(..),DateDesp(..) ,changeDealStatus @@ -224,11 +225,14 @@ priceBonds t@TestDeal {bonds = bndMap} (AP.IrrInput bMapInput) -- (Maybe Bond,IrrType) bndMap' = Map.mapWithKey (\k v -> (getBondByName t True k, v)) bMapInput -- (Rate, [(date, cash)]) - bndMap'' = Map.map (\(Just b, v) -> - do - let _irrTxns = getAllTxns b - (_irr, flows) <- priceBondIrr v _irrTxns - return (IrrResult (fromRational _irr) flows)) + bndMap'' = Map.mapWithKey (\bn (mb, v) -> + case mb of + Nothing -> Left $ "priceBonds: bond not found: " ++ show bn + Just b -> + do + let _irrTxns = getAllTxns b + (_irr, flows) <- priceBondIrr v _irrTxns + return (IrrResult (fromRational _irr) flows)) bndMap' in sequenceA bndMap'' diff --git a/test/MainTest.hs b/test/MainTest.hs index 881f7f6a..503b61a8 100644 --- a/test/MainTest.hs +++ b/test/MainTest.hs @@ -80,6 +80,7 @@ tests = testGroup "Tests" [AT.mortgageTests ,DT.dateTests ,DT.liqProviderTest ,DT.poolFlowTest + ,DT.priceBondsIrrTest ,DT2.queryTests ,UtilT.daycountTests1 ,UtilT.daycountTests2 diff --git a/test/UT/DealTest.hs b/test/UT/DealTest.hs index 8e2b00b7..2b825d32 100644 --- a/test/UT/DealTest.hs +++ b/test/UT/DealTest.hs @@ -1,4 +1,4 @@ -module UT.DealTest(td2,queryTests,triggerTests,dateTests,liqProviderTest,poolFlowTest) +module UT.DealTest(td2,queryTests,triggerTests,dateTests,liqProviderTest,poolFlowTest,priceBondsIrrTest) where @@ -31,6 +31,7 @@ import Control.Lens hiding (Index,Empty) import Control.Lens.TH import Data.Maybe import Data.Either +import Data.List (isInfixOf) import qualified Data.Map as Map import qualified Data.Time as T @@ -390,3 +391,20 @@ liqProviderTest = (ByAvailAmount 100) (CE.liqCredit $ CE.accrueLiqProvider (toDate "20221101") liq1) ] + +priceBondsIrrTest = + let + historyCash = [(toDate "20220101", -1000.0),(toDate "20230101", 1100.0)] + holding = AP.HoldingBond historyCash 0 Nothing + in + testGroup "priceBonds IrrInput Tests" + [ testCase "unknown bond name returns Left instead of crashing" $ + case priceBonds baseDeal (AP.IrrInput (Map.fromList [("NONEXISTENT", holding)])) of + Left er -> assertBool ("error message should mention the missing bond, got: " ++ er) + ("NONEXISTENT" `isInfixOf` er) + Right _ -> assertFailure "expected Left when pricing an unknown bond name" + , testCase "known bond name still prices successfully" $ + case priceBonds baseDeal (AP.IrrInput (Map.fromList [("A", holding)])) of + Left er -> assertFailure ("expected Right for known bond \"A\" but got: " ++ er) + Right m -> assertEqual "should return a result for bond A" ["A"] (Map.keys m) + ] From 7a7888e01fa602448f7db3d5b1fa504a8660c882 Mon Sep 17 00:00:00 2001 From: yellowbean Date: Wed, 14 Oct 2026 00:21:05 +0800 Subject: [PATCH 12/40] fix #331 --- src/Cashflow.hs | 4 ++-- test/MainTest.hs | 1 + test/UT/CashflowTest.hs | 35 ++++++++++++++++++++++++++++------- 3 files changed, 31 insertions(+), 9 deletions(-) diff --git a/src/Cashflow.hs b/src/Cashflow.hs index df8f75d2..f518b233 100644 --- a/src/Cashflow.hs +++ b/src/Cashflow.hs @@ -735,7 +735,7 @@ mflowBorrowerNum :: TsRow -> Maybe BorrowerNum -- ^ get borrower numfer for Mortgage Flow mflowBorrowerNum (MortgageFlow _ _ _ _ _ _ _ _ _ x _ _) = x mflowBorrowerNum (MortgageDelinqFlow _ _ _ _ _ _ _ _ _ _ x _ _) = x -mflowBorrowerNum _ = undefined +mflowBorrowerNum _ = Nothing mflowPrepaymentPenalty :: TsRow -> Balance -- ^ get prepayment penalty for a cashflow record @@ -743,7 +743,7 @@ mflowPrepaymentPenalty (MortgageFlow _ _ _ _ _ _ _ _ _ _ (Just x) _) = x mflowPrepaymentPenalty (MortgageFlow _ _ _ _ _ _ _ _ _ _ Nothing _) = 0 mflowPrepaymentPenalty (MortgageDelinqFlow _ _ _ _ _ _ _ _ _ _ _ (Just x) _) = x mflowPrepaymentPenalty (MortgageDelinqFlow _ _ _ _ _ _ _ _ _ _ _ Nothing _) = 0 -mflowPrepaymentPenalty _ = undefined +mflowPrepaymentPenalty _ = 0 -- tobe factor out alongside with similar funciton in bond cashflow mflowWeightAverageBalance :: Date -> Date -> [TsRow] -> Balance diff --git a/test/MainTest.hs b/test/MainTest.hs index 503b61a8..e921918d 100644 --- a/test/MainTest.hs +++ b/test/MainTest.hs @@ -60,6 +60,7 @@ tests = testGroup "Tests" [AT.mortgageTests ,CFT.testCumStat ,CFT.testClawIntTest ,CFT.testPoolAggTest + ,CFT.testMflowAccessors ,BT.pricingTests ,BT.bndConsolTest ,BT.writeOffTest diff --git a/test/UT/CashflowTest.hs b/test/UT/CashflowTest.hs index 619f788d..f724a44b 100644 --- a/test/UT/CashflowTest.hs +++ b/test/UT/CashflowTest.hs @@ -1,5 +1,6 @@ module UT.CashflowTest(cfTests,tsSplitTests,testMergePoolCf,combineTest,testHaircut - ,testMergeTsRowsFromTwoEntities,testCumStat,testClawIntTest,testPoolAggTest) + ,testMergeTsRowsFromTwoEntities,testCumStat,testClawIntTest,testPoolAggTest + ,testMflowAccessors) where import Test.Tasty @@ -446,10 +447,30 @@ testPoolAggTest = (snd (Pool.aggPool (Just (Map.fromList [(HistoryDefaults,100)])) [(cf, (Map.fromList [(HistoryDefaults,100)])),(cf1,Map.empty)] )) - ,testCase "pool agg with init default=100 and projected cf default2" $ - assertEqual "cum stats with default=100, projected default on cfs" - (Map.fromList [(HistoryDefaults,200)]) - (snd (Pool.aggPool (Just (Map.fromList [(HistoryDefaults,100)])) - [(cf, (Map.fromList [(HistoryDefaults,100)])),(cf2, Map.empty)] - )) + ,testCase "pool agg with init default=100 and projected cf default2" $ + assertEqual "cum stats with default=100, projected default on cfs" + (Map.fromList [(HistoryDefaults,200)]) + (snd (Pool.aggPool (Just (Map.fromList [(HistoryDefaults,100)])) + [(cf, (Map.fromList [(HistoryDefaults,100)])),(cf2, Map.empty)] + )) + ] + +testMflowAccessors = + let + loanRow = CF.LoanFlow (L.toDate "20220101") 100 10 5 0 0 0 0 0.0 Nothing + leaseRow = CF.LeaseFlow (L.toDate "20220101") 100 5 0 + mtgRow = CF.MortgageFlow (L.toDate "20220101") 100 10 10 0 0 0 0 0 (Just 3) (Just 5) Nothing + mtgRowNoB = CF.MortgageFlow (L.toDate "20220101") 100 10 10 0 0 0 0 0 Nothing Nothing Nothing + in + testGroup "mflow accessor totality" + [ testCase "borrower num on non-mortgage row returns Nothing instead of undefined" $ + assertEqual "loan flow has no borrower field" Nothing (CF.mflowBorrowerNum loanRow) + ,testCase "borrower num on mortgage row still works" $ + assertEqual "mortgage borrower num" (Just 3) (CF.mflowBorrowerNum mtgRow) + ,testCase "borrower num on mortgage row without info is Nothing" $ + assertEqual "mortgage borrower num" Nothing (CF.mflowBorrowerNum mtgRowNoB) + ,testCase "prepayment penalty on non-mortgage row returns 0 instead of undefined" $ + assertEqual "lease flow has no penalty field" 0 (CF.mflowPrepaymentPenalty leaseRow) + ,testCase "prepayment penalty on mortgage row still works" $ + assertEqual "mortgage penalty" 5 (CF.mflowPrepaymentPenalty mtgRow) ] From e1b8634904f4dda24f55da5df0e596ffdee9c085 Mon Sep 17 00:00:00 2001 From: yellowbean Date: Wed, 14 Oct 2026 00:29:39 +0800 Subject: [PATCH 13/40] fix #325 --- src/Lib.hs | 46 ++++++++++++++++------------------------------ test/UT/LibTest.hs | 26 ++++++++++++++++++++++++++ 2 files changed, 42 insertions(+), 30 deletions(-) diff --git a/src/Lib.hs b/src/Lib.hs index 6534ccb2..49dc2bf9 100644 --- a/src/Lib.hs +++ b/src/Lib.hs @@ -42,6 +42,7 @@ periodRateFromAnnualRate Quarterly annual_rate = annual_rate / 4 periodRateFromAnnualRate SemiAnnually annual_rate = annual_rate / 2 periodRateFromAnnualRate Daily annual_rate = annual_rate / 365 periodRateFromAnnualRate Weekly annual_rate = annual_rate / 52.143 +periodRateFromAnnualRate BiWeekly annual_rate = annual_rate / 26.0715 addD :: Date -> T.CalendarDiffDays -> Date addD d calendarMonth = T.addGregorianDurationClip T.calendarMonth d @@ -104,14 +105,19 @@ paySeqLiabResi startAmt funds allocatedAmts = paySeqLiabilitiesAmt startAmt funds afterNPeriod :: T.Day -> Integer -> Period -> T.Day -afterNPeriod d i p = - T.addGregorianMonthsClip ( months * i) d - where - months = case p of - Monthly -> 1 - Quarterly -> 3 - SemiAnnually -> 6 - Annually -> 12 +afterNPeriod d i p = advancePeriod i p d + +-- | Advance a date by @i@ whole periods. Total over every 'Period' +-- constructor: day-based periods advance by a fixed number of days, +-- month-based periods by a clipped number of calendar months. +advancePeriod :: Integer -> Period -> Date -> Date +advancePeriod i Daily = T.addGregorianDurationClip (T.CalendarDiffDays 0 i) +advancePeriod i Weekly = T.addGregorianDurationClip (T.CalendarDiffDays 0 (7 * i)) +advancePeriod i BiWeekly = T.addGregorianDurationClip (T.CalendarDiffDays 0 (14 * i)) +advancePeriod i Monthly = T.addGregorianMonthsClip i +advancePeriod i Quarterly = T.addGregorianMonthsClip (3 * i) +advancePeriod i SemiAnnually = T.addGregorianMonthsClip (6 * i) +advancePeriod i Annually = T.addGregorianMonthsClip (12 * i) -- | Number of whole calendar months between two dates, i.e. how many complete -- months have elapsed from @t1@ to @t2@. Partial months are clipped, so e.g. @@ -217,27 +223,7 @@ daysBetweenI :: Date -> Date -> Int daysBetweenI sd ed = fromInteger $ T.diffDays ed sd genDates :: Date -> Period -> Int -> [Date] -genDates start_day BiWeekly n = - [ T.addGregorianDurationClip (T.CalendarDiffDays 0 (toInteger i * 14)) start_day | i <- [1..n]] --`debug` ("Hit weekly") -genDates start_day Weekly n = - [ T.addGregorianDurationClip (T.CalendarDiffDays 0 (toInteger i * 7)) start_day | i <- [1..n]] --`debug` ("Hit weekly") -genDates start_day p n = - [ T.addGregorianDurationClip (T.CalendarDiffDays (toInteger i*mul) 0) start_day | i <- [1..n]] - where - mul = case p of - Monthly -> 1 - Quarterly -> 3 - SemiAnnually -> 6 - Annually -> 12 - _ -> error $ "Invalid period" ++ show p +genDates start_day p n = [ advancePeriod (toInteger i) p start_day | i <- [1..n] ] nextDate :: Date -> Period -> Date -nextDate d p - = T.addGregorianMonthsClip m d - where - m = case p of - Monthly -> 1 - Quarterly -> 3 - SemiAnnually -> 6 - Annually -> 12 - _ -> 0 +nextDate d p = advancePeriod 1 p d diff --git a/test/UT/LibTest.hs b/test/UT/LibTest.hs index b10fe19f..4b8791d4 100644 --- a/test/UT/LibTest.hs +++ b/test/UT/LibTest.hs @@ -115,6 +115,32 @@ datesTests = testGroup "date related " testCase "zero extra" $ assertEqual "1 Month" [] d2 + ,testCase "Weekly dates" $ + assertEqual "weekly schedule" + (toDates ["20220808","20220815","20220822"]) + (genDates (toDate "20220801") Weekly 3) + ,testCase "BiWeekly dates" $ + assertEqual "biweekly schedule" + (toDates ["20220815","20220829","20220912"]) + (genDates (toDate "20220801") BiWeekly 3) + ,testCase "Daily dates" $ + assertEqual "daily schedule" + (toDates ["20220802","20220803","20220804"]) + (genDates (toDate "20220801") Daily 3) + ,testCase "nextDate weekly is total" $ + assertEqual "next weekly" (toDate "20220808") (nextDate (toDate "20220801") Weekly) + ,testCase "nextDate biweekly is total" $ + assertEqual "next biweekly" (toDate "20220815") (nextDate (toDate "20220801") BiWeekly) + ,testCase "afterNPeriod weekly" $ + assertEqual "3 weekly" (toDate "20220822") (afterNPeriod (toDate "20220801") 3 Weekly) + ,testCase "afterNPeriod biweekly" $ + assertEqual "2 biweekly" (toDate "20220829") (afterNPeriod (toDate "20220801") 2 BiWeekly) + ,testCase "afterNPeriod daily" $ + assertEqual "5 daily" (toDate "20220806") (afterNPeriod (toDate "20220801") 5 Daily) + ,testCase "period rate BiWeekly" $ + assertEqual "annual->biweekly" 1 (periodRateFromAnnualRate BiWeekly 26.0715) + ,testCase "period rate Weekly" $ + assertEqual "annual->weekly" 1 (periodRateFromAnnualRate Weekly 52.143) ] prorataTests = testGroup "prorata Test" From cb73353999a61e42123c36308c6b82c30a6384d2 Mon Sep 17 00:00:00 2001 From: yellowbean Date: Wed, 14 Oct 2026 01:39:00 +0800 Subject: [PATCH 14/40] fix head/tail --- src/Analytics.hs | 8 ++++++- src/Asset.hs | 10 ++++++-- src/AssetClass/FixedAsset.hs | 1 + src/AssetClass/Lease.hs | 21 ++++++++++------- src/AssetClass/Loan.hs | 4 +++- src/AssetClass/Mortgage.hs | 13 +++++++---- src/AssetClass/ProjectedCashFlow.hs | 9 ++++++-- src/AssetClass/Receivable.hs | 5 ++-- src/Cashflow.hs | 7 ++++-- src/DateUtil.hs | 2 +- src/Deal/DealBase.hs | 4 +++- src/Deal/DealRun.hs | 6 ++--- src/Liability.hs | 15 ++++++------ src/Stmt.hs | 4 +++- src/Types.hs | 15 ++++++++---- src/Util.hs | 2 ++ test/MainTest.hs | 5 ++++ test/UT/AnalyticsTest.hs | 21 +++++++++++++++-- test/UT/AssetTest.hs | 23 +++++++++++++++++- test/UT/BondTest.hs | 8 ++++++- test/UT/CashflowTest.hs | 16 ++++++++++++- test/UT/DealTest.hs | 7 ++++-- test/UT/LibTest.hs | 36 ++++++++++++++++++++++++++++- test/UT/StmtTest.hs | 8 +++++++ 24 files changed, 203 insertions(+), 47 deletions(-) diff --git a/src/Analytics.hs b/src/Analytics.hs index 57c1c60d..79f0d90c 100644 --- a/src/Analytics.hs +++ b/src/Analytics.hs @@ -57,6 +57,8 @@ secantSlopes points = zipWith -- Compute initial slopes (average of adjacent secant slopes for interior points) initialSlopes :: [TimeYield] -> [Double] +initialSlopes [] = [] +initialSlopes [_] = [0] initialSlopes points@((t0, y0):rest) = let deltas = secantSlopes points n = length points @@ -66,7 +68,9 @@ initialSlopes points@((t0, y0):rest) = in slopes fritschCarlsonSlopes :: [TimeYield] -> [Double] -fritschCarlsonSlopes points = adjustSlopes points initialSlopes +fritschCarlsonSlopes points + | length points < 2 = replicate (length points) 0 + | otherwise = adjustSlopes points initialSlopes where -- Compute initial slopes initialSlopes :: [Double] @@ -95,6 +99,8 @@ fritschCarlsonSlopes points = adjustSlopes points initialSlopes go _ _ _ = error "Invalid input" interpolateWithHermite :: (Date,[(Date, Double)]) -> Dates -> [Double] +interpolateWithHermite (_sd, []) ds = replicate (length ds) 0 +interpolateWithHermite (_sd, [(_,y)]) ds = replicate (length ds) y interpolateWithHermite (sd, ts) ds = let xs = (fromRational . (yearCountFraction DC_ACT_365F sd)) <$> (fst <$> ts) diff --git a/src/Asset.hs b/src/Asset.hs index a532eb3b..6ac914df 100644 --- a/src/Asset.hs +++ b/src/Asset.hs @@ -209,6 +209,7 @@ buildPrepayRates a ds (Just (A.PrepaymentVec vs)) (getIntervalDays ds) buildPrepayRates a ds (Just (A.PrepaymentVecPadding vs)) + | null vs = Left "buildPrepayRates: prepayment vector padding is empty" | any (> 1.0) vs || any (< 0.0) vs = Left $ "buildPrepayRates: prepayment vector should be between 0 and 1, got " ++ show vs | otherwise = return $ zipWith Util.toPeriodRateByInterval (paddingDefault (last vs) vs (pred (length ds))) @@ -258,6 +259,7 @@ buildDefaultRates a ds (Just (A.DefaultVec vs)) (paddingDefault 0.0 vs (pred (length ds))) (getIntervalDays ds) buildDefaultRates a ds (Just (A.DefaultVecPadding vs)) + | null vs = Left "buildDefaultRates: default vector padding is empty" | any (> 1.0) vs || any (< 0.0) vs = Left $ "buildDefaultRates: default vector should be between 0 and 1, got " ++ show vs | otherwise = return $ zipWith Util.toPeriodRateByInterval (paddingDefault (last vs) vs (pred (length ds))) @@ -364,7 +366,9 @@ priceAsset m d (PVCurve curve) assumps mRates cType [] -> 0 (fstTxnDate:_) -> let - accStartDate = last $ takeWhile (< fstTxnDate) pDays + accStartDate = case takeWhile (< fstTxnDate) pDays of + [] -> getOriginDate m + pds -> last pds in mulBR (mulBIR cb cr) (yearCountFraction DC_ACT_365F accStartDate d) amts = CF.tsTotalCash <$> (case cType of @@ -408,7 +412,9 @@ priceAsset m d (PvRate r) assumps mRates cType [] -> 0 (fstTxnDate:_) -> let - accStartDate = last $ takeWhile (< fstTxnDate) pDays + accStartDate = case takeWhile (< fstTxnDate) pDays of + [] -> getOriginDate m + pds -> last pds in mulBR (mulBIR cb cr) (yearCountFraction DC_ACT_365F accStartDate d) amts = CF.tsTotalCash <$> (case cType of diff --git a/src/AssetClass/FixedAsset.hs b/src/AssetClass/FixedAsset.hs index 6b7360ab..888bf928 100644 --- a/src/AssetClass/FixedAsset.hs +++ b/src/AssetClass/FixedAsset.hs @@ -96,6 +96,7 @@ instance Ast.Asset FixedAsset where pdates = lastN cfLength $ Ast.getPaymentDates fa extPeriods capacityCaps = case cap of FixedCapacity b -> replicate cfLength b + CapacityByTerm [] -> [] CapacityByTerm tbl -> lastN cfLength $ concat [ replicate i b | (i,b) <- tbl ] ++ (replicate extPeriods (snd (last tbl))) utilsVec = getValByDates uCurve Inc pdates diff --git a/src/AssetClass/Lease.hs b/src/AssetClass/Lease.hs index 10f90ac5..a7908d7f 100644 --- a/src/AssetClass/Lease.hs +++ b/src/AssetClass/Lease.hs @@ -5,7 +5,7 @@ {-# LANGUAGE ScopedTypeVariables #-} module AssetClass.Lease - (Lease(..),projCashflow,updateOriginDate) + (Lease(..),projCashflow,updateOriginDate,calcEndDate) where import qualified Data.Time as T @@ -79,8 +79,12 @@ getNewRental (AP.BaseByVec rs) sd ed (ByPeriodRental rental per) (AP.BaseByVec nextRs, ByPeriodRental newRental per) calcEndDate :: Date -> Int -> LeaseRateCalc -> Date -calcEndDate sd periods (ByDayRate _ dp) = last $ genSerialDates dp Exc sd periods -calcEndDate sd periods (ByPeriodRental _ per) = last $ genDates sd per periods +calcEndDate sd periods (ByDayRate _ dp) = case genSerialDates dp Exc sd periods of + [] -> sd + ds -> last ds +calcEndDate sd periods (ByPeriodRental _ per) = case genDates sd per periods of + [] -> sd + ds -> last ds calcGapDays :: AP.LeaseAssetGapAssump -> Date -> Int calcGapDays (AP.GapDays days) _ = days @@ -90,7 +94,7 @@ calcGapDays (AP.GapDaysByCurve ts) d = round $ fromRational $ getValByDate ts Ex nextLease :: Lease -> (AP.LeaseAssetRentAssump, TermChangeRate, DayGap) -> (Lease, Date ,(AP.LeaseAssetRentAssump, TermChangeRate, DayGap)) nextLease l@(RegularLease (LeaseInfo sd ot rental ob) bal rt _) (rAssump,tc,gd) = let - leaseEndDate = last $ getPaymentDates l 0 + leaseEndDate = case getPaymentDates l 0 of [] -> sd; ds -> last ds nextStartDate = T.addDays (succ (toInteger gd)) leaseEndDate nextOriginTerm = round $ mulIR ot (1+tc) @@ -106,7 +110,7 @@ nextLease l@(RegularLease (LeaseInfo sd ot rental ob) bal rt _) (rAssump,tc,gd) nextLease l@(StepUpLease (LeaseInfo sd ot rental ob) lsteupInfo bal rt _) (rAssump,tc,gd) = let - leaseEndDate = last $ getPaymentDates l 0 + leaseEndDate = case getPaymentDates l 0 of [] -> sd; ds -> last ds nextStartDate = T.addDays (succ (toInteger gd)) leaseEndDate -- `debug` ("Gap Day ->"++ show gd) nextOriginTerm = round $ mulIR ot (1+tc) nextEndDate = calcEndDate nextStartDate ot rental @@ -260,7 +264,7 @@ instance Asset Lease where let pDates = lastN (getRemainTerms l) $ getPaymentDates l 0 let bals = tail $ scanl (-) bal pmts -- `debug` ("pDates "++ show pDates) let defaults = replicate (length pDates) 0.0 -- `debug` ("bals"++ show bals++ ">> d"++ show d) - return $ CF.CashFlowFrame (head bals,max d (getOriginDate l), Nothing) $ cutBy Inc Future d (zipWith4 CF.LeaseFlow pDates bals pmts defaults) + return $ CF.CashFlowFrame (case bals of [] -> bal; (b:_) -> b ,max d (getOriginDate l), Nothing) $ cutBy Inc Future d (zipWith4 CF.LeaseFlow pDates bals pmts defaults) getOriginInfo (StepUpLease lInfo lsteupInfo bal rt st) = lInfo getOriginInfo (RegularLease lInfo bal rt st) = lInfo @@ -299,7 +303,7 @@ instance Asset Lease where newLeases = nextLeaseTill l (rentAssump , 0.0 , pickGapDays gapAssump) - (last pdates) + (case pdates of [] -> getOriginDate l; _ -> last pdates) endType [] stressRentals = 0 @@ -335,7 +339,8 @@ instance Asset Lease where StepUpLease (LeaseInfo sd _ _ _) _ bal _ _ -> sd in case calcCashflow l _sd Nothing of - Right (CF.CashFlowFrame _ txns) -> CF.mflowBegBalance $ head txns + Right (CF.CashFlowFrame _ []) -> 0 + Right (CF.CashFlowFrame _ (t:_)) -> CF.mflowBegBalance t Left _ -> 0 splitWith (RegularLease (LeaseInfo sd ot dr ob) bal rt st ) rs diff --git a/src/AssetClass/Loan.hs b/src/AssetClass/Loan.hs index e31a0473..0bafc448 100644 --- a/src/AssetClass/Loan.hs +++ b/src/AssetClass/Loan.hs @@ -120,7 +120,9 @@ instance Asset Loan where getPaymentDates pl@(PersonalLoan (LoanOriginalInfo ob _ ot p sd (ScheduleRepayment ts mDp) _) _bal _rate _term _ ) extra = let pdays = getTsDates ts - extraDates = genSerialDates (fromMaybe MonthEnd mDp) Inc (last pdays) extra + extraDates = case pdays of + [] -> [] + _ -> genSerialDates (fromMaybe MonthEnd mDp) Inc (last pdays) extra in pdays ++ extraDates diff --git a/src/AssetClass/Mortgage.hs b/src/AssetClass/Mortgage.hs index 08684968..0497808b 100644 --- a/src/AssetClass/Mortgage.hs +++ b/src/AssetClass/Mortgage.hs @@ -313,6 +313,8 @@ instance Ast.Asset Mortgage where ,A.DummyDelinqAssump ,A.DummyDefaultAssump) mRates) + calcCashflow s@(ScheduleMortgageFlow beg_date [] _) d _ + = Right $ CF.CashFlowFrame (0.0, beg_date, Nothing) [] calcCashflow s@(ScheduleMortgageFlow beg_date flows _) d _ = Right $ CF.CashFlowFrame ( ((view CF.tsRowBalance) . head) flows, beg_date, Nothing ) flows @@ -364,6 +366,7 @@ instance Ast.Asset Mortgage where getPaymentDates (Mortgage (MortgageOriginalInfo _ _ ot p sd _ _ _) _ _ _ _ _) extra = genDates sd p (ot+extra) getPaymentDates (AdjustRateMortgage (MortgageOriginalInfo _ _ ot p sd _ _ _) _ _ _ _ _ _) extra = genDates sd p (ot+extra) + getPaymentDates (ScheduleMortgageFlow _ [] _) extra = [] getPaymentDates (ScheduleMortgageFlow begDate flows dp) extra = let lastPayDay = (getDate . last) flows @@ -392,6 +395,7 @@ instance Ast.Asset Mortgage where = AdjustRateMortgage (MortgageOriginalInfo ob or ot p nd _type mpn obr) arm cb cr ct mbn st -- project current mortgage with total default amt + projCashflow (ScheduleMortgageFlow _ [] _) _ _ _ = Left "projCashflow: empty schedule mortgage flow" projCashflow m@(Mortgage (MortgageOriginalInfo ob or ot p sd prinPayType mpn _) cb cr rt mbn Current) asOfDay mars@(A.MortgageAssump (Just (A.DefaultByAmt (dBal,vs))) amp amr ams ,_ ,_) @@ -424,7 +428,7 @@ instance Ast.Asset Mortgage where firstResetDate = monthsAfter sd (toInteger (succ initPeriod)) lastPayDate:cfDates = sliceDates (SliceOnAfterKeepPrevious asOfDay) $ lastN (rt + recoveryLag + 1) $ sd:getPaymentDates m recoveryLag - rateCurve = buildARMrates or (arm, sd, firstResetDate, last cfDates, getOriginRate m) mRates + rateCurve = buildARMrates or (arm, sd, firstResetDate, case cfDates of [] -> lastPayDate; _ -> last cfDates, getOriginRate m) mRates rateVector = fromRational <$> getValByDates rateCurve Inc cfDates expectedDefaultBals = paddingDefault 0 (mulBR dBal <$> vs) (length cfDates) unAppliedDefaultBals = tail $ scanl (-) dBal expectedDefaultBals @@ -488,8 +492,9 @@ instance Ast.Asset Mortgage where (ob, cb,lastPayDate,mbn,prinPayType,dc,cr,p,ot) (cfDates, defRates, ppyRates,rateVector,remainTerms) let txns = DL.toList txns' - let lastProjTxn = last txns - let extraTxns = [ CF.emptyTsRow d lastProjTxn | d <- recoveryDates ] + let extraTxns = case txns of + [] -> [] + _ -> [ CF.emptyTsRow d (last txns) | d <- recoveryDates ] txns'' <- (patchLossRecovery (txns++extraTxns) amr) let (futureTxns,historyM)= CF.cutoffTrs asOfDay txns'' let begBal = CF.buildBegBal futureTxns @@ -582,7 +587,7 @@ instance Ast.Asset Mortgage where lastPayDate:cfDates = lastN (recoveryLag + defaultLag + rt + 1) $ sd:getPaymentDates m recoveryLag (_,defaultLag,defaultPct) = Ast.getDefaultDelinqAssump amd cfDates cfDatesLength = length cfDates - rateCurve = buildARMrates or (arm, sd, firstResetDate, last cfDates, getOriginRate m) mRates + rateCurve = buildARMrates or (arm, sd, firstResetDate, case cfDates of [] -> lastPayDate; _ -> last cfDates, getOriginRate m) mRates rateVector = fromRational <$> getValByDates rateCurve Inc cfDates -- `debug` ("RateCurve"++ show rate_curve) in do diff --git a/src/AssetClass/ProjectedCashFlow.hs b/src/AssetClass/ProjectedCashFlow.hs index 5965ea12..742952bd 100644 --- a/src/AssetClass/ProjectedCashFlow.hs +++ b/src/AssetClass/ProjectedCashFlow.hs @@ -3,7 +3,7 @@ {-# LANGUAGE DeriveGeneric #-} module AssetClass.ProjectedCashFlow - (ProjectedCashFlow(..)) + (ProjectedCashFlow(..),projFixCfwithAssumption) where import qualified Data.Time as T @@ -85,6 +85,7 @@ projectScheduleFlow trs b_factor (lastBal,lastDate) [] _ _ (r:rs) (l:ls) (recove projFixCfwithAssumption :: ([Balance], [Date], [Rational], [IntCalcType], DatePattern) -> ([Rate],[Rate],Rate,Int) -> Date -> Either ErrorRep CF.CashFlowFrame projFixCfwithAssumption (bals, ds, amortFactors, rates, dp) (ppyRates,defRates,recoveryRate,recoveryLag) asOfDay | all (== 0) bals = return $ CF.CashFlowFrame (0.0,asOfDay,Nothing) [] + | null bals || null ds = Left "projFixCfwithAssumption: empty balance or date schedule" | length amortFactors /= length ppyRates || length amortFactors /= length defRates = Left $ "Not even rates amort "++ (showLength amortFactors) ++ "ppy rate " ++ (showLength ppyRates) ++ " def rate" ++ (showLength defRates) | otherwise = let @@ -99,11 +100,14 @@ projFixCfwithAssumption (bals, ds, amortFactors, rates, dp) (ppyRates,defRates,r in do let (futureTxns,historyM) = CF.cutoffTrs asOfDay (DL.toList txns) -- `debug` ("txn" ++ show txns) - let cb = (CF.mflowBegBalance . head) futureTxns + let cb = case futureTxns of + [] -> 0.0 + (t:_) -> CF.mflowBegBalance t return $ CF.CashFlowFrame (cb,asOfDay,Nothing) futureTxns -- `debug` ("future txns" ++ show futureTxns) -- ^ project cashflow with fix rate portion projIndexCashflows :: ([Balance] , [Date] , Index, Spread) -> DatePattern -> ([Rate],[Rate],Rate,Int) -> Maybe [RateAssumption] -> Either String CF.CashFlowFrame +projIndexCashflows (_, [], _, _) _ _ _ = Left "projIndexCashflows: empty date schedule" projIndexCashflows (bals, ds, index, spd) dp pAssump Nothing = Left "No rate assumption provided for index cashflow projection" projIndexCashflows (bals, ds, index, spd) dp pAssump (Just ras) = do @@ -119,6 +123,7 @@ seperateCashflows :: ProjectedCashFlow -> Maybe A.AssetPerfAssumption -> Maybe [ seperateCashflows a@(ProjectedByFactor pflow dp (fixPct,fixRate) floaterList) mPassump mRates + | null pflow = Left "seperateCashflows: empty cashflow schedule" | fixPct + sum (view _1 <$> floaterList) /= 1.0 = Left $ "Fix portion " ++ show fixPct ++ " + float portion " ++ show (sum (view _1 <$> floaterList)) ++ " is not sum up to 100% " | otherwise = let diff --git a/src/AssetClass/Receivable.hs b/src/AssetClass/Receivable.hs index 49319345..359cd52d 100644 --- a/src/AssetClass/Receivable.hs +++ b/src/AssetClass/Receivable.hs @@ -162,9 +162,10 @@ instance Asset Receivable where in do defaultRates <- A.buildDefaultRates r (sd:[dd]) amd - let defaultAmt = mulBR ob (head defaultRates) + let dr = case defaultRates of [] -> 0.0; (x:_) -> x + let defaultAmt = mulBR ob dr let afterDefaultBal = ob - defaultAmt - let afterDefaultFee = mulBR feeDue (1 - head defaultRates) + let afterDefaultFee = mulBR feeDue (1 - dr) let feePaid = min afterDefaultBal afterDefaultFee let principal = max 0 $ afterDefaultBal - feePaid diff --git a/src/Cashflow.hs b/src/Cashflow.hs index f518b233..d2e18a17 100644 --- a/src/Cashflow.hs +++ b/src/Cashflow.hs @@ -5,7 +5,7 @@ module Cashflow (CashFlowFrame(..),Principals,Interests,Amount ,combine,mergePoolCf,sumTsCF,tsSetLoss,tsSetRecovery - ,sizeCashFlowFrame,aggTsByDates,emptyCashFlowFrame + ,sizeCashFlowFrame,aggTsByDates,emptyCashFlowFrame,buildCollectedCF ,mflowInterest,mflowPrincipal,mflowRecovery,mflowPrepayment ,mflowRental,mflowRate,sumPoolFlow,splitTrs,aggregateTsByDate ,mflowDefault,mflowLoss @@ -596,7 +596,10 @@ combine cf1@(CashFlowFrame st1@(begBal1,begDate1,acc1) txn1) cf2@(CashFlowFrame buildCollectedCF :: [[TsRow]] -> [Date] -> [TsRow] -> [[TsRow]] buildCollectedCF [] [] [] = [] buildCollectedCF trs [] _trs = trs -buildCollectedCF trs ds [] = trs ++ [ [viewTsRow _d ((last . last) trs)] | _d <- ds ] +buildCollectedCF trs ds [] = + case Util.lastOf trs (not . null) of + Just lastTr -> trs ++ [ [viewTsRow _d (last lastTr)] | _d <- ds ] + Nothing -> trs ++ replicate (length ds) [] buildCollectedCF trs (d:ds) _trs = case newFlow of [] -> case Util.lastOf trs (not . null) of diff --git a/src/DateUtil.hs b/src/DateUtil.hs index 33d692bf..1fa4fce1 100644 --- a/src/DateUtil.hs +++ b/src/DateUtil.hs @@ -229,7 +229,7 @@ genSerialDatesTill sd ptn ed genSerialDatesTill2 :: RangeType -> Date -> DatePattern -> Date -> Dates genSerialDatesTill2 rt sd dp ed - = case (rt, head _r==sd, last _r==ed) of + = case (rt, not (null _r) && head _r==sd, not (null _r) && last _r==ed) of (II,True,True) -> _r (II,True,False) -> _r ++ [ed] (II,False,True)-> sd:_r diff --git a/src/Deal/DealBase.hs b/src/Deal/DealBase.hs index 6ea3a3c5..ca468f19 100644 --- a/src/Deal/DealBase.hs +++ b/src/Deal/DealBase.hs @@ -237,7 +237,9 @@ populateDealDates (CurrentDates (lastCollect,lastPay) mRevolving end (nextCollec futureCollectDates = genSerialDatesTill2 IE nextCollect poolDp end pa = [ PoolCollection _d "" | _d <- futureCollectDates] in - return (lastCollect, lastPay,head futurePayDates, pa, ba, end, []) + case futurePayDates of + [] -> Left $ "populateDealDates: no payment dates between "++ show nextPay ++ " and "++ show end + (firstFuturePay:_) -> return (lastCollect, lastPay, firstFuturePay, pa, ba, end, []) populateDealDates (GenericDates m) st = let diff --git a/src/Deal/DealRun.hs b/src/Deal/DealRun.hs index 8f019ea0..65efbef2 100644 --- a/src/Deal/DealRun.hs +++ b/src/Deal/DealRun.hs @@ -79,7 +79,7 @@ runEffects (t@TestDeal{accounts = accMap, fees = feeMap ,status=st, bonds = bond t' = t {bonds = updateBondInMap bName updateFn bondMap} -- build bond rate reset actions newActions = case getBondByName t' True bName of - Just bnd -> [ ResetBondRate _d bName | _d <- L.buildRateResetDates bnd d (getDate (last actions))] + Just bnd -> [ ResetBondRate _d bName | _d <- L.buildRateResetDates bnd d (case actions of [] -> d; as -> getDate (last as))] Nothing -> [] in return (t' , rc, sortBy sortActionOnDate (newActions++actions), logs) @@ -584,7 +584,7 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= (\x -> (spd + (fromMaybe 0 (lookupTable walTbl Up (fromRational x >))))) bondWal let bondPricingCurve = Map.map - (\x -> IRateCurve [ TsPoint d x,TsPoint (getDate (last ads)) x]) + (\x -> IRateCurve [ TsPoint d x,TsPoint (case ads of [] -> d; as -> getDate (last as)) x]) bondSprd bondPricingResult <- sequenceA $ Map.intersectionWith (flip (L.priceBond d)) (bonds runDealWithSchedule) bondPricingCurve depositBondFlow <- sequenceA $ @@ -666,7 +666,7 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= run t{bonds = newBonds, accounts = newAcc} rc (Just ads) calls log RefiBondRate d accName bName iInfo -> let - lstDate = getDate (last ads) + lstDate = case ads of [] -> d; as -> getDate (last as) isResetActionEvent (ResetBondRate _ bName ) = False isResetActionEvent _ = True filteredAds = filter isResetActionEvent ads diff --git a/src/Liability.hs b/src/Liability.hs index ea7fb857..51a35d2b 100644 --- a/src/Liability.hs +++ b/src/Liability.hs @@ -583,7 +583,11 @@ calcWalBond d (BondGroup bMap _) weightedBy bndBals bndWal calcWalBond d b - = let + | null txns = 0 + | cutoffBalance == 0 = 0 + | lastBalance > 0 = 0 + | otherwise = toRational wal -- `debug` ("WAL-->"++show (bndName b)++">>"++show wal) + where txns = cutBy Exc Future d $ S.getAllTxns b cutoffBalance = (S.getTxnBegBalance . head ) txns lastBalance = (S.getTxnBalance . last) txns @@ -591,11 +595,6 @@ calcWalBond d b gapDays = (daysBetween firstTxnDate) . S.getDate <$> txns weightPrins = zipWith (*) (S.getTxnPrincipal <$> txns) (fromIntegral <$> gapDays) wal = sum weightPrins / 365 / cutoffBalance - in - if lastBalance > 0 then - 0 - else - toRational wal -- `debug` ("WAL-->"++show (bndName b)++">>"++show wal) getTxnRate :: Txn -> IRate @@ -616,7 +615,9 @@ priceBond d rc bnd | otherwise = let cutoffBalance = case S.getTxnAsOf txns d of - Nothing -> (S.getTxnBegBalance . head) txns + Nothing -> case txns of + [] -> 0 + (t:_) -> S.getTxnBegBalance t Just _txn -> S.getTxnBegBalance _txn -- TODO: what if in current deal,no transaction before pricing day ? what's the begin day for interest to accrual? accruedInt = backoutAccruedInt d (getOriginDate bnd) txns diff --git a/src/Stmt.hs b/src/Stmt.hs index 54e9c69a..0402bf38 100644 --- a/src/Stmt.hs +++ b/src/Stmt.hs @@ -155,7 +155,9 @@ weightAvgBalance sd ed txns = sum $ zipWith mulBR bals dsFactor -- `debug` ("WavgBalace "++show bals++show dsFactor) where _txns = sliceBy IE sd ed txns - bals = map getTxnBegBalance _txns ++ [getTxnBalance (last _txns)] + bals = case _txns of + [] -> [] + _ -> map getTxnBegBalance _txns ++ [getTxnBalance (last _txns)] ds = [sd] ++ map getDate _txns ++ [ed] dsFactor = getIntervalFactors ds -- `debug` ("DS>>>"++show ds) diff --git a/src/Types.hs b/src/Types.hs index f387c6e0..7e4872d1 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -1101,11 +1101,16 @@ parseTxn t = case tagName of -- toJSON (IssuanceProceeds nb) = String $ T.pack $ "" "IssuanceProceeds" -> return $ IssuanceProceeds contents "Tag" -> return $ Tag contents + _ -> fail ("parseTxn: invalid or unsupported txn comment: " ++ show t) where pat = "<(\\S+):(\\S+)>"::String sr = (T.unpack t =~ pat)::[[String]] - tagName = head sr!!1::String - contents = head sr!!2::String + tagName = case sr of + ((_:x:_):_) -> x::String + _ -> "" + contents = case sr of + (([_,_,x]):_) -> x::String + _ -> "" mapKVTraversal :: Traversal' (Map.Map k a) (k, a) @@ -1200,8 +1205,10 @@ getDealStatType (DealStatBool _) = RtnBool getDealStatType (ConstTrue) = RtnBool getDealStatType (ConstFalse) = RtnBool -getDealStatType (Max dss) = getDealStatType (head dss) -getDealStatType (Min dss) = getDealStatType (head dss) +getDealStatType (Max (d:_)) = getDealStatType d +getDealStatType (Max []) = RtnBalance +getDealStatType (Min (d:_)) = getDealStatType d +getDealStatType (Min []) = RtnBalance getDealStatType _ = RtnBalance dealStatType _ = RtnBalance diff --git a/src/Util.hs b/src/Util.hs index 7db1d5aa..e7323e18 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -142,6 +142,7 @@ getValByDate (RatioCurve dps) Inc d Just (TsPoint _d v) -> toRational v -- `debug` ("Getting rate "++show(_d)++show(v)) Nothing -> 0 -- `debug` ("Getting 0 ") +getValByDate (ThresholdCurve []) _ _ = 0 getValByDate (ThresholdCurve dps) Inc d = case find (\(TsPoint _d _) -> d <= _d) dps of Just (TsPoint _d v) -> toRational v -- `debug` ("Getting rate "++show(_d)++show(v)) @@ -161,6 +162,7 @@ getValByDate (FactorCurveClosed dps ed) Exc d _found_v Nothing -> 1.0 +getValByDate (PricingCurve []) _ _ = 0 getValByDate (PricingCurve dps) _ d = case (d>=lday,d<=fday) of (True,_) -> tsPointVal $ last dps diff --git a/test/MainTest.hs b/test/MainTest.hs index e921918d..5f2578f8 100644 --- a/test/MainTest.hs +++ b/test/MainTest.hs @@ -51,6 +51,7 @@ tests = testGroup "Tests" [AT.mortgageTests ,AT.nonPayMortgageTest ,AT.receivableTest ,AT.fixedAssetTest + ,AT.buildRateSafetyTest ,CFT.cfTests ,CFT.tsSplitTests ,CFT.testMergePoolCf @@ -61,11 +62,13 @@ tests = testGroup "Tests" [AT.mortgageTests ,CFT.testClawIntTest ,CFT.testPoolAggTest ,CFT.testMflowAccessors + ,CFT.testCollectedCfSafety ,BT.pricingTests ,BT.bndConsolTest ,BT.writeOffTest ,BT.accrueTest ,BT.selectorTest + ,BT.walSafetyTest ,LT.curveTests ,LT.periodCurveTest ,LT.pvTests @@ -74,6 +77,7 @@ tests = testGroup "Tests" [AT.mortgageTests ,LT.datesTests ,LT.prorataTests ,LT.tsOperationTests + ,LT.libSafetyTests ,ET.expTests ,ET.expPayTest ,DT.queryTests @@ -116,6 +120,7 @@ tests = testGroup "Tests" [AT.mortgageTests ,AnalyticsT.assetPricingTest ,AnalyticsT.irrTest ,AnalyticsT.survivorTest + ,AnalyticsT.hermiteTest ,DealTest.baseTests ,RevolvingTest.baseTests ,DealMultiTest.mPoolbaseTests diff --git a/test/UT/AnalyticsTest.hs b/test/UT/AnalyticsTest.hs index 68b35175..3131c619 100644 --- a/test/UT/AnalyticsTest.hs +++ b/test/UT/AnalyticsTest.hs @@ -1,4 +1,4 @@ -module UT.AnalyticsTest(walTest,durationTest,fvTest,assetPricingTest,irrTest,survivorTest) +module UT.AnalyticsTest(walTest,durationTest,fvTest,assetPricingTest,irrTest,survivorTest,hermiteTest) where import Test.Tasty @@ -30,7 +30,24 @@ walTest = assertEqual "" 0.74 (calcWAL ByYear 100 (L.toDate "20230101") _ps ) - ] + ] + +hermiteTest = + testGroup "Hermite interpolation safety" [ + testCase "single yield point does not crash" $ + assertEqual "one point returns that yield" + [1.0] + (interpolateWithHermite (L.toDate "20230101", [(L.toDate "20230101", 1.0)]) [L.toDate "20230101"]) + ,testCase "empty yield curve does not crash" $ + assertEqual "no points returns zeros" + [0.0] + (interpolateWithHermite (L.toDate "20230101", []) [L.toDate "20230101"]) + ,testCase "two yield points still interpolate" $ + assertBool "interior point yields a value between the two yields" $ + case interpolateWithHermite (L.toDate "20230101", [(L.toDate "20230101", 1.0),(L.toDate "20240101", 2.0)]) [L.toDate "20230701"] of + [v] -> v > 1.0 && v < 2.0 + _ -> False + ] durationTest = testGroup "Duration Test" diff --git a/test/UT/AssetTest.hs b/test/UT/AssetTest.hs index e3fa1c4e..cce105b5 100644 --- a/test/UT/AssetTest.hs +++ b/test/UT/AssetTest.hs @@ -1,5 +1,6 @@ module UT.AssetTest(mortgageTests,mortgageCalcTests,loanTests,leaseTests,installmentTest,armTest,ppyTest,ppyVectorTest - ,delinqScheduleCFTest,delinqMortgageTest,btlMortgageTest,nonPayMortgageTest,receivableTest,fixedAssetTest) + ,delinqScheduleCFTest,delinqMortgageTest,btlMortgageTest,nonPayMortgageTest,receivableTest,fixedAssetTest + ,buildRateSafetyTest) where import Test.Tasty @@ -15,6 +16,7 @@ import qualified AssetClass.Loan as ACL import qualified AssetClass.Lease as ACR import qualified AssetClass.Installment as ACI import qualified AssetClass.Receivable as AR +import qualified AssetClass.ProjectedCashFlow as ACPF import qualified Assumptions as A import qualified Cashflow as CF import qualified Deal as D @@ -971,3 +973,22 @@ fixedAssetTest = -- ((`CF.cfAt` 9) <$> (fst <$> (Ast.projCashflow asset2 (L.toDate "20240101") -- ((A.FixedAssetAssump utilCurve priceCurve Nothing) ,A.DummyDelinqAssump ,A.DummyDefaultAssump) Nothing)))) ] + +buildRateSafetyTest = + let ds = L.toDates ["20210101","20210201","20210301"] + in + testGroup "asset head/last safety" + [ + testCase "empty prepayment padding vector returns Left" $ + assertBool "should be Left" (isLeft (Ast.buildPrepayRates tm ds (Just (A.PrepaymentVecPadding [])))) + , testCase "empty default padding vector returns Left" $ + assertBool "should be Left" (isLeft (Ast.buildDefaultRates tm ds (Just (A.DefaultVecPadding [])))) + , testCase "empty ScheduleMortgageFlow cashflow does not crash" $ + case Ast.calcCashflow (AB.ScheduleMortgageFlow (L.toDate "20220101") [] MonthFirst) (L.toDate "20220101") Nothing of + Right (CF.CashFlowFrame (b,_,_) _) -> assertEqual "begin balance" 0 b + Left e -> assertFailure ("unexpected Left: " ++ e) + , testCase "calcEndDate with zero periods returns start date" $ + assertEqual "start date" (L.toDate "20220101") (ACR.calcEndDate (L.toDate "20220101") 0 (AB.ByPeriodRental 0 L.Monthly)) + , testCase "projFixCfwithAssumption with empty dates returns Left" $ + assertBool "should be Left" (isLeft (ACPF.projFixCfwithAssumption ([1.0],[],[],[],MonthFirst) ([],[],0,0) (L.toDate "20220101"))) + ] diff --git a/test/UT/BondTest.hs b/test/UT/BondTest.hs index 3460b0ef..e1acb661 100644 --- a/test/UT/BondTest.hs +++ b/test/UT/BondTest.hs @@ -1,4 +1,4 @@ -module UT.BondTest(pricingTests,bndConsolTest,writeOffTest,accrueTest,selectorTest) +module UT.BondTest(pricingTests,bndConsolTest,writeOffTest,accrueTest,selectorTest,walSafetyTest) where import Test.Tasty @@ -319,4 +319,10 @@ selectorTest = (isLeft (DB.traverseBondMapByFn fnMap4 bgTest))) ] +walSafetyTest = testGroup "Bond WAL safety" + [ + testCase "calcWalBond on a bond with no future txn returns 0 instead of crashing" $ + assertEqual "0" 0 (B.calcWalBond (L.toDate "20230101") b1) + ] + diff --git a/test/UT/CashflowTest.hs b/test/UT/CashflowTest.hs index f724a44b..8afe4b4c 100644 --- a/test/UT/CashflowTest.hs +++ b/test/UT/CashflowTest.hs @@ -1,6 +1,6 @@ module UT.CashflowTest(cfTests,tsSplitTests,testMergePoolCf,combineTest,testHaircut ,testMergeTsRowsFromTwoEntities,testCumStat,testClawIntTest,testPoolAggTest - ,testMflowAccessors) + ,testMflowAccessors,testCollectedCfSafety) where import Test.Tasty @@ -474,3 +474,17 @@ testMflowAccessors = ,testCase "prepayment penalty on mortgage row still works" $ assertEqual "mortgage penalty" 5 (CF.mflowPrepaymentPenalty mtgRow) ] + +testCollectedCfSafety = + let + row1 = CF.MortgageFlow (L.toDate "20220101") 100 10 10 0 0 0 0 0 Nothing Nothing Nothing + d = L.toDate "20220301" + in + testGroup "buildCollectedCF safety" + [ testCase "does not crash when last accumulated row is empty" $ + let r = CF.buildCollectedCF [[row1],[]] [d] [] + in assertEqual "last row balance comes from the last non-empty accumulated row" 100 + (CF.mflowBegBalance (last (concat r))) + ,testCase "empty trs with dates returns empty rows instead of crashing" $ + assertEqual "two empty rows" [[],[]] (CF.buildCollectedCF [] [L.toDate "20220101",L.toDate "20220201"] []) + ] diff --git a/test/UT/DealTest.hs b/test/UT/DealTest.hs index 2b825d32..074ac52d 100644 --- a/test/UT/DealTest.hs +++ b/test/UT/DealTest.hs @@ -360,8 +360,11 @@ dateTests = ,[RunWaterfall (toDate "20220715") "",RunWaterfall (toDate "20220810") ""] ,(toDate "20220901") ,[])) - (populateDealDates a Amortizing) - ] + (populateDealDates a Amortizing) + ,testCase "populateDealDates with no future pay date returns Left instead of crashing" $ + assertBool "should be Left" + (isLeft (populateDealDates (CurrentDates (toDate "20211201",toDate "20220101") Nothing (toDate "20220101") (toDate "20220101", MonthFirst) (toDate "20220101", MonthFirst)) Amortizing)) + ] liqProviderTest = let diff --git a/test/UT/LibTest.hs b/test/UT/LibTest.hs index 4b8791d4..fec91312 100644 --- a/test/UT/LibTest.hs +++ b/test/UT/LibTest.hs @@ -1,19 +1,23 @@ +{-# LANGUAGE OverloadedStrings #-} module UT.LibTest(curveTests --,queryStmtTests ,datesTests ,prorataTests ,tsOperationTests - ,pvTests,seqFunTest,periodCurveTest) + ,pvTests,seqFunTest,periodCurveTest + ,libSafetyTests) where import Test.Tasty import Test.Tasty.HUnit import qualified Data.Time as T +import qualified Data.Aeson as A import Lib import Types import Util import Stmt +import DateUtil import Data.Ratio curveTests = @@ -248,3 +252,33 @@ seqFunTest = [100,10,0] (paySeqLiabilitiesAmt 120 [100,10,0]) ] + +libSafetyTests = + let + d = toDate "20220101" + in + testGroup "library safety (total head/last)" + [ + testCase "getValByDate on empty ThresholdCurve returns 0" $ + assertEqual "0" (0::Rational) (getValByDate (ThresholdCurve []) Inc d) + , testCase "getValByDate on empty PricingCurve returns 0" $ + assertEqual "0" (0::Rational) (getValByDate (PricingCurve []) Inc d) + , testCase "getDealStatType (Max []) returns RtnBalance" $ + assertEqual "RtnBalance" RtnBalance (getDealStatType (Max [])) + , testCase "getDealStatType (Min []) returns RtnBalance" $ + assertEqual "RtnBalance" RtnBalance (getDealStatType (Min [])) + , testCase "genSerialDatesTill2 with empty generated dates does not crash" $ + assertEqual "sd and ed included for II" + [toDate "20220101", toDate "20221231"] + (genSerialDatesTill2 II (toDate "20220101") (SingletonDate (toDate "20500101")) (toDate "20221231")) + , testCase "parseTxn on invalid string fails instead of crashing" $ + assertBool "should be a parse error" $ + case (A.fromJSON (A.String "garbage") :: A.Result TxnComment) of + A.Error _ -> True + A.Success _ -> False + , testCase "parseTxn on valid tag string still parses" $ + assertBool "should parse Tag" $ + case (A.fromJSON (A.String "") :: A.Result TxnComment) of + A.Success (Tag t) -> t == "hello" + _ -> False + ] diff --git a/test/UT/StmtTest.hs b/test/UT/StmtTest.hs index 3756459e..8fbb6f20 100644 --- a/test/UT/StmtTest.hs +++ b/test/UT/StmtTest.hs @@ -21,6 +21,14 @@ txnTest = (toDate "20221101") (toDate "20221201") [(AccTxn (toDate "20221115") 100 20 Empty)] + ,testCase "Weight Average Balance with no txn in window" $ + assertEqual "empty window -> 0" + 0 $ + weightAvgBalance (toDate "20221101") (toDate "20221201") [] + ,testCase "Weight Average Balance with txns outside window" $ + assertEqual "outside window -> 0" + 0 $ + weightAvgBalance (toDate "20221101") (toDate "20221201") [AccTxn (toDate "20230101") 100 0 Empty] ,testCase "Weight Average Balance " $ assertEqual "Weight Average Balacne " 7.26 $ From 6f573a0503e618e7fc45db2052a233ae3bff762a Mon Sep 17 00:00:00 2001 From: yellowbean Date: Wed, 14 Oct 2026 11:14:50 +0800 Subject: [PATCH 15/40] fix #333 --- src/Deal/DealQuery.hs | 58 +++++++-------- src/Deal/DealRun.hs | 42 +++++------ src/Deal/DealValidation.hs | 149 ++++++++++++++++++++++++++++++++++++- test/MainTest.hs | 2 + test/UT/DealTest.hs | 85 ++++++++++++++++++++- 5 files changed, 279 insertions(+), 57 deletions(-) diff --git a/src/Deal/DealQuery.hs b/src/Deal/DealQuery.hs index 6a099157..1a295b4c 100644 --- a/src/Deal/DealQuery.hs +++ b/src/Deal/DealQuery.hs @@ -578,24 +578,21 @@ queryCompound t@TestDeal{accounts=accMap, bonds=bndMap, ledgers=ledgersM, fees=f Right . toRational $ sum $ map ex stmts FeeTxnAmtBy d fns mCmt -> - let - fees = (feeMap Map.!) <$> fns -- Map.elems $ getFeeByName t (Just fns) - in - Right . toRational $ - case mCmt of - Just cmt -> sum [ queryTxnAmtAsOf fee d cmt | fee <- fees ] - Nothing -> - let - _txn = concat [ (DL.toList .getTxns)(F.feeStmt fee) | fee <- fees ] - in - sumTxn $ cutBy Inc Past d _txn + do + fees <- lookupVs fns feeMap + case mCmt of + Just cmt -> return . toRational $ sum [ queryTxnAmtAsOf fee d cmt | fee <- fees ] + Nothing -> + let + _txn = concat [ (DL.toList .getTxns)(F.feeStmt fee) | fee <- fees ] + in + return . toRational $ sumTxn $ cutBy Inc Past d _txn FeePaidAmt fns -> - let - fees = (feeMap Map.!) <$> fns - feeTxns = concat [ (DL.toList .getTxns) (F.feeStmt fee) | fee <- fees ] - in - Right . toRational $ sumTxn feeTxns + do + fees <- lookupVs fns feeMap + let feeTxns = concat [ (DL.toList .getTxns) (F.feeStmt fee) | fee <- fees ] + return . toRational $ sumTxn feeTxns BondTxnAmtBy d bns mCmt -> let @@ -611,28 +608,25 @@ queryCompound t@TestDeal{accounts=accMap, bonds=bndMap, ledgers=ledgersM, fees=f sumTxn $ cutBy Inc Past d _txn AccTxnAmtBy d ans mCmt -> - let - accs = (accMap Map.!) <$> ans - in - Right . toRational $ - case mCmt of - Just cmt -> sum [ queryTxnAmtAsOf acc d cmt | acc <- accs ] - Nothing -> - let - _txn = concat [ (DL.toList . getTxns) (A.accStmt acc) | acc <- accs ] - in - sumTxn $ cutBy Inc Past d _txn + do + accs <- lookupVs ans accMap + case mCmt of + Just cmt -> return . toRational $ sum [ queryTxnAmtAsOf acc d cmt | acc <- accs ] + Nothing -> + let + _txn = concat [ (DL.toList . getTxns) (A.accStmt acc) | acc <- accs ] + in + return . toRational $ sumTxn $ cutBy Inc Past d _txn LedgerTxnAmt lns mCmt -> case ledgersM of Nothing -> Left $ ("Date:"++show d++"No ledgers were modeled , failed to find ledger:"++show lns ) Just ledgerm -> - let - lgs = (ledgerm Map.!) <$> lns - in + do + lgs <- lookupVs lns ledgerm case mCmt of - Just cmt -> Right . toRational $ sum [ queryTxnAmt lg cmt | lg <- lgs ] - Nothing -> Right . toRational $ sum [ (snd . LD.ledgBalance) lg | lg <- lgs ] + Just cmt -> return . toRational $ sum [ queryTxnAmt lg cmt | lg <- lgs ] + Nothing -> return . toRational $ sum [ (snd . LD.ledgBalance) lg | lg <- lgs ] BondBalanceGapAt d bName -> queryCompound t rc d (Excess [CurrentBondBalanceOf [bName], BondBalanceTarget [bName]]) diff --git a/src/Deal/DealRun.hs b/src/Deal/DealRun.hs index 65efbef2..83781dd6 100644 --- a/src/Deal/DealRun.hs +++ b/src/Deal/DealRun.hs @@ -53,7 +53,8 @@ runEffects (t@TestDeal{accounts = accMap, fees = feeMap ,status=st, bonds = bond = case te of DealStatusTo _ds -> return (t {status = _ds}, rc, actions, logs) DoAccrueFee fns -> do - newFeeList <- traverse (calcDueFee t rc d) $ (feeMap Map.!) <$> fns + fees <- lookupVs fns feeMap + newFeeList <- traverse (calcDueFee t rc d) fees let newFeeMap = Map.fromList (zip fns newFeeList) <> feeMap return (t {fees = newFeeMap}, rc, actions, logs) @@ -473,11 +474,12 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= Nothing -> Left $ " No rate swaps modeled when looking for "++ sn Just rSwap -> do - acc <- case HE.rsSettleDates (rSwap Map.! sn) of + rs0 <- lookupM sn rSwap + acc <- case HE.rsSettleDates rs0 of Nothing -> Left $ "No settle date found for "++ sn - Just (_, _accName) -> return $ accMap Map.! _accName + Just (_, _accName) -> lookupM _accName accMap let accBal = A.accBalance acc - let rs = rSwap Map.! sn + let rs = rs0 let settleAmt = HE.rsNetCash rs let accName = A.accName acc case (settleAmt <0, accBal < abs settleAmt) of @@ -517,21 +519,16 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= run t rc (Just ads) calls $ DL.append log (DL.fromList newlog) ResetBondRate d bn -> - let - rateList = fromMaybe [] rates - bnd = bndMap Map.! bn - in - do - newBnd <- setBondNewRate t rc d rateList bnd - run t{bonds = Map.fromList [(bn,newBnd)] <> bndMap} rc (Just ads) calls log + do + bnd <- lookupM bn bndMap + newBnd <- setBondNewRate t rc d (fromMaybe [] rates) bnd + run t{bonds = Map.fromList [(bn,newBnd)] <> bndMap} rc (Just ads) calls log StepUpBondRate d bn -> - let - bnd = bndMap Map.! bn - in - do - newBndMap <- adjustM (setBondStepUpRate d (fromMaybe [] rates)) bn bndMap - run t{bonds = newBndMap } rc (Just ads) calls log + do + _ <- lookupM bn bndMap + newBndMap <- adjustM (setBondStepUpRate d (fromMaybe [] rates)) bn bndMap + run t{bonds = newBndMap } rc (Just ads) calls log ResetAccRate d accName -> do @@ -605,7 +602,8 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= newAcc = Map.adjust (A.deposit fundAmt d (FundWith bName fundAmt)) accName accMap in do - bndFunded <- draw d fundAmt (FundWith bName fundAmt) $ bndMap Map.! bName + bnd0 <- lookupM bName bndMap + bndFunded <- draw d fundAmt (FundWith bName fundAmt) bnd0 run t{accounts = newAcc, bonds = Map.insert bName bndFunded bndMap} rc (Just ads) calls log @@ -619,7 +617,8 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= False -> run t rc (Just ads) calls log True -> do - bndFunded <- draw d fundAmt (FundWith bName fundAmt) $ bndMap Map.! bName + bnd0 <- lookupM bName bndMap + bndFunded <- draw d fundAmt (FundWith bName fundAmt) bnd0 run t{accounts = newAcc, bonds = Map.insert bName bndFunded bndMap} rc (Just ads) calls log @@ -673,9 +672,10 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= newRate = L.getBeginRate iInfo in do - nBnd <- calcDueInt t rc d $ bndMap Map.! bName + bnd0 <- lookupM bName bndMap + nBnd <- calcDueInt t rc d bnd0 let dueIntToPay = L.getTotalDueInt nBnd - let acc = accMap Map.! accName + acc <- lookupM accName accMap let actualPayout = min (A.accBalance acc) dueIntToPay bnd1 <- pay d (DueTotalOf [DueInterest Nothing, DueArrears]) actualPayout nBnd let newBnd = set L.bndIntLens iInfo bnd1 diff --git a/src/Deal/DealValidation.hs b/src/Deal/DealValidation.hs index c679c91d..d836d44a 100644 --- a/src/Deal/DealValidation.hs +++ b/src/Deal/DealValidation.hs @@ -19,6 +19,7 @@ import Data.Maybe import qualified Waterfall as W import qualified CreditEnhancement as CE import qualified Liability as L +import qualified Triggers as Trg import qualified Accounts as A import qualified Expense as F import qualified Asset as P @@ -124,6 +125,139 @@ extractRequiredRevolvingPool t@TestDeal{waterfall = waterfallM} = (Set.unions $ fst <$> requiredByWaterfall, Set.unions $ snd <$> requiredByWaterfall) +-- | Names referenced by the deal definition, grouped by the map they should exist in. +-- Used to catch typos before a run instead of crashing mid-run. +data NameRefs = NameRefs { + refAccounts :: Set.Set String + , refFees :: Set.Set String + , refBonds :: Set.Set String + , refLiq :: Set.Set String + , refSwaps :: Set.Set String + , refCaps :: Set.Set String + } + +instance Semigroup NameRefs where + NameRefs a b c d e f <> NameRefs a' b' c' d' e' f' = + NameRefs (a <> a') (b <> b') (c <> c') (d <> d') (e <> e') (f <> f') +instance Monoid NameRefs where + mempty = NameRefs Set.empty Set.empty Set.empty Set.empty Set.empty Set.empty + mappend = (<>) + +refsOfAction :: W.Action -> NameRefs +refsOfAction a = case a of + W.Transfer _ a1 a2 _ -> accs [a1,a2] + W.TransferAndBook _ a1 a2 _ _ -> accs [a1,a2] + W.TransferMultiple srcs a2 _ -> accs (a2 : (snd <$> srcs)) + W.CalcFee fns -> fees fns + W.PayFee _ acc fns _ -> accs [acc] <> fees fns + W.PayFeeBySeq _ acc fns _ -> accs [acc] <> fees fns + W.CalcAndPayFee _ acc fns _ -> accs [acc] <> fees fns + W.PayFeeResidual _ acc fn -> accs [acc] <> fees [fn] + W.CalcBondInt bns -> bonds bns + W.CalcBondIntBy bn _ _ -> bonds [bn] + W.PayIntOverInt _ acc bns _ -> accs [acc] <> bonds bns + W.PayInt _ acc bns _ -> accs [acc] <> bonds bns + W.PayIntAndBook _ acc bns _ _ -> accs [acc] <> bonds bns + W.PayIntBySeq _ acc bns _ -> accs [acc] <> bonds bns + W.PayIntOverIntBySeq _ acc bns _ -> accs [acc] <> bonds bns + W.AccrueAndPayInt _ acc bns _ -> accs [acc] <> bonds bns + W.AccrueAndPayIntBySeq _ acc bns _ -> accs [acc] <> bonds bns + W.PayIntResidual _ acc bn -> accs [acc] <> bonds [bn] + W.PayIntByRateIndex _ acc bns _ _ -> accs [acc] <> bonds bns + W.PayIntByRateIndexBySeq _ acc bns _ _ -> accs [acc] <> bonds bns + W.CalcBondPrin _ acc bns _ -> accs [acc] <> bonds bns + W.CalcBondPrin2 _ bns -> bonds bns + W.PayPrinWithDue acc bns _ -> accs [acc] <> bonds bns + W.PayPrin _ acc bns _ -> accs [acc] <> bonds bns + W.PayPrinBySeq _ acc bns _ -> accs [acc] <> bonds bns + W.PayPrinResidual acc bns -> accs [acc] <> bonds bns + W.PayIntPrinBySeq _ acc bns _ -> accs [acc] <> bonds bns + W.AccrueAndPayIntPrinBySeq _ acc bns _ -> accs [acc] <> bonds bns + W.PayPrinGroup _ acc bn _ _ -> accs [acc] <> bonds [bn] + W.AccrueIntGroup bns -> bonds bns + W.PayIntGroup _ acc bn _ _ -> accs [acc] <> bonds [bn] + W.AccrueAndPayIntGroup _ acc bn _ _ -> accs [acc] <> bonds [bn] + W.WriteOff _ bn -> bonds [bn] + W.WriteOffAndBook _ bn _ -> bonds [bn] + W.WriteOffBySeq _ bns -> bonds bns + W.WriteOffBySeqAndBook _ bns _ -> bonds bns + W.FundWith _ acc bn -> accs [acc] <> bonds [bn] + W.BuyAsset _ _ acc _ -> accs [acc] + W.BuyAssetFrom _ _ acc _ _ -> accs [acc] + W.LiquidatePool _ acc _ -> accs [acc] + W.LiqSupport _ liq _ _ -> liqs [liq] + W.LiqRepay _ _ acc liq -> accs [acc] <> liqs [liq] + W.LiqYield _ acc liq -> accs [acc] <> liqs [liq] + W.LiqAccrue liqNames -> liqs liqNames + W.SwapAccrue ce -> swaps [ce] + W.SwapReceive acc ce -> accs [acc] <> swaps [ce] + W.SwapPay acc ce -> accs [acc] <> swaps [ce] + W.SwapSettle acc ce -> accs [acc] <> swaps [ce] + W.CollectRateCap acc ce -> accs [acc] <> caps [ce] + W.WithPay acc _ -> accs [acc] + W.ActionWithPre _ sub -> foldMap refsOfAction sub + W.ActionWithPre2 _ sa sb -> foldMap refsOfAction sa <> foldMap refsOfAction sb + _ -> mempty + where + accs xs = mempty { refAccounts = Set.fromList xs } + fees xs = mempty { refFees = Set.fromList xs } + bonds xs = mempty { refBonds = Set.fromList xs } + liqs xs = mempty { refLiq = Set.fromList xs } + swaps xs = mempty { refSwaps = Set.fromList xs } + caps xs = mempty { refCaps = Set.fromList xs } + +refsOfTriggerEffect :: Trg.TriggerEffect -> NameRefs +refsOfTriggerEffect te = case te of + Trg.DoAccrueFee fns -> mempty { refFees = Set.fromList fns } + Trg.ChangeReserveBalance acc _ -> mempty { refAccounts = Set.singleton acc } + Trg.CloseDeal _ _ (_, acc, _) _ -> mempty { refAccounts = Set.singleton acc } + Trg.BuyAsset acc _ -> mempty { refAccounts = Set.singleton acc } + Trg.ChangeBondRate bn _ _ -> mempty { refBonds = Set.singleton bn } + Trg.AddTrigger trg -> refsOfTriggerEffect (Trg.trgEffects trg) + Trg.TriggerEffects effs -> foldMap refsOfTriggerEffect effs + Trg.RunActions acts -> foldMap refsOfAction acts + _ -> mempty + +refsOfTrigger :: Trg.Trigger -> NameRefs +refsOfTrigger = refsOfTriggerEffect . Trg.trgEffects + +refsOfCollectRule :: CollectionRule -> NameRefs +refsOfCollectRule (Collect _ _ acc) = mempty { refAccounts = Set.singleton acc } +refsOfCollectRule (CollectByPct _ _ lst) = mempty { refAccounts = Set.fromList (snd <$> lst) } + +-- | Collect every deal-definition name reference and report the ones absent from the +-- corresponding deal map. Bond groups are accepted wherever a bond name is expected. +validateNameReferences :: P.Asset a => TestDeal a -> Set.Set BondName -> [ResultComponent] +validateNameReferences t@TestDeal{waterfall = waterfallM + ,accounts = accM + ,fees = feeM + ,collects = aggRule + ,liqProvider = liqProviderM + ,rateSwap = rsM + ,rateCap = rcM + ,triggers = triggerM} + extraBondNames + = let + refs = foldMap refsOfAction (concat (Map.elems waterfallM)) + <> foldMap refsOfCollectRule aggRule + <> maybe mempty (foldMap (foldMap refsOfTrigger)) triggerM + accNames = Map.keysSet accM + feeNames = Map.keysSet feeM + bondNames = Set.fromList (L.bndName <$> viewDealAllBonds t) <> Map.keysSet (view dealBondGroups t) <> extraBondNames + liqNames = maybe Set.empty Map.keysSet liqProviderM + swapNames = maybe Set.empty Map.keysSet rsM + capNames = maybe Set.empty Map.keysSet rcM + missing label set valid = + [ ErrorMsg (label ++ " not found in deal: " ++ x) | x <- Set.toList set, not (Set.member x valid) ] + in + missing "Account" (refAccounts refs) accNames + ++ missing "Fee" (refFees refs) feeNames + ++ missing "Bond/BondGroup" (refBonds refs) bondNames + ++ missing "Liquidity provider" (refLiq refs) liqNames + ++ missing "Rate swap" (refSwaps refs) swapNames + ++ missing "Rate cap" (refCaps refs) capNames + + validateReq :: (IR.UseRate a,P.Asset a) => TestDeal a -> AP.NonPerfAssumption -> (Bool,[ResultComponent]) validateReq t@TestDeal{accounts = accMap, fees = feeMap} assump@A.NonPerfAssumption{A.interest = intM, A.issueBondSchedule = mIssuePlan, A.revolving = mRevolvingAssump} @@ -174,14 +308,22 @@ validateReq t@TestDeal{accounts = accMap, fees = feeMap} Just (A.AvailableAssetsBy rMap ) -> [ ErrorMsg ("BuyAsset: Missing Revolving Pool in assumption" ++ show x) | x <- Set.toList (requiredRPoolNames Set.\\ Set.fromList (Map.keys rMap))] -- `debug` ("requiredRPoolNames 0> "++ show requiredRPoolNames) - (dealWarnings,dealErrors) = validatePreRun t + (dealWarnings,dealErrors) = validatePreRunWith t planBondNames finalErrors = missingIndexError ++ dealErrors ++ issuePlanError ++ feeErrors ++ revolvingBuyError finalWarnings = dealWarnings + planBondNames = case mIssuePlan of + Nothing -> Set.empty + Just evs -> Set.fromList [ L.bndName bnd | TsPoint _ (A.IssueBondEvent _ _ _ bnd _ _) <- evs ] in (null finalErrors,finalErrors++finalWarnings) validatePreRun :: P.Asset a => TestDeal a -> ([ResultComponent],[ResultComponent]) -validatePreRun t@TestDeal{waterfall=waterfallM +validatePreRun t = validatePreRunWith t Set.empty + +-- | Like 'validatePreRun' but treats @extraBondNames@ (e.g. bonds created by an +-- issuance plan during the run) as known, so they are not flagged as missing. +validatePreRunWith :: P.Asset a => TestDeal a -> Set.Set BondName -> ([ResultComponent],[ResultComponent]) +validatePreRunWith t@TestDeal{waterfall=waterfallM ,accounts =accM ,fees = feeM ,bonds = bondM @@ -194,6 +336,7 @@ validatePreRun t@TestDeal{waterfall=waterfallM ,pool = pool ,dates = dates ,status = status} + extraBondNames = let poolIds = getPoolIds t -- date check @@ -222,7 +365,7 @@ validatePreRun t@TestDeal{waterfall=waterfallM -- run result scan - allErrors = issuanceBalCheck dates ++ aggRuleResult + allErrors = issuanceBalCheck dates ++ aggRuleResult ++ validateNameReferences t extraBondNames -- check issuance balance w1 = if (not (isPreClosing t)) && (length (Map.elems (getIssuanceStats t Nothing))) == 0 then diff --git a/test/MainTest.hs b/test/MainTest.hs index 5f2578f8..77b7fcc1 100644 --- a/test/MainTest.hs +++ b/test/MainTest.hs @@ -86,6 +86,8 @@ tests = testGroup "Tests" [AT.mortgageTests ,DT.liqProviderTest ,DT.poolFlowTest ,DT.priceBondsIrrTest + ,DT.mapLookupSafetyTest + ,DT.validationNameTest ,DT2.queryTests ,UtilT.daycountTests1 ,UtilT.daycountTests2 diff --git a/test/UT/DealTest.hs b/test/UT/DealTest.hs index 074ac52d..5b80951b 100644 --- a/test/UT/DealTest.hs +++ b/test/UT/DealTest.hs @@ -1,4 +1,5 @@ -module UT.DealTest(td2,queryTests,triggerTests,dateTests,liqProviderTest,poolFlowTest,priceBondsIrrTest) +module UT.DealTest(td2,queryTests,triggerTests,dateTests,liqProviderTest,poolFlowTest,priceBondsIrrTest + ,mapLookupSafetyTest,validationNameTest) where @@ -6,6 +7,7 @@ import Test.Tasty import Test.Tasty.HUnit import Deal import Deal.DealQuery (queryCompound) +import Deal.DealValidation (validatePreRun) import qualified Accounts as A import qualified Stmt as Stmt @@ -24,6 +26,7 @@ import qualified Call as C import InterestRate import qualified CreditEnhancement as CE import qualified Triggers as Trg +import qualified Ledger as LD import Lib import Types @@ -411,3 +414,83 @@ priceBondsIrrTest = Left er -> assertFailure ("expected Right for known bond \"A\" but got: " ++ er) Right m -> assertEqual "should return a result for bond A" ["A"] (Map.keys m) ] + +mapLookupSafetyTest = + let + ctx = D.RunContext Map.empty Nothing Nothing + d0 = toDate "20220101" + dealWithLedger = baseDeal { D.ledgers = Just (Map.fromList [("L1", LD.Ledger "L1" (Debit, 0) Nothing)]) } + badTrg = Trg.Trigger (IfDate G (toDate "20220501")) (Trg.DoAccrueFee ["NONEXISTENTFEE"]) False False Nothing + tBadTrg = td2 { D.triggers = Just $ Map.fromList [(BeginDistributionWF, Map.fromList [("bad fee trigger", badTrg)])] } + poolflows = (CF.CashFlowFrame dummySt $ + [CF.MortgageDelinqFlow (toDate "20220201") 800 100 20 0 0 0 0 0 0.08 Nothing Nothing Nothing + ,CF.MortgageDelinqFlow (toDate "20220301") 700 100 20 0 0 0 0 0 0.08 Nothing Nothing Nothing + ,CF.MortgageDelinqFlow (toDate "20220401") 600 100 20 0 0 0 0 0 0.08 Nothing Nothing Nothing + ,CF.MortgageDelinqFlow (toDate "20220501") 500 100 20 0 0 0 0 0 0.08 Nothing Nothing Nothing + ,CF.MortgageDelinqFlow (toDate "20220601") 400 100 20 0 0 0 0 0 0.08 Nothing Nothing Nothing + ,CF.MortgageDelinqFlow (toDate "20220701") 300 100 20 0 0 0 0 0 0.08 Nothing Nothing Nothing + ] + ,Nothing) + poolflowM = Map.fromList [(PoolConsol, poolflows)] + ctxPool = D.RunContext poolflowM Nothing Nothing + ads = [PoolCollection (toDate "20220201") "" + ,RunWaterfall (toDate "20220225") "" + ,PoolCollection (toDate "20220301")"" + ,RunWaterfall (toDate "20220325") "" + ,PoolCollection (toDate "20220401")"" + ,RunWaterfall (toDate "20220425") "" + ,PoolCollection (toDate "20220501")"" + ,RunWaterfall (toDate "20220525") "" ] + in + testGroup "map lookup safety (missing names return Left)" + [ + testCase "ResetBondRate with missing bond returns Left" $ + assertBool "Left" (isLeft (run baseDeal ctx (Just [ResetBondRate d0 "NONEXISTENT"]) Nothing DL.empty)) + , testCase "StepUpBondRate with missing bond returns Left" $ + assertBool "Left" (isLeft (run baseDeal ctx (Just [StepUpBondRate d0 "NONEXISTENT"]) Nothing DL.empty)) + , testCase "FundBond with missing bond returns Left" $ + assertBool "Left" (isLeft (run baseDeal ctx (Just [FundBond d0 Nothing "NONEXISTENT" "General" 100]) Nothing DL.empty)) + , testCase "RefiBondRate with missing bond returns Left" $ + assertBool "Left" (isLeft (run baseDeal ctx (Just [RefiBondRate d0 "General" "NONEXISTENT" (L.Fix 0.08 DC_ACT_365F)]) Nothing DL.empty)) + , testCase "RefiBondRate with missing account returns Left" $ + assertBool "Left" (isLeft (run baseDeal ctx (Just [RefiBondRate d0 "NONEXISTENTACC" "A" (L.Fix 0.08 DC_ACT_365F)]) Nothing DL.empty)) + , testCase "DoAccrueFee trigger effect with missing fee returns Left" $ + assertBool "Left" (isLeft (run tBadTrg ctxPool (Just ads) Nothing DL.empty)) + , testCase "FeePaidAmt query with missing fee returns Left" $ + assertBool "Left" (isLeft (queryCompound baseDeal ctx d0 (FeePaidAmt ["NONEXISTENT"]))) + , testCase "FeeTxnAmtBy query with missing fee returns Left" $ + assertBool "Left" (isLeft (queryCompound baseDeal ctx d0 (FeeTxnAmtBy d0 ["NONEXISTENT"] Nothing))) + , testCase "AccTxnAmtBy query with missing account returns Left" $ + assertBool "Left" (isLeft (queryCompound baseDeal ctx d0 (AccTxnAmtBy d0 ["NONEXISTENT"] Nothing))) + , testCase "LedgerTxnAmt query with missing ledger returns Left" $ + assertBool "Left" (isLeft (queryCompound dealWithLedger ctx d0 (LedgerTxnAmt ["NONEXISTENT"] Nothing))) + , testCase "FeePaidAmt query with existing fee still works" $ + assertEqual "0" (Right 0 :: Either String Rational) (queryCompound td2 ctx d0 (FeePaidAmt ["Service-Fee"])) + , testCase "AccTxnAmtBy query with existing account still works" $ + assertEqual "0" (Right 0 :: Either String Rational) (queryCompound td2 ctx d0 (AccTxnAmtBy d0 ["General"] Nothing)) + , testCase "LedgerTxnAmt query with existing ledger still works" $ + assertEqual "0" (Right 0 :: Either String Rational) (queryCompound dealWithLedger ctx d0 (LedgerTxnAmt ["L1"] Nothing)) + ] + +validationNameTest = + let + errMsgs deal = let (_,errs) = validatePreRun deal in [ m | ErrorMsg m <- errs ] + nameErrs deal = [ m | m <- errMsgs deal, "not found in deal" `isInfixOf` m ] + badWaterfall = td2 { D.waterfall = Map.fromList [(W.DistributionDay Amortizing, [ W.PayInt Nothing "General" ["NONEXISTENTBOND"] Nothing ])] } + badTrigger = td2 { D.triggers = Just (Map.fromList [(BeginDistributionWF, Map.fromList [("t", Trg.Trigger (IfDate G (toDate "20220501")) (Trg.DoAccrueFee ["NONEXISTENTFEE"]) False False Nothing)])]) } + badCollect = td2 { D.collects = [ Collect Nothing W.CollectedInterest "NONEXISTENTACC" ] } + in + testGroup "pre-run name validation" + [ + testCase "waterfall referencing a missing bond is flagged" $ + assertBool ("expected a bond error, got: " ++ show (nameErrs badWaterfall)) + ("Bond/BondGroup not found in deal: NONEXISTENTBOND" `elem` nameErrs badWaterfall) + , testCase "trigger effect referencing a missing fee is flagged" $ + assertBool ("expected a fee error, got: " ++ show (nameErrs badTrigger)) + ("Fee not found in deal: NONEXISTENTFEE" `elem` nameErrs badTrigger) + , testCase "collect rule referencing a missing account is flagged" $ + assertBool ("expected an account error, got: " ++ show (nameErrs badCollect)) + ("Account not found in deal: NONEXISTENTACC" `elem` nameErrs badCollect) + , testCase "a valid deal has no name reference errors" $ + assertBool ("unexpected name errors: " ++ show (nameErrs td2)) (null (nameErrs td2)) + ] From d85cd9425cf0732d7d84c114c4ba64d51a07bfac Mon Sep 17 00:00:00 2001 From: yellowbean Date: Wed, 14 Oct 2026 11:22:37 +0800 Subject: [PATCH 16/40] fix #335 --- src/Deal/DealValidation.hs | 2 +- test/MainTest.hs | 1 + test/UT/DealTest.hs | 25 ++++++++++++++++++++++++- 3 files changed, 26 insertions(+), 2 deletions(-) diff --git a/src/Deal/DealValidation.hs b/src/Deal/DealValidation.hs index d836d44a..0a2fae0b 100644 --- a/src/Deal/DealValidation.hs +++ b/src/Deal/DealValidation.hs @@ -75,7 +75,7 @@ validateAggRule rules validPids = countWeight (CollectByPct (Just pids) ps lst) = Map.fromList [((pid,ps), pct) | pid <- pids, pct <- fst <$> lst] countWeight (CollectByPct Nothing ps lst) = Map.fromList [((PoolConsol, ps),pct)| pct <- fst <$> lst] - sumMap = foldl1 (Map.unionWith (+)) $ countWeight <$> rules + sumMap = foldl (Map.unionWith (+)) Map.empty $ countWeight <$> rules oustandingPs = Map.filter (> 1.0) sumMap getPids (Collect (Just pids) _ _) = pids diff --git a/test/MainTest.hs b/test/MainTest.hs index 77b7fcc1..6004ea72 100644 --- a/test/MainTest.hs +++ b/test/MainTest.hs @@ -88,6 +88,7 @@ tests = testGroup "Tests" [AT.mortgageTests ,DT.priceBondsIrrTest ,DT.mapLookupSafetyTest ,DT.validationNameTest + ,DT.aggRuleValidationTest ,DT2.queryTests ,UtilT.daycountTests1 ,UtilT.daycountTests2 diff --git a/test/UT/DealTest.hs b/test/UT/DealTest.hs index 5b80951b..212b268d 100644 --- a/test/UT/DealTest.hs +++ b/test/UT/DealTest.hs @@ -1,5 +1,5 @@ module UT.DealTest(td2,queryTests,triggerTests,dateTests,liqProviderTest,poolFlowTest,priceBondsIrrTest - ,mapLookupSafetyTest,validationNameTest) + ,mapLookupSafetyTest,validationNameTest,aggRuleValidationTest) where @@ -494,3 +494,26 @@ validationNameTest = , testCase "a valid deal has no name reference errors" $ assertBool ("unexpected name errors: " ++ show (nameErrs td2)) (null (nameErrs td2)) ] + +aggRuleValidationTest = + let + errMsgs deal = let (_,errs) = validatePreRun deal in [ m | ErrorMsg m <- errs ] + aggErrs deal = [ m | m <- errMsgs deal, "Pool source" `isInfixOf` m || "Pool Id not found" `isInfixOf` m ] + in + testGroup "collection rule validation" + [ + testCase "normal collect rules validate with no errors" $ + assertBool ("unexpected errors: " ++ show (aggErrs baseDeal)) (null (aggErrs baseDeal)) + , testCase "a deal with empty collects does not crash and reports no errors" $ + let deal = baseDeal { D.collects = [] } + in assertBool ("unexpected errors: " ++ show (aggErrs deal)) (null (aggErrs deal)) + , testCase "over-weighted collect source is flagged" $ + let deal = baseDeal { D.collects = [ Collect Nothing W.CollectedInterest "General" + , Collect Nothing W.CollectedInterest "General" ] } + in assertBool ("expected a weight error, got: " ++ show (aggErrs deal)) + (any ("has a weight of" `isInfixOf`) (aggErrs deal)) + , testCase "unknown pool id in a collect rule is flagged" $ + let deal = baseDeal { D.collects = [ Collect (Just [PoolName "NOPE"]) W.CollectedInterest "General" ] } + in assertBool ("expected a pool id error, got: " ++ show (aggErrs deal)) + (any ("Pool Id not found" `isInfixOf`) (aggErrs deal)) + ] From cf050b2590a3a68843cdfd7c68caa2542527a334 Mon Sep 17 00:00:00 2001 From: yellowbean Date: Wed, 14 Oct 2026 12:01:03 +0800 Subject: [PATCH 17/40] Fix#346: add para support on endpoints --- app/Main.hs | 31 ++++++++++++++++++++----------- src/Util.hs | 18 +++++++++++++++++- test/MainTest.hs | 1 + test/UT/UtilTest.hs | 20 +++++++++++++++++++- 4 files changed, 57 insertions(+), 13 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index badd3e83..c5a0b70f 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -56,6 +56,7 @@ import Servant.API.ContentTypes (contentType) import Types import MainBase +import Util (boundedParMap) import qualified Deal as D import qualified Deal.DealBase as DB import qualified Deal.DealDate as DD @@ -202,6 +203,14 @@ engineSwagger = toOpenApi engineAPI showVersion :: Handler Version showVersion = return version1 +-- | Upper bound on the number of scenarios/deals evaluated concurrently, i.e. +-- on in-flight sparks. The RTS itself limits real concurrency to @-N@ +-- capabilities; this cap is what prevents unbounded spark creation for large +-- grids (e.g. 'runDealByCombo's cartesian product). Raise/lower here to tune +-- memory vs throughput. +maxParallelWorkers :: Int +maxParallelWorkers = 8 + runAsset :: RunAssetReq -> Handler RunAssetResp runAsset req = return $ wrapRunAsset req @@ -212,8 +221,9 @@ runPool (SingleRunPoolReq f pt passumption mRates) runPoolScenarios :: RunPoolReq -> Handler (Map.Map ScenarioName PoolRunResp) runPoolScenarios (MultiScenarioRunPoolReq f pt mAssumps mRates) - = return $ Map.map (\assump -> patchCumulativeToPoolRun <$> wrapRunPoolType f pt (Just assump) mRates) - mAssumps + = return $ boundedParMap maxParallelWorkers + (\assump -> patchCumulativeToPoolRun <$> wrapRunPoolType f pt (Just assump) mRates) + mAssumps runDeal :: RunDealReq -> Handler RunResp runDeal (SingleRunReq f dt assump nonPerfAssump) = return $ wrapRun f dt assump nonPerfAssump @@ -399,11 +409,11 @@ runRootFinderBy (RootFinderReq req@(dt,Just assumps,nonPerfAssump@AP.NonPerfAssu runDealScenarios :: RunDealReq -> Handler (Map.Map ScenarioName RunResp) runDealScenarios (MultiScenarioRunReq f dt mAssumps nonPerfAssump) - = return $ Map.map (\singleAssump -> wrapRun f dt (Just singleAssump) nonPerfAssump) mAssumps + = return $ boundedParMap maxParallelWorkers (\singleAssump -> wrapRun f dt (Just singleAssump) nonPerfAssump) mAssumps runMultiDeals :: RunDealReq -> Handler (Map.Map ScenarioName RunResp) runMultiDeals (MultiDealRunReq f mDts assump nonPerfAssump) - = return $ Map.map (\singleDealType -> wrapRun f singleDealType assump nonPerfAssump) mDts + = return $ boundedParMap maxParallelWorkers (\singleDealType -> wrapRun f singleDealType assump nonPerfAssump) mDts runDate :: RunDateReq -> Handler [Date] runDate (RunDateReq sd dp md) @@ -414,18 +424,17 @@ runDate (RunDateReq sd dp md) runDealByRunScenarios :: RunDealReq -> Handler (Map.Map ScenarioName RunResp) runDealByRunScenarios (MultiRunAssumpReq f dt mAssump nonPerfAssumpMap) - = return $ Map.map (wrapRun f dt mAssump) nonPerfAssumpMap + = return $ boundedParMap maxParallelWorkers (wrapRun f dt mAssump) nonPerfAssumpMap runDealByCombo :: RunDealReq -> Handler (Map.Map String RunResp) runDealByCombo (MultiComboReq f dMap assumpMap nonPerfAssumpMap) = let - dList = Map.toList dMap - aList = Map.toList assumpMap - nList = Map.toList nonPerfAssumpMap - r = [ (intercalate "^" [dk,ak,nk], wrapRun f d a n) | (dk,d) <- dList, (ak,a) <- aList, (nk,n) <- nList ] - rMap = Map.fromList r + inputs = Map.fromList [ (intercalate "^" [dk,ak,nk], (d,a,n)) + | (dk,d) <- Map.toList dMap + , (ak,a) <- Map.toList assumpMap + , (nk,n) <- Map.toList nonPerfAssumpMap ] in - return rMap + return $ boundedParMap maxParallelWorkers (\(d,a,n) -> wrapRun f d a n) inputs myServer :: ServerT API Handler myServer = return engineSwagger diff --git a/src/Util.hs b/src/Util.hs index e7323e18..72e8c832 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -13,7 +13,7 @@ module Util ,lastOf,findBox,safeDivide', safeDiv ,safeDivide,lstToMapByFn,paySequentially,payProRata,mapWithinMap ,payInMap,payInMapM,adjustM,adjustMs,mapInMapM,lookupAndApply,lookupAndUpdate,lookupAndApplies - ,lookupInMap,selectInMap,scaleByFstElement + ,lookupInMap,selectInMap,scaleByFstElement,boundedParMap ,lookupTuple6 ,lookupTuple7,diffNum,splitBal,lookupM,lookupVs ,lookupMM -- for debug @@ -37,6 +37,7 @@ import Numeric.Limits (infinity) import Text.Printf import Control.Exception +import Control.Parallel.Strategies (parBuffer, rseq, using) import Data.Time (addDays) import Debug.Trace debug = flip trace @@ -261,6 +262,21 @@ scaleByFstElement y (b:xs) = debugLine :: Show a => [a] -> String debugLine xs = "" +-- | Like 'Map.map' but evaluates the mapped values in parallel, keeping at most +-- @n@ computations in flight at once. Bounding the in-flight work avoids spark +-- explosion when mapping over large scenario/deal grids (e.g. cartesian products). +-- +-- The bound is on in-flight *sparks*, not on OS threads: real concurrency is +-- still limited by the RTS capabilities (@-N@). Values are forced only to WHNF, +-- which is enough for computations expressed in a strict monad such as 'Either' +-- (e.g. 'runDeal'), where reducing the result to a constructor runs the work; +-- deeply-lazy results would need an 'NFData'-based variant instead. +boundedParMap :: Ord k => Int -> (a -> b) -> Map.Map k a -> Map.Map k b +boundedParMap n f m = + let (ks, vs) = unzip (Map.toList m) + vs' = (map f vs) `using` parBuffer (max 1 n) rseq + in Map.fromList (zip ks vs') + lastOf:: [a] -> (a->Bool) -> Maybe a lastOf [] fn = Nothing lastOf xs fn = diff --git a/test/MainTest.hs b/test/MainTest.hs index 6004ea72..2fc79b1b 100644 --- a/test/MainTest.hs +++ b/test/MainTest.hs @@ -109,6 +109,7 @@ tests = testGroup "Tests" [AT.mortgageTests ,UtilT.paySeqTest ,UtilT.scaleListTest ,UtilT.mapUpdateTest + ,UtilT.boundedParMapTest ,AccT.intTests ,AccT.investTests ,AccT.reserveAccTest diff --git a/test/UT/UtilTest.hs b/test/UT/UtilTest.hs index d67a6c3d..7bbb5f46 100644 --- a/test/UT/UtilTest.hs +++ b/test/UT/UtilTest.hs @@ -3,7 +3,7 @@ module UT.UtilTest(daycountTests1,daycountTests2,daycountTests3,daycountTests4 ,tsTest,ts2Test,ts3Test,dateVectorPatternTest,paddingTest,dateSliceTest ,capTest,roundingTest,sliceTest,splitTsTest,tableTest,lastOftest,paySeqTest - ,scaleListTest,mapUpdateTest)--,daycountTests3,daycountTests4) + ,scaleListTest,mapUpdateTest,boundedParMapTest)--,daycountTests3,daycountTests4) where import Test.Tasty @@ -695,4 +695,22 @@ mapUpdateTest = assertEqual "mapInMapM - Test - 3" True (isLeft (mapInMapM fn' [3] m)) + ] + +boundedParMapTest = + let + m = Map.fromList [(1::Int,10::Int),(2,20),(3,30),(4,40),(5,50)] + f x = x * x + in + testGroup "boundedParMap" + [ testCase "matches Map.map for a normal bound" $ + assertEqual "same result" (Map.map f m) (boundedParMap 4 f m) + , testCase "matches Map.map with bound 1 (serial)" $ + assertEqual "same result" (Map.map f m) (boundedParMap 1 f m) + , testCase "matches Map.map with bound larger than the map" $ + assertEqual "same result" (Map.map f m) (boundedParMap 100 f m) + , testCase "empty map yields empty map" $ + assertEqual "empty" (Map.empty :: Map.Map Int Int) (boundedParMap 4 f (Map.empty :: Map.Map Int Int)) + , testCase "preserves keys order-independently" $ + assertEqual "keys" (Map.keys m) (Map.keys (boundedParMap 3 f m)) ] \ No newline at end of file From 1ee1ff9744432b4dd6554f80f2e08d5226ef35ac Mon Sep 17 00:00:00 2001 From: yellowbean Date: Wed, 14 Oct 2026 12:30:27 +0800 Subject: [PATCH 18/40] fix #348 --- app/Main.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index c5a0b70f..58642085 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -96,12 +96,14 @@ import Cashflow (patchCumulative) import Numeric.RootFinding +import qualified Data.Version as DV +import qualified Paths_Hastructure as Paths + import Debug.Trace debug = flip Debug.Trace.trace - version1 :: Version -version1 = Version "0.52.7" +version1 = Version (DV.showVersion Paths.version) wrapRun :: [D.ExpectReturn] -> DealType -> Maybe AP.ApplyAssumptionType -> AP.NonPerfAssumption -> RunResp From f046cb6aa52e838e24f9a0f32d98cad5ca0bf782 Mon Sep 17 00:00:00 2001 From: yellowbean Date: Wed, 14 Oct 2026 16:58:31 +0800 Subject: [PATCH 19/40] fix #352 --- src/Deal/DealValidation.hs | 26 ++++++++--------------- src/Validation.hs | 42 -------------------------------------- 2 files changed, 8 insertions(+), 60 deletions(-) delete mode 100644 src/Validation.hs diff --git a/src/Deal/DealValidation.hs b/src/Deal/DealValidation.hs index 0a2fae0b..68f6ac56 100644 --- a/src/Deal/DealValidation.hs +++ b/src/Deal/DealValidation.hs @@ -3,9 +3,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TemplateHaskell #-} module Deal.DealValidation (validateRun,validatePreRun,validateReq) where @@ -32,13 +29,6 @@ import Deal.DealCollection (CollectionRule(..)) import Control.Lens hiding (element) import Control.Lens.TH -import Data.Maybe -import qualified Assumptions as A - - -import Debug.Trace -debug = flip trace - extractRequiredRates :: (P.Asset a,IR.UseRate a) => TestDeal a -> Set.Set Types.Index extractRequiredRates t@TestDeal{accounts = accM ,fees = feeM @@ -260,7 +250,7 @@ validateNameReferences t@TestDeal{waterfall = waterfallM validateReq :: (IR.UseRate a,P.Asset a) => TestDeal a -> AP.NonPerfAssumption -> (Bool,[ResultComponent]) validateReq t@TestDeal{accounts = accMap, fees = feeMap} - assump@A.NonPerfAssumption{A.interest = intM, A.issueBondSchedule = mIssuePlan, A.revolving = mRevolvingAssump} + assump@AP.NonPerfAssumption{AP.interest = intM, AP.issueBondSchedule = mIssuePlan, AP.revolving = mRevolvingAssump} = let ratesRequired = extractRequiredRates t ratesSupplied = case intM of @@ -280,18 +270,18 @@ validateReq t@TestDeal{accounts = accMap, fees = feeMap} Nothing -> [] Just issueBndEventlist -> let - bgNamesInAssump = Set.fromList $ [ bgName | TsPoint d (A.IssueBondEvent _ bgName _ bnd _ _) <- issueBndEventlist ] + bgNamesInAssump = Set.fromList $ [ bgName | TsPoint d (AP.IssueBondEvent _ bgName _ bnd _ _) <- issueBndEventlist ] bgNameErrors = [ ErrorMsg ("issueBond:Missing Bond Group Name in Deal:"++ missingBgName ) | missingBgName <- Set.elems (Set.difference bgNamesInAssump bgNamesInDeal)] - newBndNames = Set.fromList $ [ L.bndName bnd | TsPoint d (A.IssueBondEvent _ _ _ bnd _ _) <- issueBndEventlist ] + newBndNames = Set.fromList $ [ L.bndName bnd | TsPoint d (AP.IssueBondEvent _ _ _ bnd _ _) <- issueBndEventlist ] existingBndNames = Set.fromList $ L.bndName <$> viewDealAllBonds t bndNameErrors = [ ErrorMsg ("issueBond:Existing Bond Name in Deal:"++ existsBndName ) | existsBndName <- Set.elems (Set.intersection newBndNames existingBndNames)] - acNamesInAssump = Set.fromList $ [ acName | TsPoint d (A.IssueBondEvent _ _ acName _ _ _) <- issueBndEventlist ] + acNamesInAssump = Set.fromList $ [ acName | TsPoint d (AP.IssueBondEvent _ _ acName _ _ _) <- issueBndEventlist ] existingAccNames = Map.keysSet accMap accNameErrors = [ ErrorMsg ("issueBond:Missing Account Name in Deal:"++ missingAccName ) | missingAccName <- Set.elems (Set.difference acNamesInAssump existingAccNames)] - bndNamesInAssump = [ L.bndName bnd | TsPoint d (A.IssueBondEvent _ bgName _ bnd _ _) <- issueBndEventlist ] + bndNamesInAssump = [ L.bndName bnd | TsPoint d (AP.IssueBondEvent _ bgName _ bnd _ _) <- issueBndEventlist ] bndUniqNames = Set.fromList bndNamesInAssump dupNamesErrors = [ ErrorMsg("Duplicate Bond Names in Funding Plan") | length bndUniqNames /= length bndNamesInAssump] in @@ -304,8 +294,8 @@ validateReq t@TestDeal{accounts = accMap, fees = feeMap} in case mRevolvingAssump of Nothing -> [] - Just (A.AvailableAssets _ _ ) -> [ ErrorMsg ("BuyAsset: Missing Pool Id in assumption" ++ show x) | x <- Set.toList (requiredPoolIds Set.\\ Set.fromList (getPoolIds t))] - Just (A.AvailableAssetsBy rMap ) -> [ ErrorMsg ("BuyAsset: Missing Revolving Pool in assumption" ++ show x) | x <- Set.toList (requiredRPoolNames Set.\\ Set.fromList (Map.keys rMap))] -- `debug` ("requiredRPoolNames 0> "++ show requiredRPoolNames) + Just (AP.AvailableAssets _ _ ) -> [ ErrorMsg ("BuyAsset: Missing Pool Id in assumption" ++ show x) | x <- Set.toList (requiredPoolIds Set.\\ Set.fromList (getPoolIds t))] + Just (AP.AvailableAssetsBy rMap ) -> [ ErrorMsg ("BuyAsset: Missing Revolving Pool in assumption" ++ show x) | x <- Set.toList (requiredRPoolNames Set.\\ Set.fromList (Map.keys rMap))] -- `debug` ("requiredRPoolNames 0> "++ show requiredRPoolNames) (dealWarnings,dealErrors) = validatePreRunWith t planBondNames @@ -313,7 +303,7 @@ validateReq t@TestDeal{accounts = accMap, fees = feeMap} finalWarnings = dealWarnings planBondNames = case mIssuePlan of Nothing -> Set.empty - Just evs -> Set.fromList [ L.bndName bnd | TsPoint _ (A.IssueBondEvent _ _ _ bnd _ _) <- evs ] + Just evs -> Set.fromList [ L.bndName bnd | TsPoint _ (AP.IssueBondEvent _ _ _ bnd _ _) <- evs ] in (null finalErrors,finalErrors++finalWarnings) diff --git a/src/Validation.hs b/src/Validation.hs deleted file mode 100644 index c773d93e..00000000 --- a/src/Validation.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TemplateHaskell #-} - -module Validation () - where - -import Deal.DealBase -import Types -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.Maybe - -import qualified Waterfall as W -import qualified CreditEnhancement as CE -import qualified Liability as L -import qualified Accounts as A -import qualified Expense as F -import qualified Asset as P -import qualified Assumptions as AP -import qualified InterestRate as IR - -import Control.Lens hiding (element) -import Control.Lens.TH - -import Data.Maybe -import qualified Assumptions as A - - -import Debug.Trace -debug = flip trace - - - --- valAssetRunReq :: (IR.UseRate a,P.Asset a) => TestDeal a -> AP.NonPerfAssumption -> (Bool,[ResultComponent]) --- valAssetRunReq t@TestDeal{accounts = accMap} assump@A.NonPerfAssumption{A.interest = intM, A.issueBondSchedule = mIssuePlan} --- = let \ No newline at end of file From a6554a81305a2e9c10406344fd8cb54664d61745 Mon Sep 17 00:00:00 2001 From: yellowbean Date: Wed, 14 Oct 2026 18:45:29 +0800 Subject: [PATCH 20/40] cabal updat --- Hastructure.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/Hastructure.cabal b/Hastructure.cabal index 56626b1c..8c40dfd0 100644 --- a/Hastructure.cabal +++ b/Hastructure.cabal @@ -69,7 +69,6 @@ library Triggers Types Util - Validation Waterfall other-modules: Paths_Hastructure From 3bb176a0daee8809349742600566572a041156fa Mon Sep 17 00:00:00 2001 From: yellowbean Date: Wed, 14 Oct 2026 19:51:17 +0800 Subject: [PATCH 21/40] UT: collected-CF safety tests (buildCollectedCF empty groups / padding) --- test/UT/PoolTest.hs | 104 ++++++++++++++++++++++++++++++-------------- 1 file changed, 72 insertions(+), 32 deletions(-) diff --git a/test/UT/PoolTest.hs b/test/UT/PoolTest.hs index 7f927c61..d2e12614 100644 --- a/test/UT/PoolTest.hs +++ b/test/UT/PoolTest.hs @@ -63,6 +63,60 @@ poolTest = "each asset defaults its full current balance" [100, 300] (totalDefaults <$> proj) + , testCase "pool DefaultByAmt with a zero-balance asset allocates nothing to it" $ + case P.runPool zeroBalPool (Just (assumpWith 80 [1])) Nothing of + Left err -> assertFailure err + Right proj -> + assertEqual + "pro-rata over balances [0,100,300] for a total default of 80" + [0, 20, 60] + (totalDefaults <$> proj) + , testCase "pool DefaultByAmt rounding residual goes to the first asset and preserves the total" $ + case P.runPool tiePool (Just (assumpWith 100 [1])) Nothing of + Left err -> assertFailure err + Right proj -> + let ds = totalDefaults <$> proj + in do + assertEqual + "largest-remainder tie breaks by asset index (first asset gets the extra cent)" + [33.34, 33.33, 33.33] + ds + assertEqual "allocations sum to the requested total" 100 (sum ds) + , testCase "pool DefaultByAmt across a single asset allocates the full amount" $ + case P.runPool singlePool (Just (assumpWith 40 [1])) Nothing of + Left err -> assertFailure err + Right proj -> + assertEqual "one asset gets the whole default" [40] (totalDefaults <$> proj) + , testCase "pool DefaultByAmt with an empty pool and positive total fails with Left" $ + case P.runPool emptyPool (Just (assumpWith 40 [1])) Nothing of + Left err -> + assertBool + ("error should mention the pool total: " ++ err) + ("exceeds total current balance" `isInfixOf` err) + Right _ -> + assertFailure "expected Left for an empty pool with a positive default" + , testCase "pool DefaultByAmt with an empty pool and zero total returns no projections" $ + case P.runPool emptyPool (Just (assumpWith 0 [1])) Nothing of + Left err -> assertFailure err + Right proj -> assertEqual "no assets to project" [] proj + , testCase "pool DefaultByAmt of zero allocates zero to every asset" $ + case P.runPool pool (Just (assumpWith 0 [1])) Nothing of + Left err -> assertFailure err + Right proj -> assertEqual "no defaults" [0, 0] (totalDefaults <$> proj) + , testCase "pool DefaultByAmt applies multi-period weights per asset" $ + case P.runPool pool (Just (assumpWith 40 [0.5, 0.5])) Nothing of + Left err -> assertFailure err + Right proj -> do + assertEqual + "positive per-period defaults follow the weights of each allocated amount" + [[5, 5], [15, 15]] + (positiveDefaults <$> proj) + assertEqual "per-asset totals" [10, 30] (totalDefaults <$> proj) + , testCase "pool DefaultByAmt with a negative total currently clamps to zero allocations" $ + case P.runPool pool (Just (assumpWith (-5) [1])) Nothing of + Left err -> assertFailure err + Right proj -> + assertEqual "negative total is clamped to no defaults" [0, 0] (totalDefaults <$> proj) ] where pool = @@ -77,49 +131,32 @@ poolTest = smallPool = pool {P.assets = replicate 12 (mortgage 0.01)} + zeroBalPool = pool {P.assets = [mortgage 0, mortgage 100, mortgage 300]} + + tiePool = pool {P.assets = [mortgage 100, mortgage 100, mortgage 100]} + + singlePool = pool {P.assets = [mortgage 100]} + + emptyPool = pool {P.assets = ([] :: [AB.Mortgage])} + schedulePool = pool { P.assets = [scheduleMortgage 100, scheduleMortgage 300] , P.asOfDate = L.toDate "20240101" } - defaultAss = - A.PoolLevel - ( A.MortgageAssump - (Just (A.DefaultByAmt (40, [1]))) - Nothing - Nothing - Nothing - , A.DummyDelinqAssump - , A.DummyDefaultAssump - ) + defaultAss = assumpWith 40 [1] - smallDefaultAss = - A.PoolLevel - ( A.MortgageAssump - (Just (A.DefaultByAmt (0.10, [1]))) - Nothing - Nothing - Nothing - , A.DummyDelinqAssump - , A.DummyDefaultAssump - ) + smallDefaultAss = assumpWith 0.10 [1] - overDefaultAss = - A.PoolLevel - ( A.MortgageAssump - (Just (A.DefaultByAmt (500, [1]))) - Nothing - Nothing - Nothing - , A.DummyDelinqAssump - , A.DummyDefaultAssump - ) + overDefaultAss = assumpWith 500 [1] + + exactDefaultAss = assumpWith 400 [1] - exactDefaultAss = + assumpWith total vs = A.PoolLevel ( A.MortgageAssump - (Just (A.DefaultByAmt (400, [1]))) + (Just (A.DefaultByAmt (total, vs))) Nothing Nothing Nothing @@ -155,3 +192,6 @@ poolTest = totalDefaults (CF.CashFlowFrame _ txns, _) = sum (CF.mflowDefault <$> txns) + + positiveDefaults (CF.CashFlowFrame _ txns, _) = + filter (> 0) (CF.mflowDefault <$> txns) From 612149c371cbe6730a195940e9b066625444886d Mon Sep 17 00:00:00 2001 From: yellowbean Date: Wed, 14 Oct 2026 20:06:53 +0800 Subject: [PATCH 22/40] bump version to-> < 0.52.8 > --- CHANGELOG.md | 15 +++++++++++++++ Hastructure.cabal | 2 +- 2 files changed, 16 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 07fa5e96..c7d77b4b 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,21 @@ # Changelog for Hastructure +## 0.52.7 +### 2026-10-17 +* ENHANCE: #346 enable parallel compute on multi-deals and multi-scenarios +* ENHANCE: #333 validate bond / account / fee / ledger / swap names referenced by waterfall actions, collect rules, trigger effects and formulas before the run, reporting every missing name up-front +* ENHANCE: #348 source the engine version from the package (`Paths_Hastructure`) instead of a hardcoded string, so `/version` and the OpenAPI schema always match the built package +* ENHANCE: #352 remove the empty `Validation` module and de-duplicate pragmas / imports in `Deal.DealValidation` +* FIX: #327 IRR bond pricing (`priceBonds`) no longer crashes when a requested bond name does not exist; it returns a descriptive error +* FIX: #331 `mflowBorrowerNum` / `mflowPrepaymentPenalty` no longer fail with `undefined` on non-mortgage cashflow rows +* FIX: #325 `Weekly` / `BiWeekly` / `Daily` periods are now handled by `periodRateFromAnnualRate`, `afterNPeriod`, `genDates` and `nextDate` (previously a pattern-match failure or a silently non-advancing schedule) +* FIX: #333 missing bond / account / fee / ledger / swap names used by waterfall actions, trigger effects and formulas now return a descriptive error instead of crashing with `Map.!: not found` +* FIX: #335 deal validation no longer crashes with `foldl1: empty list` when a deal has no collection rules +* FIX: harden `head` / `last` usages across the engine (curves, statements, date generation, asset projections, bond WAL, deal dates and cashflow aggregation) so empty input yields a defined result or a typed error instead of a runtime exception +* FIX: extend pool-level `DefaultByAmt` pro-rata allocation coverage with edge-case unit tests (cent rounding, zero-balance assets, empty pool, multi-period weights, negative totals) (#321) + + ## 0.52.6 ### 2026-09-27 * NEW: add new prepayment assumption `PrepaymentABS`, an ABS / absolute prepayment model driven by the asset's seasoning (months elapsed since origin). Supported for `Monthly` assets only. diff --git a/Hastructure.cabal b/Hastructure.cabal index 8c40dfd0..13d6711c 100644 --- a/Hastructure.cabal +++ b/Hastructure.cabal @@ -5,7 +5,7 @@ cabal-version: 3.0 -- see: https://github.com/sol/hpack name: Hastructure -version: 0.52.7 +version: 0.52.8 synopsis: Cashflow modeling library for structured finance description: Please see the README on GitHub at category: StructuredFinance,Securitisation,Cashflow From 51936363c46d485dc5fddbbdd4f5074c936a36ae Mon Sep 17 00:00:00 2001 From: yellowbean Date: Fri, 16 Oct 2026 16:01:36 +0800 Subject: [PATCH 23/40] Fix#353: default NonPerfAssumption/RunContext, -Werror=missing-fields, test fixtures --- Hastructure.cabal | 5 ++-- app/Main.hs | 16 +++++------ src/Assumptions.hs | 24 ++++++++++++++++ src/Deal/DealBase.hs | 6 +++- test/DealTest/DealTest.hs | 10 +++---- test/DealTest/MultiPoolDealTest.hs | 10 +++---- test/DealTest/ResecDealTest.hs | 12 ++++---- test/DealTest/RevolvingTest.hs | 12 ++++---- test/MainTest.hs | 1 + test/UT/AccountTest.hs | 2 +- test/UT/CashflowTest.hs | 12 ++++---- test/UT/DealTest.hs | 45 ++++++++++++++++++++++-------- test/UT/DealTest2.hs | 16 +++++------ test/UT/ExpTest.hs | 4 +-- test/UT/RateHedgeTest.hs | 2 +- 15 files changed, 114 insertions(+), 63 deletions(-) diff --git a/Hastructure.cabal b/Hastructure.cabal index 13d6711c..150d9d6e 100644 --- a/Hastructure.cabal +++ b/Hastructure.cabal @@ -76,6 +76,7 @@ library Paths_Hastructure hs-source-dirs: src + ghc-options: -Werror=missing-fields build-depends: Decimal >= 0.5.2 && < 0.6, base >= 4.18.0 && < 4.22.0, @@ -127,7 +128,7 @@ executable Hastructure-exe Paths_Hastructure hs-source-dirs: app - ghc-options: -threaded -rtsopts -with-rtsopts=-N + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Werror=missing-fields build-depends: Hastructure, Decimal, @@ -200,7 +201,7 @@ test-suite Hastructure-test Paths_Hastructure hs-source-dirs: test - ghc-options: -threaded -rtsopts -with-rtsopts=-N + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Werror=missing-fields build-depends: Hastructure, Decimal, diff --git a/app/Main.hs b/app/Main.hs index 58642085..3aa89d14 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -149,14 +149,14 @@ patchCumulativeToPoolRun -- flag -> breakdown flag wrapRunPoolType :: Bool -> PoolTypeWrap -> Maybe AP.ApplyAssumptionType -> Maybe [RateAssumption] -> RunPoolTypeRtn -wrapRunPoolType flag (MPool pt) assump mRates = D.runPoolType flag pt assump $ Just (AP.NonPerfAssumption{AP.interest = mRates}) -wrapRunPoolType flag (LPool pt) assump mRates = D.runPoolType flag pt assump $ Just (AP.NonPerfAssumption{AP.interest = mRates}) -wrapRunPoolType flag (IPool pt) assump mRates = D.runPoolType flag pt assump $ Just (AP.NonPerfAssumption{AP.interest = mRates}) -wrapRunPoolType flag (RPool pt) assump mRates = D.runPoolType flag pt assump $ Just (AP.NonPerfAssumption{AP.interest = mRates}) -wrapRunPoolType flag (FPool pt) assump mRates = D.runPoolType flag pt assump $ Just (AP.NonPerfAssumption{AP.interest = mRates}) -wrapRunPoolType flag (VPool pt) assump mRates = D.runPoolType flag pt assump $ Just (AP.NonPerfAssumption{AP.interest = mRates}) -wrapRunPoolType flag (PPool pt) assump mRates = D.runPoolType flag pt assump $ Just (AP.NonPerfAssumption{AP.interest = mRates}) -wrapRunPoolType flag (UPool pt) assump mRates = D.runPoolType flag pt assump $ Just (AP.NonPerfAssumption{AP.interest = mRates}) +wrapRunPoolType flag (MPool pt) assump mRates = D.runPoolType flag pt assump $ Just (AP.nonPerfWithRates mRates) +wrapRunPoolType flag (LPool pt) assump mRates = D.runPoolType flag pt assump $ Just (AP.nonPerfWithRates mRates) +wrapRunPoolType flag (IPool pt) assump mRates = D.runPoolType flag pt assump $ Just (AP.nonPerfWithRates mRates) +wrapRunPoolType flag (RPool pt) assump mRates = D.runPoolType flag pt assump $ Just (AP.nonPerfWithRates mRates) +wrapRunPoolType flag (FPool pt) assump mRates = D.runPoolType flag pt assump $ Just (AP.nonPerfWithRates mRates) +wrapRunPoolType flag (VPool pt) assump mRates = D.runPoolType flag pt assump $ Just (AP.nonPerfWithRates mRates) +wrapRunPoolType flag (PPool pt) assump mRates = D.runPoolType flag pt assump $ Just (AP.nonPerfWithRates mRates) +wrapRunPoolType flag (UPool pt) assump mRates = D.runPoolType flag pt assump $ Just (AP.nonPerfWithRates mRates) wrapRunAsset :: RunAssetReq -> RunAssetResp diff --git a/src/Assumptions.hs b/src/Assumptions.hs index 59372c7e..93ebb95c 100644 --- a/src/Assumptions.hs +++ b/src/Assumptions.hs @@ -13,6 +13,7 @@ module Assumptions (BondPricingInput(..),IrrType(..) ,LeaseAssetGapAssump(..) ,LeaseAssetRentAssump(..) ,NonPerfAssumption(..),AssetPerf + ,defaultNonPerfAssumption,nonPerfWithRates ,AssetDelinquencyAssumption(..) ,AssetDelinqPerfAssumption(..),AssetDefaultedPerfAssumption(..) ,IssueBondEvent(..) @@ -149,6 +150,29 @@ data NonPerfAssumption = NonPerfAssumption { ,refinance :: Maybe [TsPoint RefiEvent] } deriving (Show, Generic) +-- | Total default: every optional field set to 'Nothing'. +-- Always build overrides with record-update syntax: +-- @defaultNonPerfAssumption { interest = mRates }@ so no field is left 'undefined'. +defaultNonPerfAssumption :: NonPerfAssumption +defaultNonPerfAssumption = NonPerfAssumption + { stopRunBy = Nothing + , projectedExpense = Nothing + , callWhen = Nothing + , revolving = Nothing + , interest = Nothing + , inspectOn = Nothing + , buildFinancialReport = Nothing + , pricing = Nothing + , fireTrigger = Nothing + , makeWholeWhen = Nothing + , issueBondSchedule = Nothing + , refinance = Nothing + } + +-- | Non-perf assumption carrying only a rate assumption (the pool-run case). +nonPerfWithRates :: Maybe [RateAssumption] -> NonPerfAssumption +nonPerfWithRates mRates = defaultNonPerfAssumption { interest = mRates } + data AssumptionInput = Single ApplyAssumptionType NonPerfAssumption -- ^ one assumption request | Multiple (Map.Map String ApplyAssumptionType) NonPerfAssumption -- ^ multiple assumption request in a single request deriving (Show,Generic) diff --git a/src/Deal/DealBase.hs b/src/Deal/DealBase.hs index ca468f19..8e3470a1 100644 --- a/src/Deal/DealBase.hs +++ b/src/Deal/DealBase.hs @@ -16,7 +16,7 @@ module Deal.DealBase (TestDeal(..),SPV(..),dealBonds,dealFees,dealAccounts,dealP ,DealStatFields(..),getDealStatInt,isPreClosing,populateDealDates ,bondTraversal,findBondByNames,updateBondInMap,traverseBondMap,traverseBondMapByFn ,_MultiPool,_ResecDeal,uDealFutureCf,uDealFutureScheduleCf - ,RunContext(..),getNextPoolCfTxn + ,RunContext(..),defaultRunContext,getNextPoolCfTxn ) where import qualified Accounts as A @@ -215,6 +215,10 @@ data RunContext = RunContext{ } deriving (Show) +-- | Total default: an empty pool flow and no revolving assumptions/rates. +defaultRunContext :: RunContext +defaultRunContext = RunContext Map.empty Nothing Nothing + getNextPoolCfTxn :: Map.Map PoolId CF.PoolCashflow -> Map.Map PoolId (Maybe CF.TsRow) getNextPoolCfTxn poolCfMap = Map.map (\case ((CF.CashFlowFrame (_,_,_) []),_) -> Nothing --TODO it looks can be deleted diff --git a/test/DealTest/DealTest.hs b/test/DealTest/DealTest.hs index e008fd1b..d67188a5 100644 --- a/test/DealTest/DealTest.hs +++ b/test/DealTest/DealTest.hs @@ -44,10 +44,10 @@ emptyCase = D.TestDeal { ,D.accounts = Map.empty ,D.fees = Map.empty ,D.bonds = Map.empty - ,D.pool = D.MultiPool $ Map.fromList [(PoolConsol, (P.Pool {P.assets=[]}))] + ,D.pool = D.MultiPool $ Map.fromList [(PoolConsol, (P.Pool {P.assets=[], P.futureCf = Nothing, P.futureScheduleCf = Nothing, P.asOfDate = (toDate "20220101"), P.issuanceStat = Nothing, P.extendPeriods = Nothing }))] ,D.waterfall = Map.empty ,D.collects = [] -} +, D.stats = (Map.empty,Map.empty,Map.empty,Map.empty) , D.liqProvider = Nothing, D.rateCap = Nothing, D.custom = Nothing, D.triggers = Nothing, D.ledgers = Nothing } baseCase = D.TestDeal { D.name = "base case" @@ -90,7 +90,7 @@ baseCase = D.TestDeal { ,AB.period=Monthly ,AB.startDate=T.fromGregorian 2022 1 1 ,AB.prinType= AB.Level - ,AB.prepaymentPenalty = Nothing} + ,AB.prepaymentPenalty = Nothing, AB.obligor = Nothing } 4000 0.085 60 @@ -99,7 +99,7 @@ baseCase = D.TestDeal { ,P.futureCf=Nothing ,P.asOfDate = T.fromGregorian 2022 1 1 ,P.issuanceStat = Just $ Map.fromList [(IssuanceBalance, 4000)] - ,P.extendPeriods = Nothing}))]) + ,P.extendPeriods = Nothing, P.futureScheduleCf = Nothing }))]) ,D.waterfall = Map.fromList [(W.DistributionDay Amortizing, [ (W.PayInt Nothing "General" ["A"] Nothing) ,(W.PayPrin Nothing "General" ["A"] Nothing) @@ -111,7 +111,7 @@ baseCase = D.TestDeal { ,D.triggers = Nothing ,D.ledgers = Nothing ,D.stats = (Map.empty,Map.empty,Map.empty,Map.empty) -} +, D.custom = Nothing } baseTests = let diff --git a/test/DealTest/MultiPoolDealTest.hs b/test/DealTest/MultiPoolDealTest.hs index 0c227151..bf9fb77c 100644 --- a/test/DealTest/MultiPoolDealTest.hs +++ b/test/DealTest/MultiPoolDealTest.hs @@ -37,20 +37,20 @@ debug = flip trace dummySt = (0,Lib.toDate "19000101",Nothing) multiPool = Map.fromList [(PoolName "PoolA",P.Pool {P.assets=[AB.Mortgage - AB.MortgageOriginalInfo{ AB.originBalance=4000 ,AB.originRate=Fix DC_ACT_365F 0.085 ,AB.originTerm=60 ,AB.period=Monthly ,AB.startDate=T.fromGregorian 2022 1 1 ,AB.prinType= AB.Level ,AB.prepaymentPenalty = Nothing} + AB.MortgageOriginalInfo{ AB.originBalance=4000 ,AB.originRate=Fix DC_ACT_365F 0.085 ,AB.originTerm=60 ,AB.period=Monthly ,AB.startDate=T.fromGregorian 2022 1 1 ,AB.prinType= AB.Level ,AB.prepaymentPenalty = Nothing, AB.obligor = Nothing } 1000 0.085 60 Nothing AB.Current] ,P.futureCf= Nothing ,P.asOfDate = T.fromGregorian 2022 1 1 ,P.issuanceStat = Just $ Map.fromList [(IssuanceBalance,1000)] ,P.extendPeriods = Nothing - }) + , P.futureScheduleCf = Nothing }) ,(PoolName "PoolB",(P.Pool {P.assets=[AB.Mortgage - AB.MortgageOriginalInfo{ AB.originBalance=4000 ,AB.originRate=Fix DC_ACT_365F 0.085 ,AB.originTerm=60 ,AB.period=Monthly ,AB.startDate=T.fromGregorian 2022 1 1 ,AB.prinType= AB.Level ,AB.prepaymentPenalty = Nothing} + AB.MortgageOriginalInfo{ AB.originBalance=4000 ,AB.originRate=Fix DC_ACT_365F 0.085 ,AB.originTerm=60 ,AB.period=Monthly ,AB.startDate=T.fromGregorian 2022 1 1 ,AB.prinType= AB.Level ,AB.prepaymentPenalty = Nothing, AB.obligor = Nothing } 3000 0.085 60 Nothing AB.Current] ,P.futureCf=Nothing ,P.asOfDate = T.fromGregorian 2022 1 1 ,P.issuanceStat = Just $ Map.fromList [(IssuanceBalance,3000)] - ,P.extendPeriods = Nothing}))] + ,P.extendPeriods = Nothing, P.futureScheduleCf = Nothing }))] baseCase = D.TestDeal { @@ -97,7 +97,7 @@ baseCase = D.TestDeal { ,D.triggers = Nothing ,D.ledgers = Nothing ,D.stats = (Map.empty,Map.empty,Map.empty,Map.empty) -} +, D.custom = Nothing } mPoolbaseTests = let diff --git a/test/DealTest/ResecDealTest.hs b/test/DealTest/ResecDealTest.hs index ba77c779..98cdf22a 100644 --- a/test/DealTest/ResecDealTest.hs +++ b/test/DealTest/ResecDealTest.hs @@ -62,7 +62,7 @@ baseCase = D.TestDeal { ,L.bndDueIntDate=Nothing ,L.bndLastIntPay = Just (T.fromGregorian 2022 1 1) ,L.bndLastPrinPay = Just (T.fromGregorian 2022 1 1) - ,L.bndStmt=Nothing}) + ,L.bndStmt=Nothing, L.bndStepUp = Nothing, L.bndDueIntOverInt = 0.0 }) ] ) ,D.pool = D.MultiPool (Map.fromList [(PoolConsol, (P.Pool {P.assets=[AB.Mortgage @@ -73,7 +73,7 @@ baseCase = D.TestDeal { ,AB.period=Monthly ,AB.startDate=T.fromGregorian 2022 1 1 ,AB.prinType= AB.Level - ,AB.prepaymentPenalty = Nothing} + ,AB.prepaymentPenalty = Nothing, AB.obligor = Nothing } 4000 0.085 60 @@ -82,14 +82,14 @@ baseCase = D.TestDeal { ,P.futureCf=Nothing ,P.asOfDate = T.fromGregorian 2022 1 1 ,P.issuanceStat = Nothing - ,P.extendPeriods = Nothing}))]) + ,P.extendPeriods = Nothing, P.futureScheduleCf = Nothing }))]) ,D.waterfall = Map.fromList [(W.DistributionDay Amortizing, [ (W.PayInt Nothing "General" ["A"] Nothing) ,(W.PayPrin Nothing "General" ["A"] Nothing) ])] ,D.collects = [Collect Nothing W.CollectedInterest "General" ,Collect Nothing W.CollectedPrincipal "General"] -} +, D.stats = (Map.empty,Map.empty,Map.empty,Map.empty) , D.liqProvider = Nothing, D.rateCap = Nothing, D.custom = Nothing, D.triggers = Nothing, D.ledgers = Nothing } resecDeal = D.TestDeal { D.name = "Top Deal" @@ -118,7 +118,7 @@ resecDeal = D.TestDeal { ,L.bndDueIntDate=Nothing ,L.bndLastIntPay = Just (T.fromGregorian 2022 1 1) ,L.bndLastPrinPay = Just (T.fromGregorian 2022 1 1) - ,L.bndStmt=Nothing}) + ,L.bndStmt=Nothing, L.bndStepUp = Nothing, L.bndDueIntOverInt = 0.0 }) ] ) ,D.pool = D.ResecDeal (Map.fromList [(DealBondFlow "base case" "A" (toDate "20200101") 0.25 @@ -129,4 +129,4 @@ resecDeal = D.TestDeal { ])] ,D.collects = [Collect Nothing W.CollectedInterest "General" ,Collect Nothing W.CollectedPrincipal "General"] -} +, D.stats = (Map.empty,Map.empty,Map.empty,Map.empty) , D.liqProvider = Nothing, D.rateCap = Nothing, D.custom = Nothing, D.triggers = Nothing, D.ledgers = Nothing } diff --git a/test/DealTest/RevolvingTest.hs b/test/DealTest/RevolvingTest.hs index ad5a5d73..bea990e6 100644 --- a/test/DealTest/RevolvingTest.hs +++ b/test/DealTest/RevolvingTest.hs @@ -35,20 +35,20 @@ import Control.Lens hiding (element) import Control.Lens.TH multiPool = Map.fromList [(PoolName "PoolA",P.Pool {P.assets=[AB.Mortgage - AB.MortgageOriginalInfo{ AB.originBalance=4000 ,AB.originRate=Fix DC_ACT_365F 0.085 ,AB.originTerm=60 ,AB.period=Monthly ,AB.startDate=T.fromGregorian 2022 1 1 ,AB.prinType= AB.Level ,AB.prepaymentPenalty = Nothing} + AB.MortgageOriginalInfo{ AB.originBalance=4000 ,AB.originRate=Fix DC_ACT_365F 0.085 ,AB.originTerm=60 ,AB.period=Monthly ,AB.startDate=T.fromGregorian 2022 1 1 ,AB.prinType= AB.Level ,AB.prepaymentPenalty = Nothing, AB.obligor = Nothing } 1000 0.085 60 Nothing AB.Current] ,P.futureCf= Nothing ,P.asOfDate = T.fromGregorian 2022 1 1 ,P.issuanceStat = Just $ Map.fromList [(IssuanceBalance,1000)] ,P.extendPeriods = Nothing - }) + , P.futureScheduleCf = Nothing }) ,(PoolName "PoolB",(P.Pool {P.assets=[AB.Mortgage - AB.MortgageOriginalInfo{ AB.originBalance=4000 ,AB.originRate=Fix DC_ACT_365F 0.085 ,AB.originTerm=60 ,AB.period=Monthly ,AB.startDate=T.fromGregorian 2022 1 1 ,AB.prinType= AB.Level ,AB.prepaymentPenalty = Nothing} + AB.MortgageOriginalInfo{ AB.originBalance=4000 ,AB.originRate=Fix DC_ACT_365F 0.085 ,AB.originTerm=60 ,AB.period=Monthly ,AB.startDate=T.fromGregorian 2022 1 1 ,AB.prinType= AB.Level ,AB.prepaymentPenalty = Nothing, AB.obligor = Nothing } 3000 0.085 60 Nothing AB.Current] ,P.futureCf= Nothing ,P.asOfDate = T.fromGregorian 2022 1 1 ,P.issuanceStat = Just $ Map.fromList [(IssuanceBalance,3000)] - ,P.extendPeriods = Nothing}))] + ,P.extendPeriods = Nothing, P.futureScheduleCf = Nothing }))] baseCase = D.TestDeal { @@ -95,14 +95,14 @@ baseCase = D.TestDeal { ,D.triggers = Nothing ,D.ledgers = Nothing ,D.stats = (Map.empty,Map.empty,Map.empty,Map.empty) -} +, D.custom = Nothing } baseTests = let poolAssets = [(AB.PersonalLoan AB.LoanOriginalInfo{AB.originBalance= 1000, AB.originRate= Fix DC_ACT_365F 0.08, AB.originTerm = 24, AB.period = Monthly ,AB.startDate = (T.fromGregorian 2022 1 1), - AB.prinType = AB.I_P} + AB.prinType = AB.I_P, AB.obligor = Nothing } 1000 0.08 24 diff --git a/test/MainTest.hs b/test/MainTest.hs index 2fc79b1b..4a69729e 100644 --- a/test/MainTest.hs +++ b/test/MainTest.hs @@ -89,6 +89,7 @@ tests = testGroup "Tests" [AT.mortgageTests ,DT.mapLookupSafetyTest ,DT.validationNameTest ,DT.aggRuleValidationTest + ,DT.nonPerfAssumptionTest ,DT2.queryTests ,UtilT.daycountTests1 ,UtilT.daycountTests2 diff --git a/test/UT/AccountTest.hs b/test/UT/AccountTest.hs index 87a79e5a..6798e130 100644 --- a/test/UT/AccountTest.hs +++ b/test/UT/AccountTest.hs @@ -81,7 +81,7 @@ reserveAccTest = acc1 = Account 200 "A1" Nothing (Just (PctReserve (CurrentPoolBalance Nothing) 0.01)) Nothing acc2 = Account 150 "A2" Nothing (Just (FixReserve 210)) Nothing accMap = Map.fromList [("A1",acc1),("A2",acc2)] - ctx = RunContext {} + ctx = defaultRunContext testCFs = CF.CashFlowFrame dummySt [CF.MortgageFlow (toDate "20220601") 150 20 10 0 0 0 0 0 Nothing Nothing Nothing ,CF.MortgageFlow (toDate "20220701") 130 20 10 0 0 0 0 0 Nothing Nothing Nothing diff --git a/test/UT/CashflowTest.hs b/test/UT/CashflowTest.hs index 8afe4b4c..0abd0119 100644 --- a/test/UT/CashflowTest.hs +++ b/test/UT/CashflowTest.hs @@ -296,29 +296,29 @@ testHaircut = ,testCase "Haircut on principal" $ assertEqual "" (Just (CF.MortgageDelinqFlow (L.toDate "20230101") 100 10 10 20 0 0 5 0 0.0 Nothing (Just 10) Nothing )) - (CF.cfAt (P.applyHaircut (Just A.ExtraStress{A.poolHairCut = Just [(CollectedPrincipal,0.5)]}) cflow) 0) + (CF.cfAt (P.applyHaircut (Just A.ExtraStress{A.poolHairCut = Just [(CollectedPrincipal,0.5)], A.defaultFactors = Nothing, A.prepaymentFactors = Nothing }) cflow) 0) ,testCase "Haircut on interest" $ assertEqual "" (Just (CF.MortgageDelinqFlow (L.toDate "20230101") 100 20 7 20 0 0 5 0 0.0 Nothing (Just 10) Nothing)) - (CF.cfAt (P.applyHaircut (Just A.ExtraStress{A.poolHairCut = Just [(CollectedInterest,0.3)]}) cflow) 0) + (CF.cfAt (P.applyHaircut (Just A.ExtraStress{A.poolHairCut = Just [(CollectedInterest,0.3)], A.defaultFactors = Nothing, A.prepaymentFactors = Nothing }) cflow) 0) ,testCase "Haircut on prepayment" $ assertEqual "" (Just (CF.MortgageDelinqFlow (L.toDate "20230101") 100 20 10 12 0 0 5 0 0.0 Nothing (Just 10) Nothing)) - (CF.cfAt (P.applyHaircut (Just A.ExtraStress{A.poolHairCut = Just [(CollectedPrepayment,0.4)]}) cflow) 0) + (CF.cfAt (P.applyHaircut (Just A.ExtraStress{A.poolHairCut = Just [(CollectedPrepayment,0.4)], A.defaultFactors = Nothing, A.prepaymentFactors = Nothing }) cflow) 0) ,testCase "Haircut on recoveries" $ assertEqual "" (Just (CF.MortgageDelinqFlow (L.toDate "20230101") 100 20 10 20 0 0 4.5 0 0.0 Nothing (Just 10) Nothing)) - (CF.cfAt (P.applyHaircut (Just A.ExtraStress{A.poolHairCut = Just [(CollectedRecoveries,0.1)]}) cflow) 0) + (CF.cfAt (P.applyHaircut (Just A.ExtraStress{A.poolHairCut = Just [(CollectedRecoveries,0.1)], A.defaultFactors = Nothing, A.prepaymentFactors = Nothing }) cflow) 0) ,testCase "Haircut on prepay penalty" $ assertEqual "" (Just (CF.MortgageDelinqFlow (L.toDate "20230101") 100 20 10 20 0 0 5 0 0.0 Nothing (Just 8) Nothing)) - (CF.cfAt (P.applyHaircut (Just A.ExtraStress{A.poolHairCut = Just [(CollectedPrepaymentPenalty,0.2)]}) cflow) 0) + (CF.cfAt (P.applyHaircut (Just A.ExtraStress{A.poolHairCut = Just [(CollectedPrepaymentPenalty,0.2)], A.defaultFactors = Nothing, A.prepaymentFactors = Nothing }) cflow) 0) ,testCase "Haircut on mix" $ assertEqual "" (Just (CF.MortgageDelinqFlow (L.toDate "20230101") 100 10 7 20 0 0 5 0 0.0 Nothing (Just 8) Nothing)) (CF.cfAt (P.applyHaircut (Just A.ExtraStress{A.poolHairCut = Just [(CollectedPrepaymentPenalty,0.2) ,(CollectedPrincipal,0.5) - ,(CollectedInterest,0.3)]}) cflow) 0) + ,(CollectedInterest,0.3)], A.defaultFactors = Nothing, A.prepaymentFactors = Nothing }) cflow) 0) ] testCumStat = diff --git a/test/UT/DealTest.hs b/test/UT/DealTest.hs index 212b268d..16201267 100644 --- a/test/UT/DealTest.hs +++ b/test/UT/DealTest.hs @@ -1,5 +1,5 @@ module UT.DealTest(td2,queryTests,triggerTests,dateTests,liqProviderTest,poolFlowTest,priceBondsIrrTest - ,mapLookupSafetyTest,validationNameTest,aggRuleValidationTest) + ,mapLookupSafetyTest,validationNameTest,aggRuleValidationTest,nonPerfAssumptionTest) where @@ -47,7 +47,7 @@ debug = flip Debug.Trace.trace dummySt = (0,toDate "19000101",Nothing) -emptyRunAssump = AP.NonPerfAssumption Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + td2 = D.TestDeal { @@ -90,7 +90,7 @@ td2 = D.TestDeal { ,L.bndDueIntDate=Nothing ,L.bndLastIntPay = Just (T.fromGregorian 2022 1 1) ,L.bndLastPrinPay = Just (T.fromGregorian 2022 1 1) - ,L.bndStmt=Nothing}) + ,L.bndStmt=Nothing, L.bndStepUp = Nothing }) ,("B" ,L.Bond{ L.bndName="B" @@ -108,7 +108,7 @@ td2 = D.TestDeal { ,L.bndDueIntDate=Nothing ,L.bndLastIntPay = Just (T.fromGregorian 2022 1 1) ,L.bndLastPrinPay = Just (T.fromGregorian 2022 1 1) - ,L.bndStmt=Nothing}) + ,L.bndStmt=Nothing, L.bndStepUp = Nothing, L.bndDueIntOverInt = 0.0 }) ] ) ,D.pool = D.MultiPool $ @@ -122,7 +122,7 @@ td2 = D.TestDeal { ,AB.period=Monthly ,AB.startDate=(T.fromGregorian 2022 1 1) ,AB.prinType= AB.Level - ,AB.prepaymentPenalty = Nothing} + ,AB.prepaymentPenalty = Nothing, AB.obligor = Nothing } 4000 0.085 60 @@ -136,7 +136,7 @@ td2 = D.TestDeal { ,AB.period=Monthly ,AB.startDate=(T.fromGregorian 2022 1 1) ,AB.prinType= AB.Level - ,AB.prepaymentPenalty = Nothing} + ,AB.prepaymentPenalty = Nothing, AB.obligor = Nothing } 200 0.085 60 @@ -145,7 +145,7 @@ td2 = D.TestDeal { ] ,P.futureCf=Nothing ,P.asOfDate = T.fromGregorian 2022 1 1 - ,P.issuanceStat = Just $ Map.fromList [(RuntimeCurrentPoolBalance, 70)]} + ,P.issuanceStat = Just $ Map.fromList [(RuntimeCurrentPoolBalance, 70)], P.futureScheduleCf = Nothing, P.extendPeriods = Nothing } )] ,D.waterfall = Map.fromList [(W.DistributionDay Amortizing, [ (W.PayFee Nothing "General" ["Service-Fee"] Nothing) @@ -179,11 +179,11 @@ td2 = D.TestDeal { Map.fromList [ ("revolving trigger",Trg.Trigger{Trg.trgCondition = IfDate G (toDate "20220501") ,Trg.trgEffects = Trg.DealStatusTo Revolving ,Trg.trgStatus = False - ,Trg.trgCurable = False })] + ,Trg.trgCurable = False , Trg.trgStmt = Nothing })] )] ,D.ledgers = Nothing ,D.stats = (Map.empty,Map.empty,Map.empty,Map.empty) -} +, D.rateCap = Nothing } baseDeal = D.TestDeal { D.name = "base deal" @@ -258,7 +258,7 @@ baseDeal = D.TestDeal { ,P.futureCf= Nothing ,P.extendPeriods = Nothing ,P.asOfDate = T.fromGregorian 2022 1 1 - ,P.issuanceStat = Just $ Map.fromList [(RuntimeCurrentPoolBalance, 70),(IssuanceBalance, 4000)]})] + ,P.issuanceStat = Just $ Map.fromList [(RuntimeCurrentPoolBalance, 70),(IssuanceBalance, 4000)], P.futureScheduleCf = Nothing })] ,D.waterfall = Map.fromList [(W.DistributionDay Amortizing, [ (W.PayInt Nothing "General" ["A"] Nothing) ,(W.PayPrin Nothing "General" ["A"] Nothing) @@ -274,7 +274,7 @@ baseDeal = D.TestDeal { poolFlowTest = let - (deal,mPoolCf,mResultComp,mPricing,oustandingFlow) = case (runDeal baseDeal S.empty Nothing emptyRunAssump) of + (deal,mPoolCf,mResultComp,mPricing,oustandingFlow) = case (runDeal baseDeal S.empty Nothing AP.defaultNonPerfAssumption) of (Left er) -> error $ "Deal run failed"++ show er (Right (a,b,c,d,e)) -> (a,b,c,d,e) bndMap = D.viewBondsInMap deal @@ -301,7 +301,7 @@ poolFlowTest = queryTests = testGroup "deal stat query Tests" [ let - ctx = D.RunContext {} + ctx = D.defaultRunContext currentDefBal = queryCompound td2 ctx epocDate CurrentPoolDefaultedBalance in testCase "query current assets in defaulted status" $ @@ -517,3 +517,24 @@ aggRuleValidationTest = in assertBool ("expected a pool id error, got: " ++ show (aggErrs deal)) (any ("Pool Id not found" `isInfixOf`) (aggErrs deal)) ] + +nonPerfAssumptionTest = + testGroup "NonPerfAssumption / RunContext defaults" + [ + testCase "default NonPerfAssumption is fully defined and shows without throwing" $ + assertBool "show forces every field" (not (null (show AP.defaultNonPerfAssumption))) + , testCase "default NonPerfAssumption has no interest assumption" $ + assertBool "interest is Nothing" + (case AP.interest AP.defaultNonPerfAssumption of Nothing -> True; _ -> False) + , testCase "nonPerfWithRates sets interest and leaves other fields untouched" $ + let a = AP.nonPerfWithRates (Just []) + in do + assertBool "interest set" (case AP.interest a of Just [] -> True; _ -> False) + assertBool "show forces every field" (not (null (show a))) + assertBool "revolving stays Nothing" (case AP.revolving a of Nothing -> True; _ -> False) + assertBool "pricing stays Nothing" (case AP.pricing a of Nothing -> True; _ -> False) + , testCase "default RunContext is fully defined" $ + assertBool "show forces every field" (not (null (show D.defaultRunContext))) + , testCase "default RunContext has an empty pool flow" $ + assertEqual "empty pool flow" Map.empty (D.runPoolFlow D.defaultRunContext) + ] diff --git a/test/UT/DealTest2.hs b/test/UT/DealTest2.hs index 754a084a..6693e999 100644 --- a/test/UT/DealTest2.hs +++ b/test/UT/DealTest2.hs @@ -70,7 +70,7 @@ td = D.TestDeal { ,L.bndDueIntDate=Nothing ,L.bndLastIntPay = Just (T.fromGregorian 2022 1 1) ,L.bndLastPrinPay = Just (T.fromGregorian 2022 1 1) - ,L.bndStmt=Nothing}) + ,L.bndStmt=Nothing, L.bndStepUp = Nothing }) ,("B" ,L.Bond{ L.bndName="B" @@ -88,7 +88,7 @@ td = D.TestDeal { ,L.bndDueIntDate=Nothing ,L.bndLastIntPay = Just (T.fromGregorian 2022 1 1) ,L.bndLastPrinPay = Just (T.fromGregorian 2022 1 1) - ,L.bndStmt=Nothing}) + ,L.bndStmt=Nothing, L.bndStepUp = Nothing, L.bndDueIntOverInt = 0.0 }) ] ) ,D.pool = D.MultiPool $ @@ -101,7 +101,7 @@ td = D.TestDeal { ,AB.period=Monthly ,AB.startDate=(T.fromGregorian 2022 1 1) ,AB.prinType= AB.Level - ,AB.prepaymentPenalty = Nothing} + ,AB.prepaymentPenalty = Nothing, AB.obligor = Nothing } 4000 0.085 60 @@ -115,7 +115,7 @@ td = D.TestDeal { ,AB.period=Monthly ,AB.startDate=(T.fromGregorian 2022 1 1) ,AB.prinType= AB.Level - ,AB.prepaymentPenalty = Nothing} + ,AB.prepaymentPenalty = Nothing, AB.obligor = Nothing } 200 0.085 60 @@ -124,7 +124,7 @@ td = D.TestDeal { ] ,P.futureCf=Nothing ,P.asOfDate = T.fromGregorian 2022 1 1 - ,P.issuanceStat = Nothing} + ,P.issuanceStat = Nothing, P.futureScheduleCf = Nothing, P.extendPeriods = Nothing } )] ,D.waterfall = Map.fromList [(W.DistributionDay Amortizing, [ (W.PayFee Nothing "General" ["Service-Fee"] Nothing) @@ -136,7 +136,7 @@ td = D.TestDeal { ,D.liqProvider = Nothing ,D.triggers = Nothing ,D.ledgers = Nothing -} +, D.stats = (Map.empty,Map.empty,Map.empty,Map.empty) , D.rateCap = Nothing } bondGroups = Map.fromList [("A" ,L.BondGroup (Map.fromList @@ -199,7 +199,7 @@ bondGroups = Map.fromList [("A" ,L.bndDueIntDate=Nothing ,L.bndLastIntPay = Just (T.fromGregorian 2022 1 1) ,L.bndLastPrinPay = Just (T.fromGregorian 2022 1 1) - ,L.bndStmt=Nothing}) + ,L.bndStmt=Nothing, L.bndDueIntOverInt = 0.0 }) ] tdBondGroup = td { D.bonds = bondGroups, @@ -214,7 +214,7 @@ tdBondGroup = td { D.bonds = bondGroups, queryTests = let - ctx = D.RunContext {} + ctx = D.defaultRunContext in testGroup "Deal Group Test" [ diff --git a/test/UT/ExpTest.hs b/test/UT/ExpTest.hs index c910df47..dccae3ba 100644 --- a/test/UT/ExpTest.hs +++ b/test/UT/ExpTest.hs @@ -30,7 +30,7 @@ expTests = testGroup "Expense Tests" _calcDate = (L.toDate "20220310") _calcDate2 = (L.toDate "20220115") _calcDate3 = (L.toDate "20220415") - ctx = RunContext {} + ctx = defaultRunContext feesCalc = sequenceA [(DA.calcDueFee DT.td2 ctx _calcDate f1) ,(DA.calcDueFee DT.td2 ctx _calcDate2 f1) ,(DA.calcDueFee DT.td2 ctx _calcDate3 f2) ,(DA.calcDueFee DT.td2 ctx _calcDate3 f1)] in testCase "calc on diff same period for recur fee" $ @@ -53,7 +53,7 @@ expTests = testGroup "Expense Tests" f1WithDue = Fee "FeeName1" (FeeFlow (L.BalanceCurve tsPoints)) (L.toDate "20210101") 3 Nothing 0 Nothing Nothing _f1WithDue = f1WithDue {feeType= FeeFlow (L.BalanceCurve [(L.TsPoint (L.toDate "20220601") 20.0)]), feeDue = 28, feeDueDate = Just _calcDate} - ctx = RunContext {} + ctx = defaultRunContext feesCalc = sequenceA [DA.calcDueFee DT.td2 ctx _calcDate f1 ,DA.calcDueFee DT.td2 ctx _calcDate2 f1 ,DA.calcDueFee DT.td2 ctx _calcDate3 f1 diff --git a/test/UT/RateHedgeTest.hs b/test/UT/RateHedgeTest.hs index 43af9e1e..67fc0765 100644 --- a/test/UT/RateHedgeTest.hs +++ b/test/UT/RateHedgeTest.hs @@ -24,7 +24,7 @@ capRateTests = (Lib.toDate "20240101") QuarterEnd (Lib.toDate "20270101") 0.03 Nothing 0 Nothing indexAssump = [RateFlat LIBOR6M 0.04] - ctx = D.RunContext {} + ctx = D.defaultRunContext rc1 = accrueRC td2 ctx (Lib.toDate "20241231") indexAssump rc in testGroup "Cap Rate Tests" From 2ee3864413897008047ff0bbce70c70be1b3bd1d Mon Sep 17 00:00:00 2001 From: yellowbean Date: Fri, 16 Oct 2026 18:34:11 +0800 Subject: [PATCH 24/40] Fix#346: resolve the worker cap from HASTRUCTURE_WORKERS env (superseded by #345 ServerConfig) --- app/Main.hs | 26 ++++++++++++++++++++------ src/Util.hs | 16 +++++++++++++++- test/MainTest.hs | 1 + test/UT/UtilTest.hs | 21 +++++++++++++++++++-- 4 files changed, 55 insertions(+), 9 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 3aa89d14..ea7a655a 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -15,6 +15,8 @@ module Main import Prelude () import Prelude.Compat import System.Environment +import System.IO.Unsafe (unsafePerformIO) +import GHC.Conc (getNumCapabilities) import Control.Monad.IO.Class (liftIO) import Control.Monad (mapM) import Control.Exception (Exception,throwIO,throw) @@ -56,7 +58,7 @@ import Servant.API.ContentTypes (contentType) import Types import MainBase -import Util (boundedParMap) +import Util (boundedParMap,resolveWorkerCap) import qualified Deal as D import qualified Deal.DealBase as DB import qualified Deal.DealDate as DD @@ -206,12 +208,24 @@ showVersion :: Handler Version showVersion = return version1 -- | Upper bound on the number of scenarios/deals evaluated concurrently, i.e. --- on in-flight sparks. The RTS itself limits real concurrency to @-N@ --- capabilities; this cap is what prevents unbounded spark creation for large --- grids (e.g. 'runDealByCombo's cartesian product). Raise/lower here to tune --- memory vs throughput. +-- on in-flight sparks. This is a bound on in-flight *evaluation* rather than on +-- threads: the RTS limits real concurrency to @-N@ capabilities and nested +-- asset-level 'parMap' inside each run self-throttles via work-stealing +-- (unevaluated sparks simply wait, or fall back to sequential evaluation when +-- demanded — see the @SPARKS@ counters printed by @+RTS -s@). The bound +-- therefore controls peak heap from concurrent deal states on large grids +-- (e.g. 'runDealByCombo's cartesian product), not parallelism. +-- +-- Resolution order: the @HASTRUCTURE_WORKERS@ environment variable when it +-- parses to a positive integer — it may exceed @-N@, acting as evaluation +-- lookahead — otherwise the RTS capability count (@-N@). See +-- 'resolveWorkerCap' (unit-tested) for the pure decision logic. +{-# NOINLINE maxParallelWorkers #-} maxParallelWorkers :: Int -maxParallelWorkers = 8 +maxParallelWorkers = unsafePerformIO $ do + caps <- getNumCapabilities + env <- lookupEnv "HASTRUCTURE_WORKERS" + pure $ resolveWorkerCap caps env runAsset :: RunAssetReq -> Handler RunAssetResp runAsset req = return $ wrapRunAsset req diff --git a/src/Util.hs b/src/Util.hs index 72e8c832..872bf0fc 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -13,7 +13,7 @@ module Util ,lastOf,findBox,safeDivide', safeDiv ,safeDivide,lstToMapByFn,paySequentially,payProRata,mapWithinMap ,payInMap,payInMapM,adjustM,adjustMs,mapInMapM,lookupAndApply,lookupAndUpdate,lookupAndApplies - ,lookupInMap,selectInMap,scaleByFstElement,boundedParMap + ,lookupInMap,selectInMap,scaleByFstElement,boundedParMap,resolveWorkerCap ,lookupTuple6 ,lookupTuple7,diffNum,splitBal,lookupM,lookupVs ,lookupMM -- for debug @@ -38,6 +38,7 @@ import Text.Printf import Control.Exception import Control.Parallel.Strategies (parBuffer, rseq, using) +import Text.Read (readMaybe) import Data.Time (addDays) import Debug.Trace debug = flip trace @@ -277,6 +278,19 @@ boundedParMap n f m = vs' = (map f vs) `using` parBuffer (max 1 n) rseq in Map.fromList (zip ks vs') +-- | Resolve the parallel-worker cap used by the multi-scenario\/multi-deal +-- endpoints (see 'boundedParMap'). @caps@ is the RTS capability count (@-N@) +-- and @mEnv@ is the value of the @HASTRUCTURE_WORKERS@ environment variable. +-- An explicit override wins when it parses to a positive 'Int' — it may exceed +-- @caps@, because the bound caps in-flight evaluation (peak heap) rather than +-- real concurrency. Missing, unparsable, zero or negative values fall back to +-- @caps@. +resolveWorkerCap :: Int -> Maybe String -> Int +resolveWorkerCap caps mEnv = + case mEnv >>= readMaybe of + Just n | n > 0 -> n + _ -> caps + lastOf:: [a] -> (a->Bool) -> Maybe a lastOf [] fn = Nothing lastOf xs fn = diff --git a/test/MainTest.hs b/test/MainTest.hs index 4a69729e..c7022789 100644 --- a/test/MainTest.hs +++ b/test/MainTest.hs @@ -111,6 +111,7 @@ tests = testGroup "Tests" [AT.mortgageTests ,UtilT.scaleListTest ,UtilT.mapUpdateTest ,UtilT.boundedParMapTest + ,UtilT.resolveWorkerCapTest ,AccT.intTests ,AccT.investTests ,AccT.reserveAccTest diff --git a/test/UT/UtilTest.hs b/test/UT/UtilTest.hs index 7bbb5f46..9ea4a0b9 100644 --- a/test/UT/UtilTest.hs +++ b/test/UT/UtilTest.hs @@ -3,7 +3,7 @@ module UT.UtilTest(daycountTests1,daycountTests2,daycountTests3,daycountTests4 ,tsTest,ts2Test,ts3Test,dateVectorPatternTest,paddingTest,dateSliceTest ,capTest,roundingTest,sliceTest,splitTsTest,tableTest,lastOftest,paySeqTest - ,scaleListTest,mapUpdateTest,boundedParMapTest)--,daycountTests3,daycountTests4) + ,scaleListTest,mapUpdateTest,boundedParMapTest,resolveWorkerCapTest)--,daycountTests3,daycountTests4) where import Test.Tasty @@ -713,4 +713,21 @@ boundedParMapTest = assertEqual "empty" (Map.empty :: Map.Map Int Int) (boundedParMap 4 f (Map.empty :: Map.Map Int Int)) , testCase "preserves keys order-independently" $ assertEqual "keys" (Map.keys m) (Map.keys (boundedParMap 3 f m)) - ] \ No newline at end of file + ] + +resolveWorkerCapTest :: TestTree +resolveWorkerCapTest = + testGroup "resolveWorkerCap" + [ testCase "missing env falls back to capability count" $ + assertEqual "fallback" 4 (resolveWorkerCap 4 Nothing) + , testCase "valid override wins (may exceed capability count)" $ + assertEqual "override" 16 (resolveWorkerCap 4 (Just "16")) + , testCase "override of 1 is the minimum usable bound" $ + assertEqual "one" 1 (resolveWorkerCap 4 (Just "1")) + , testCase "zero override falls back" $ + assertEqual "zero" 4 (resolveWorkerCap 4 (Just "0")) + , testCase "negative override falls back" $ + assertEqual "negative" 4 (resolveWorkerCap 4 (Just "-3")) + , testCase "unparsable override falls back" $ + assertEqual "garbage" 4 (resolveWorkerCap 4 (Just "garbage")) + ] \ No newline at end of file From 4093f296b9ebcb92919f05ca37df50ce2f79c437 Mon Sep 17 00:00:00 2001 From: yellowbean Date: Sat, 17 Oct 2026 01:17:20 +0800 Subject: [PATCH 25/40] Fix#328: strict canonical TxnComment JSON codec with roundtrip tests --- src/Types.hs | 310 ++++++++++++++++++++++++++------------------- test/UT/LibTest.hs | 42 +++++- 2 files changed, 222 insertions(+), 130 deletions(-) diff --git a/src/Types.hs b/src/Types.hs index 7e4872d1..984933b4 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -57,8 +57,6 @@ import qualified Data.Time as Time import qualified Data.Time.Format as TF import qualified Data.Map as Map import qualified Data.List.Split -import Text.Regex.Base -import Text.Regex.PCRE import GHC.Generics import Language.Haskell.TH @@ -269,21 +267,20 @@ instance Show PoolId where show PoolConsol = "PoolConsol" show (DealBondFlow dn bn sd r) = "BondFlow:"++dn++":"++bn++":"++show sd++":"++show r -instance (Read PoolId) where - readsPrec d "PoolConsol" = [(PoolConsol,"")] - readsPrec d rStr = - let - pn = Data.List.Split.splitOn ":" rStr - in - case pn of - [dn,bn,sd,r] -> - let - sd' = TF.parseTimeOrError True TF.defaultTimeLocale "%Y-%m-%d" sd - r' = read r::Rate - in - [(DealBondFlow dn bn sd' r',"")] - ["PoolName",pn] -> [(PoolName pn,"")] - _ -> error $ "Invalid PoolId: "++ show pn +instance Read PoolId where + readsPrec _ s + | s == "PoolConsol" = [(PoolConsol, "")] + | otherwise = case Data.List.Split.splitOn ":" s of + ["PoolName", pn] -> [(PoolName pn, "")] + ["BondFlow", dn, bn, sd, r] -> mkDealBondFlow dn bn sd r + [dn, bn, sd, r] -> mkDealBondFlow dn bn sd r + _ | ':' `notElem` s -> [(PoolName s, "")] -- bare pool name, matching `show` + _ -> [] + where + mkDealBondFlow dn bn sd r = + case TF.parseTimeM True TF.defaultTimeLocale "%Y-%m-%d" sd of + Nothing -> [] + Just sd' -> maybe [] (\r' -> [(DealBondFlow dn bn sd' r', "")]) (readMaybe r :: Maybe Rate) @@ -998,119 +995,176 @@ data ResultComponent = CallAt Date -- ^ makePrisms ''ResultComponent -listToStrWithComma :: [String] -> String -listToStrWithComma = intercalate "," - -instance ToJSON TxnComment where - toJSON (PayInt bns ) = String $ T.pack $ "" - toJSON (PayYield bn ) = String $ T.pack $ "" - toJSON (PayPrin bns ) = String $ T.pack $ "" - toJSON (WriteOff bn amt ) = String $ T.pack $ "" - toJSON (FundWith b bal) = String $ T.pack $ "" - toJSON (PayPrinResidual bns ) = String $ T.pack $ "" - toJSON (PayFee fn ) = String $ T.pack $ "" - toJSON (SeqPayFee fns) = String $ T.pack $ "" - toJSON (PayFeeYield fn) = String $ T.pack $ "" - toJSON (Transfer an1 an2) = String $ T.pack $ "" - toJSON (TransferBy an1 an2 limit) = String $ T.pack $ "" - toJSON (PoolInflow mPids ps) = String $ T.pack $ ")) mPids ++":"++ show ps++">" - toJSON (LiquidationProceeds pids) = String $ T.pack $ " pids) ++">" - toJSON (UsingDS ds) = String $ T.pack $ "" - toJSON BankInt = String $ T.pack $ "" - toJSON Empty = String $ T.pack $ "" - toJSON (LiquidationSupport source) = String $ T.pack $ "" - toJSON (LiquidationSupportInt b1 b2) = String $ T.pack $ "" - toJSON LiquidationDraw = String $ T.pack $ "" - toJSON (LiquidationRepay s) = String $ T.pack $ "" - toJSON SwapAccrue = String $ T.pack $ "" - toJSON (SwapInSettle s)= String $ T.pack $ "" - toJSON (SwapOutSettle s) = String $ T.pack $ "" - toJSON (PurchaseAsset rPoolName bal) = String $ T.pack $ " rPoolName <>","++show bal++">" - toJSON (TxnDirection dr) = String $ T.pack $ "" - toJSON SupportDraw = String $ T.pack $ "" - toJSON (IssuanceProceeds nb) = String $ T.pack $ "" - toJSON (Tag cmt) = String $ T.pack $ "" - toJSON (TxnComments tcms) = Array $ V.fromList $ map toJSON tcms - toJSON (PayGroupInt bns) = String $ T.pack $ "" - toJSON (PayGroupPrin bns) = String $ T.pack $ "" - toJSON (BookLedgerBy dr lName) = String $ T.pack $ "" - toJSON x = error $ "Not support for toJSON for "++show x +-- | Canonical textual payload of a txn comment: 'NoFields' renders "", +-- 'RawFields' renders "", 'FieldList' renders "". +data Payload = NoFields | RawFields T.Text | FieldList [T.Text] + deriving (Show, Eq) + +-- | Split "" at the FIRST colon. Total: anything that is not +-- of the form "<...:...>" yields 'Nothing'. +txnSplitComment :: T.Text -> Maybe (T.Text, T.Text) +txnSplitComment t = do + inner <- T.stripSuffix ">" =<< T.stripPrefix "<" t + let (tag, rest) = T.breakOn ":" inner + contents <- T.stripPrefix ":" rest + pure (tag, contents) + +-- | Comma split where "" means [] (empty payloads are valid for list tags). +txnSplitFields :: T.Text -> [T.Text] +txnSplitFields t + | T.null t = [] + | otherwise = T.splitOn "," t + +txnNames :: T.Text -> [String] +txnNames = map T.unpack . txnSplitFields + +-- | Exactly 2 comma-separated fields. +txnField2 :: T.Text -> T.Text -> Parser (T.Text, T.Text) +txnField2 ctx t = case txnSplitFields t of + [a, b] -> pure (a, b) + fs -> fail (T.unpack ctx ++ ": expected 2 comma-separated fields but got " ++ show (length fs) ++ " in '" ++ T.unpack t ++ "'") + +-- | Exactly 3 comma-separated fields. +txnField3 :: T.Text -> T.Text -> Parser (T.Text, T.Text, T.Text) +txnField3 ctx t = case txnSplitFields t of + [a, b, c] -> pure (a, b, c) + fs -> fail (T.unpack ctx ++ ": expected 3 comma-separated fields but got " ++ show (length fs) ++ " in '" ++ T.unpack t ++ "'") + +-- | Total 'read' with a descriptive 'Parser' failure instead of a runtime exception. +txnReadField :: Read a => T.Text -> T.Text -> Parser a +txnReadField ctx t = case readMaybe (T.unpack t) of + Just v -> pure v + Nothing -> fail (T.unpack ctx ++ ": cannot parse '" ++ T.unpack t ++ "'") + +-- | Tags without payload must have empty contents. +txnNoPayload :: T.Text -> T.Text -> Parser () +txnNoPayload ctx t + | T.null t = pure () + | otherwise = fail (T.unpack ctx ++ ": expected no payload but got '" ++ T.unpack t ++ "'") + +-- | Canonical (tag, payload) per constructor: the mirror image of 'parseTxn'. +-- 'Empty' and 'TxnComments' are intercepted by the leading clauses of the +-- ToJSON instance, so their entries here are never rendered. +txnPayload :: TxnComment -> (T.Text, Payload) +txnPayload Empty = ("", NoFields) +txnPayload (TxnComments _) = ("", NoFields) +txnPayload (PayInt bns) = ("PayInt", FieldList (map T.pack bns)) +txnPayload (PayYield bn) = ("PayYield", RawFields (T.pack bn)) +txnPayload (PayPrin bns) = ("PayPrin", FieldList (map T.pack bns)) +txnPayload (PayGroupPrin bs) = ("PayGroupPrin", FieldList (map T.pack bs)) +txnPayload (PayGroupInt bs) = ("PayGroupInt", FieldList (map T.pack bs)) +txnPayload (WriteOff bn amt) = ("WriteOff", FieldList [T.pack bn, T.pack (show amt)]) +txnPayload (FundWith b bal) = ("FundWith", FieldList [T.pack b, T.pack (show bal)]) +txnPayload (PayPrinResidual bs) = ("PayPrinResidual", FieldList (map T.pack bs)) +txnPayload (PayFee fn) = ("PayFee", RawFields (T.pack fn)) +txnPayload (SeqPayFee fns) = ("SeqPayFee", FieldList (map T.pack fns)) +txnPayload (PayFeeYield fn) = ("PayFeeYield", RawFields (T.pack fn)) +txnPayload (Transfer a1 a2) = ("Transfer", FieldList [T.pack a1, T.pack a2]) +txnPayload (TransferBy a1 a2 l) = ("TransferBy", FieldList [T.pack a1, T.pack a2, T.pack (show l)]) +txnPayload (BookLedgerBy dr lName) = ("BookLedger", FieldList [T.pack (show dr), T.pack lName]) +txnPayload (PoolInflow mPids ps) = + ("Pool", FieldList [maybe "" (T.intercalate "|" . map (T.pack . show)) mPids, T.pack (show ps)]) +txnPayload (LiquidationProceeds pids) = ("Liquidation", FieldList (map (T.pack . show) pids)) +txnPayload (LiquidationSupport s) = ("Support", RawFields (T.pack s)) +txnPayload LiquidationDraw = ("Draw", NoFields) +txnPayload (LiquidationRepay s) = ("Repay", RawFields (T.pack s)) +txnPayload (LiquidationSupportInt b1 b2) = ("SupportExp", FieldList [T.pack (show b1), T.pack (show b2)]) +txnPayload BankInt = ("BankInt", NoFields) +txnPayload SupportDraw = ("SupportDraw", NoFields) +txnPayload (Tag s) = ("Tag", RawFields (T.pack s)) +txnPayload (UsingDS ds) = ("DS", RawFields (T.pack (show ds))) +txnPayload SwapAccrue = ("Accure", NoFields) +txnPayload (SwapInSettle s) = ("SettleIn", RawFields (T.pack s)) +txnPayload (SwapOutSettle s) = ("SettleOut", RawFields (T.pack s)) +txnPayload (PurchaseAsset rp bal) = ("PurchaseAsset", FieldList [T.pack rp, T.pack (show bal)]) +txnPayload (IssuanceProceeds nb) = ("IssuanceProceeds", RawFields (T.pack nb)) +txnPayload (TxnDirection dr) = ("TxnDirection", RawFields (T.pack (show dr))) + +renderPayload :: Payload -> T.Text +renderPayload NoFields = "" +renderPayload (RawFields s) = s +renderPayload (FieldList fs) = T.intercalate "," fs + +instance ToJSON TxnComment where + toJSON Empty = String "" + toJSON (TxnComments ts) = Array $ V.fromList $ map toJSON ts + toJSON tc = let (tag, pl) = txnPayload tc + in String $ "<" <> tag <> ":" <> renderPayload pl <> ">" instance FromJSON TxnComment where - parseJSON = withText "Empty" parseTxn - -parseTxn :: T.Text -> Parser TxnComment -parseTxn "" = return Empty -parseTxn "" = return BankInt -parseTxn t = case tagName of - "Transfer" -> let - sv = T.splitOn (T.pack ",") $ T.pack contents - in - return $ Transfer (T.unpack (head sv)) (T.unpack (sv!!1)) - "Support" -> return $ LiquidationSupport contents - "PayInt" -> return $ PayInt [contents] - "PayYield" -> return $ PayYield contents - "PayPrin" -> return $ PayPrin [contents] - "WriteOff" -> let - sv = T.splitOn (T.pack ",") $ T.pack contents - in - return $ WriteOff (T.unpack (head sv)) (read (T.unpack (sv!!1))::Balance) - "PayPrinResidual" -> return $ PayPrinResidual [contents] - "PayFee" -> return $ PayFee contents - "SeqPayFee" -> return $ SeqPayFee [contents] - "PayFeeYield" -> return $ PayFeeYield contents - "TransferBy" -> let - sv = T.splitOn (T.pack ",") $ T.pack contents - in - return $ TransferBy (T.unpack (head sv)) (T.unpack (sv!!1)) (read (T.unpack (sv!!2))::Limit) - "Pool" -> let - sr = T.splitOn (T.pack ":") $ T.pack contents - mPids = if head sr == "Nothing" then - Nothing - else - Just (read <$> T.unpack <$> sr)::(Maybe [PoolId]) - in - return $ PoolInflow mPids (read (T.unpack (sr!!1))::PoolSource) - "Liquidation" -> let - sv = T.splitOn (T.pack ",") $ T.pack contents - pids::[PoolId] = read <$> T.unpack <$> sv - in - return $ LiquidationProceeds pids - - "DS" -> return $ UsingDS (read (contents)::DealStats) - "LiquidationSupportExp" -> let - sv = T.splitOn (T.pack ",") $ T.pack contents - in - return $ LiquidationSupportInt (read (T.unpack (head sv))::Balance) (read (T.unpack (sv!!1))::Balance) - "SupportDraw" -> return SupportDraw - "Draw" -> return LiquidationDraw - "Repay" -> return $ LiquidationRepay contents - "Accure" -> return SwapAccrue - "SettleIn" -> return $ SwapInSettle contents - "SettleOut" -> return $ SwapOutSettle contents - "PurchaseAsset" -> let - sv = T.splitOn (T.pack ",") $ T.pack contents - in - return $ PurchaseAsset (read (T.unpack (sv!!0))::String) (read (T.unpack (sv!!1))::Balance) - - "TxnDirection" -> return $ TxnDirection (read contents::BookDirection) - "FundWith" -> let - sv = T.splitOn (T.pack ",") $ T.pack contents - in - return $ FundWith (T.unpack (head sv)) (read (T.unpack (sv!!1))::Balance) --- toJSON (IssuanceProceeds nb) = String $ T.pack $ "" - "IssuanceProceeds" -> return $ IssuanceProceeds contents - "Tag" -> return $ Tag contents - _ -> fail ("parseTxn: invalid or unsupported txn comment: " ++ show t) - where - pat = "<(\\S+):(\\S+)>"::String - sr = (T.unpack t =~ pat)::[[String]] - tagName = case sr of - ((_:x:_):_) -> x::String - _ -> "" - contents = case sr of - (([_,_,x]):_) -> x::String - _ -> "" + parseJSON (Array vs) = TxnComments . V.toList <$> mapM parseJSON vs + parseJSON v = withText "TxnComment" parseTxn v + +-- | Strict canonical decoder: every tag has exactly one grammar, mirroring +-- 'txnPayload'. Legacy and malformed forms fail with a descriptive 'Parser' +-- error instead of throwing. +parseTxn :: T.Text -> Parser TxnComment +parseTxn "" = pure Empty +parseTxn t = + case txnSplitComment t of + Nothing -> txnFail + Just (tag, contents) -> case tag of + "Transfer" -> do + (a1, a2) <- txnField2 tag contents + pure $ Transfer (T.unpack a1) (T.unpack a2) + "Support" -> pure $ LiquidationSupport (T.unpack contents) + "PayInt" -> pure $ PayInt (txnNames contents) + "PayYield" -> pure $ PayYield (T.unpack contents) + "PayPrin" -> pure $ PayPrin (txnNames contents) + "WriteOff" -> do + (bn, amt) <- txnField2 tag contents + b <- txnReadField tag amt + pure $ WriteOff (T.unpack bn) b + "PayPrinResidual" -> pure $ PayPrinResidual (txnNames contents) + "PayFee" -> pure $ PayFee (T.unpack contents) + "SeqPayFee" -> pure $ SeqPayFee (txnNames contents) + "PayFeeYield" -> pure $ PayFeeYield (T.unpack contents) + "TransferBy" -> do + (a1, a2, lm) <- txnField3 tag contents + l <- txnReadField tag lm + pure $ TransferBy (T.unpack a1) (T.unpack a2) l + "Pool" -> do + (idsPart, srcPart) <- txnField2 tag contents + src <- txnReadField tag srcPart + mIds <- if T.null idsPart + then pure Nothing + else Just <$> mapM (txnReadField tag) (T.splitOn "|" idsPart) + pure $ PoolInflow mIds src + "Liquidation" -> LiquidationProceeds <$> mapM (txnReadField tag) (txnSplitFields contents) + "DS" -> UsingDS <$> txnReadField tag contents + "SupportExp" -> do + (b1t, b2t) <- txnField2 tag contents + b1 <- txnReadField tag b1t + b2 <- txnReadField tag b2t + pure $ LiquidationSupportInt b1 b2 + "SupportDraw" -> txnNoPayload tag contents >> pure SupportDraw + "Draw" -> txnNoPayload tag contents >> pure LiquidationDraw + "Repay" -> pure $ LiquidationRepay (T.unpack contents) + "Accure" -> txnNoPayload tag contents >> pure SwapAccrue + "SettleIn" -> pure $ SwapInSettle (T.unpack contents) + "SettleOut" -> pure $ SwapOutSettle (T.unpack contents) + "PurchaseAsset" -> do + (nm, amt) <- txnField2 tag contents + b <- txnReadField tag amt + pure $ PurchaseAsset (T.unpack nm) b + "TxnDirection" -> TxnDirection <$> txnReadField tag contents + "FundWith" -> do + (bn, amt) <- txnField2 tag contents + b <- txnReadField tag amt + pure $ FundWith (T.unpack bn) b + "IssuanceProceeds" -> pure $ IssuanceProceeds (T.unpack contents) + "Tag" -> pure $ Tag (T.unpack contents) + "PayGroupInt" -> pure $ PayGroupInt (txnNames contents) + "PayGroupPrin" -> pure $ PayGroupPrin (txnNames contents) + "BookLedger" -> do + (drt, lName) <- txnField2 tag contents + dr <- txnReadField tag drt + pure $ BookLedgerBy dr (T.unpack lName) + "BankInt" -> txnNoPayload tag contents >> pure BankInt + _ -> txnFail + where + txnFail = fail ("parseTxn: invalid or unsupported txn comment: " ++ show t + ++ " (expected canonical form '')") mapKVTraversal :: Traversal' (Map.Map k a) (k, a) diff --git a/test/UT/LibTest.hs b/test/UT/LibTest.hs index fec91312..058717fe 100644 --- a/test/UT/LibTest.hs +++ b/test/UT/LibTest.hs @@ -254,9 +254,27 @@ seqFunTest = ] libSafetyTests = - let + let d = toDate "20220101" - in + -- one witness per TxnComment constructor, incl. edge shapes + -- (empty lists, multi-element lists, colon-bearing content, nested comments) + txnWitnesses = + [ PayInt [], PayInt ["B1","B2"], PayYield "B1", PayPrin ["B1","B2"] + , PayGroupPrin ["B1"], PayGroupInt ["B1","B2"] + , WriteOff "B1" 10.5, FundWith "B1" 20, PayPrinResidual ["B1","B2"] + , PayFee "F1", SeqPayFee [], SeqPayFee ["F1","F2"], PayFeeYield "F1" + , Transfer "A1" "A2", TransferBy "A1" "A2" (DueCapAmt 30) + , BookLedgerBy Credit "L1", BookLedgerBy Debit "L2" + , PoolInflow Nothing CollectedInterest + , PoolInflow (Just [PoolName "p1", PoolConsol]) CollectedCash + , LiquidationProceeds [PoolName "p1", PoolConsol] + , LiquidationSupport "src", LiquidationDraw, LiquidationRepay "r" + , LiquidationSupportInt 1.5 2.5, BankInt, SupportDraw, Empty, Tag "a:b,c" + , UsingDS CurrentBondBalance, SwapAccrue, SwapInSettle "s1", SwapOutSettle "s2" + , PurchaseAsset "P1" 5, IssuanceProceeds "nb" + , TxnDirection Credit, TxnDirection Debit + , TxnComments [BankInt, Transfer "a" "b"] ] + in testGroup "library safety (total head/last)" [ testCase "getValByDate on empty ThresholdCurve returns 0" $ @@ -281,4 +299,24 @@ libSafetyTests = case (A.fromJSON (A.String "") :: A.Result TxnComment) of A.Success (Tag t) -> t == "hello" _ -> False + , testCase "TxnComment codec roundtrips every constructor" $ + mapM_ (\v -> assertEqual ("roundtrip of " ++ show v) (A.Success v) + (A.fromJSON (A.toJSON v) :: A.Result TxnComment)) + txnWitnesses + , testCase "TxnComment codec rejects legacy and malformed forms cleanly" $ + mapM_ (\s -> assertBool ("should reject " ++ show s) + (case (A.fromJSON (A.String s) :: A.Result TxnComment) of + A.Error _ -> True + A.Success _ -> False)) + [ "" -- legacy literal, no colon + , "" -- pre-0.52.8 encoder output + , "" -- legacy embedded-colon form + , "" -- legacy colon-separated ids/source + , "" -- bare ledger name (no direction) + , "" -- payload on a no-payload tag + , "" -- wrong arity + , "" -- malformed Balance + , "" -- malformed DealStats + , "" -- unknown tag + ] ] From 5ce395b6ee6de4f3a52954b000ab392235eb3ea8 Mon Sep 17 00:00:00 2001 From: yellowbean Date: Sat, 17 Oct 2026 11:47:55 +0800 Subject: [PATCH 26/40] Fix#345: ServerConfig per-endpoint run caps and worker precedence; config.yml schema --- CHANGELOG.md | 7 ++ Hastructure.cabal | 3 +- app/Main.hs | 155 ++++++++++++++++++++++++++------------------ config.yml | 9 ++- src/ServerConfig.hs | 115 ++++++++++++++++++++++++++++++++ src/Util.hs | 16 +---- swagger.json | 24 ++++++- test/MainTest.hs | 2 + test/UT/UtilTest.hs | 56 +++++++++++++++- 9 files changed, 303 insertions(+), 84 deletions(-) create mode 100644 src/ServerConfig.hs diff --git a/CHANGELOG.md b/CHANGELOG.md index c7d77b4b..29835122 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,13 @@ # Changelog for Hastructure +## 0.52.9 +### 2026-10-17 +* FIX: #345 the `maxScenario` / `maxDealNum` limits declared in `config.yml` were dead configuration: the engine never read them and scenario/deal grids were unbounded (DoS via large `runByCombo` cartesian products). Each multi-run endpoint (`runPoolByScenarios`, `runDealByScenarios`, `runMultiDeals`, `runDealByRunScenarios`, `runByCombo`) now enforces a per-request total-run cap, default 1000, configurable per endpoint via the new `maxRunNum.` keys in `config.yml`; `runByCombo` sizes the cartesian product before materialising it, so oversized grids are rejected without allocation. Oversized requests are rejected with HTTP 400 naming the endpoint, the configured limit and the key to raise. The in-flight worker cap is now configurable via `workerNum` in `config.yml` (precedence: `HASTRUCTURE_WORKERS` env > `workerNum` > RTS `-N`); the internal `unsafePerformIO` global is gone. +* FIX: BEHAVIOR CHANGE: a malformed `config.yml`, a missing `port` or a non-positive `maxRunNum.*` value now aborts startup with a descriptive error instead of silently falling back to defaults; the startup log prints the effective port, worker count and per-endpoint limits. The unused `maxScenario`/`maxDealNum` keys are removed from `config.yml`. +## 0.52.8 +### 2026-10-17 +* FIX: #328 the `TxnComment` JSON codec is now total and self-consistent: malformed, legacy or wrong-arity comment strings fail with a descriptive Aeson parse error instead of throwing (`head`/`!!`/`read` and the greedy regex are gone); the encoder emits canonical forms for `BankInt` (``), `PoolInflow` (``), `LiquidationSupportInt` (``) and `BookLedgerBy` (``), all of which now round-trip; multi-bond list comments decode to their elements; `TxnComments` arrays can be decoded; `Read PoolId` no longer throws and accepts what `Show PoolId` produces ## 0.52.7 ### 2026-10-17 * ENHANCE: #346 enable parallel compute on multi-deals and multi-scenarios diff --git a/Hastructure.cabal b/Hastructure.cabal index 150d9d6e..3d20c668 100644 --- a/Hastructure.cabal +++ b/Hastructure.cabal @@ -5,7 +5,7 @@ cabal-version: 3.0 -- see: https://github.com/sol/hpack name: Hastructure -version: 0.52.8 +version: 0.52.9 synopsis: Cashflow modeling library for structured finance description: Please see the README on GitHub at category: StructuredFinance,Securitisation,Cashflow @@ -65,6 +65,7 @@ library Pool Reports Revolving + ServerConfig Stmt Triggers Types diff --git a/app/Main.hs b/app/Main.hs index ea7a655a..3fd2263b 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -15,7 +15,6 @@ module Main import Prelude () import Prelude.Compat import System.Environment -import System.IO.Unsafe (unsafePerformIO) import GHC.Conc (getNumCapabilities) import Control.Monad.IO.Class (liftIO) import Control.Monad (mapM) @@ -58,7 +57,8 @@ import Servant.API.ContentTypes (contentType) import Types import MainBase -import Util (boundedParMap,resolveWorkerCap) +import Util (boundedParMap) +import ServerConfig import qualified Deal as D import qualified Deal.DealBase as DB import qualified Deal.DealDate as DD @@ -200,33 +200,15 @@ engineSwagger:: OpenApi engineSwagger = toOpenApi engineAPI & info.title .~ "Hastructure API" & info.version .~ T.pack (_version version1) - & info.description ?~ "Hastructure is a white-label friendly Cashflow & Analytics Engine for MBS/ABS and REITs" + & info.description ?~ (T.pack + "Hastructure is a white-label friendly Cashflow & Analytics Engine for MBS/ABS and REITs.\ + \ Multi-run endpoints (runPoolByScenarios, runDealByScenarios, runMultiDeals, runDealByRunScenarios, runByCombo) are capped per request by the maxRunNum. keys in config.yml (default 1000); oversized requests are rejected with HTTP 400.") & info.license ?~ "BSD 3" -- showVersion :: Handler (Envelope '[] Version) showVersion :: Handler Version showVersion = return version1 --- | Upper bound on the number of scenarios/deals evaluated concurrently, i.e. --- on in-flight sparks. This is a bound on in-flight *evaluation* rather than on --- threads: the RTS limits real concurrency to @-N@ capabilities and nested --- asset-level 'parMap' inside each run self-throttles via work-stealing --- (unevaluated sparks simply wait, or fall back to sequential evaluation when --- demanded — see the @SPARKS@ counters printed by @+RTS -s@). The bound --- therefore controls peak heap from concurrent deal states on large grids --- (e.g. 'runDealByCombo's cartesian product), not parallelism. --- --- Resolution order: the @HASTRUCTURE_WORKERS@ environment variable when it --- parses to a positive integer — it may exceed @-N@, acting as evaluation --- lookahead — otherwise the RTS capability count (@-N@). See --- 'resolveWorkerCap' (unit-tested) for the pure decision logic. -{-# NOINLINE maxParallelWorkers #-} -maxParallelWorkers :: Int -maxParallelWorkers = unsafePerformIO $ do - caps <- getNumCapabilities - env <- lookupEnv "HASTRUCTURE_WORKERS" - pure $ resolveWorkerCap caps env - runAsset :: RunAssetReq -> Handler RunAssetResp runAsset req = return $ wrapRunAsset req @@ -235,10 +217,34 @@ runPool (SingleRunPoolReq f pt passumption mRates) = return $ patchCumulativeToPoolRun <$> wrapRunPoolType f pt passumption mRates -runPoolScenarios :: RunPoolReq -> Handler (Map.Map ScenarioName PoolRunResp) -runPoolScenarios (MultiScenarioRunPoolReq f pt mAssumps mRates) - = return $ boundedParMap maxParallelWorkers - (\assump -> patchCumulativeToPoolRun <$> wrapRunPoolType f pt (Just assump) mRates) +-- | Per-request run bounding for a multi-run endpoint: the resolved worker +-- cap ('boundedParMap') plus the endpoint's total-run limit (#345). +data MultiRunCap = MultiRunCap { mcWorkers :: Int, mcMaxRuns :: Int } + +data ResolvedConfig = ResolvedConfig + { rcPort :: Int + , rcWorkers :: Int + , rcLimits :: RunLimits + } + +mkRunCap :: ResolvedConfig -> (RunLimits -> Int) -> MultiRunCap +mkRunCap rc getLim = MultiRunCap (rcWorkers rc) (getLim (rcLimits rc)) + +-- | Reject the request with HTTP 400 when its total run count exceeds the +-- endpoint's configured cap; the message names the endpoint, the limit and +-- the `maxRunNum.` config key to raise. +enforceRunCap :: String -> MultiRunCap -> Int -> Handler () +enforceRunCap ep cap n + = case checkRunNumLimit ep (mcMaxRuns cap) n of + Left msg -> throwError (err400 { errBody = cs msg }) + Right () -> return () + +runPoolScenarios :: MultiRunCap -> RunPoolReq -> Handler (Map.Map ScenarioName PoolRunResp) +runPoolScenarios cap (MultiScenarioRunPoolReq f pt mAssumps mRates) + = do + enforceRunCap "runPoolByScenarios" cap (Map.size mAssumps) + return $ boundedParMap (mcWorkers cap) + (\assump -> patchCumulativeToPoolRun <$> wrapRunPoolType f pt (Just assump) mRates) mAssumps runDeal :: RunDealReq -> Handler RunResp @@ -423,13 +429,17 @@ runRootFinderBy (RootFinderReq req@(dt,Just assumps,nonPerfAssump@AP.NonPerfAssu NotBracketed -> Left "Not able to bracket the root" SearchFailed -> Left "Not able to find the root" -runDealScenarios :: RunDealReq -> Handler (Map.Map ScenarioName RunResp) -runDealScenarios (MultiScenarioRunReq f dt mAssumps nonPerfAssump) - = return $ boundedParMap maxParallelWorkers (\singleAssump -> wrapRun f dt (Just singleAssump) nonPerfAssump) mAssumps +runDealScenarios :: MultiRunCap -> RunDealReq -> Handler (Map.Map ScenarioName RunResp) +runDealScenarios cap (MultiScenarioRunReq f dt mAssumps nonPerfAssump) + = do + enforceRunCap "runDealByScenarios" cap (Map.size mAssumps) + return $ boundedParMap (mcWorkers cap) (\singleAssump -> wrapRun f dt (Just singleAssump) nonPerfAssump) mAssumps -runMultiDeals :: RunDealReq -> Handler (Map.Map ScenarioName RunResp) -runMultiDeals (MultiDealRunReq f mDts assump nonPerfAssump) - = return $ boundedParMap maxParallelWorkers (\singleDealType -> wrapRun f singleDealType assump nonPerfAssump) mDts +runMultiDeals :: MultiRunCap -> RunDealReq -> Handler (Map.Map ScenarioName RunResp) +runMultiDeals cap (MultiDealRunReq f mDts assump nonPerfAssump) + = do + enforceRunCap "runMultiDeals" cap (Map.size mDts) + return $ boundedParMap (mcWorkers cap) (\singleDealType -> wrapRun f singleDealType assump nonPerfAssump) mDts runDate :: RunDateReq -> Handler [Date] runDate (RunDateReq sd dp md) @@ -438,31 +448,38 @@ runDate (RunDateReq sd dp md) Nothing -> DU.genSerialDatesTill2 IE sd dp (Lib.toDate "20990101") Just d -> DU.genSerialDatesTill2 IE sd dp d -runDealByRunScenarios :: RunDealReq -> Handler (Map.Map ScenarioName RunResp) -runDealByRunScenarios (MultiRunAssumpReq f dt mAssump nonPerfAssumpMap) - = return $ boundedParMap maxParallelWorkers (wrapRun f dt mAssump) nonPerfAssumpMap +runDealByRunScenarios :: MultiRunCap -> RunDealReq -> Handler (Map.Map ScenarioName RunResp) +runDealByRunScenarios cap (MultiRunAssumpReq f dt mAssump nonPerfAssumpMap) + = do + enforceRunCap "runDealByRunScenarios" cap (Map.size nonPerfAssumpMap) + return $ boundedParMap (mcWorkers cap) (wrapRun f dt mAssump) nonPerfAssumpMap -runDealByCombo :: RunDealReq -> Handler (Map.Map String RunResp) -runDealByCombo (MultiComboReq f dMap assumpMap nonPerfAssumpMap) - = let - inputs = Map.fromList [ (intercalate "^" [dk,ak,nk], (d,a,n)) +runDealByCombo :: MultiRunCap -> RunDealReq -> Handler (Map.Map String RunResp) +runDealByCombo cap (MultiComboReq f dMap assumpMap nonPerfAssumpMap) + = do + -- Size the cartesian product before materialising it: `Map.fromList` + -- below only shrinks (duplicate ^-joined keys), so the product is an + -- upper bound on the actual run count and an oversized request is + -- rejected without allocating it. + enforceRunCap "runByCombo" cap (Map.size dMap * Map.size assumpMap * Map.size nonPerfAssumpMap) + let inputs = Map.fromList [ (intercalate "^" [dk,ak,nk], (d,a,n)) | (dk,d) <- Map.toList dMap , (ak,a) <- Map.toList assumpMap , (nk,n) <- Map.toList nonPerfAssumpMap ] - in - return $ boundedParMap maxParallelWorkers (\(d,a,n) -> wrapRun f d a n) inputs + return $ boundedParMap (mcWorkers cap) (\(d,a,n) -> wrapRun f d a n) inputs -myServer :: ServerT API Handler -myServer = return engineSwagger - :<|> showVersion +myServer :: ResolvedConfig -> ServerT API Handler +myServer rc = + return engineSwagger + :<|> showVersion :<|> runAsset :<|> runPool - :<|> runPoolScenarios + :<|> runPoolScenarios (mkRunCap rc maxRunPoolByScenarios) :<|> runDeal - :<|> runDealScenarios - :<|> runMultiDeals - :<|> runDealByRunScenarios - :<|> runDealByCombo + :<|> runDealScenarios (mkRunCap rc maxRunDealByScenarios) + :<|> runMultiDeals (mkRunCap rc maxRunMultiDeals) + :<|> runDealByRunScenarios (mkRunCap rc maxRunDealByRunScenarios) + :<|> runDealByCombo (mkRunCap rc maxRunByCombo) :<|> runRootFinderBy :<|> runDate @@ -470,23 +487,35 @@ myServer = return engineSwagger writeSwaggerJSON :: IO () writeSwaggerJSON = BL8.writeFile "swagger.json" (encodePretty engineSwagger) -data Config = Config { port :: Int} - deriving (Show,Generic) +data Config = Config + { port :: Int + , workerNum :: Maybe Int + , maxRunNum :: Maybe RunLimitsRaw + } deriving (Show,Generic) instance FromJSON Config -app :: Application -app = simpleCors $ serve (Proxy :: Proxy API) myServer +app :: ResolvedConfig -> Application +app rc = simpleCors $ serve (Proxy :: Proxy API) (myServer rc) main :: IO () -main = - do +main = + do writeSwaggerJSON - config <- BS.readFile "config.yml" + raw <- BS.readFile "config.yml" curTime <- getCurrentTime - let mc = Y.decodeEither' config :: Either ParseException Config - let (Config _p) = case mc of - Left exp -> Config 8081 - Right c -> c - print (show curTime ++ ">> Engine start with version:"++ _version version1++";running at Port:"++ show _p) - run _p app + cfg <- either (failConfig . show) pure (Y.decodeEither' raw :: Either ParseException Config) + limits <- either failConfig pure (resolveRunLimits (fromMaybe emptyRunLimitsRaw (maxRunNum cfg))) + caps <- getNumCapabilities + mWorkers <- lookupEnv "HASTRUCTURE_WORKERS" + let rc = ResolvedConfig (port cfg) + (resolveWorkerNum caps (workerNum cfg) mWorkers) + limits + print (show curTime ++ ">> Engine start with version:"++ _version version1 + ++ ";running at Port:" ++ show (rcPort rc) + ++ ";workers:" ++ show (rcWorkers rc) + ++ ";maxRunNum:" ++ show (rcLimits rc)) + run (rcPort rc) (app rc) + where + failConfig :: String -> IO a + failConfig msg = throwIO (userError ("invalid config.yml: " ++ msg)) diff --git a/config.yml b/config.yml index fbfccd4a..c413a541 100644 --- a/config.yml +++ b/config.yml @@ -1,3 +1,8 @@ port: 8081 -maxScenario : 10 -maxDealNum : 10 \ No newline at end of file +# workerNum: 8 # in-flight cap per multi-run request; default: HASTRUCTURE_WORKERS env, else RTS -N +maxRunNum: # per-endpoint total-run caps per request; default 1000 each, non-positive values abort startup + runPoolByScenarios: 1000 + runDealByScenarios: 1000 + runMultiDeals: 1000 + runDealByRunScenarios: 1000 + runByCombo: 1000 diff --git a/src/ServerConfig.hs b/src/ServerConfig.hs new file mode 100644 index 00000000..c8bd2107 --- /dev/null +++ b/src/ServerConfig.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Server-side request bounding for the multi-run HTTP endpoints (#345). +-- +-- The engine accepts scenario\/deal maps and cartesian grids whose size is +-- chosen by the client; unbounded, these are a denial-of-service vector +-- (memory and CPU). Each multi-run endpoint has its own total-run cap +-- ('RunLimits', mirrored 1:1 by the @maxRunNum.\@ keys in +-- @config.yml@) and its in-flight evaluation is bounded by a worker cap +-- resolved from config \/ environment \/ RTS capabilities +-- ('resolveWorkerNum'). +module ServerConfig + ( defaultRunNum + , resolveRunNum + , RunLimitsRaw(..) + , emptyRunLimitsRaw + , RunLimits(..) + , resolveRunLimits + , checkRunNumLimit + , resolveWorkerNum + , resolveWorkerCap + ) + where + +import Data.Aeson (FromJSON(..), withObject, (.:?)) +import GHC.Generics (Generic) +import Text.Read (readMaybe) + +-- | Default total-run cap per multi-run request. +defaultRunNum :: Int +defaultRunNum = 1000 + +-- | Resolve a single @maxRunNum@ value: an absent key takes 'defaultRunNum', +-- a present value must be positive. +resolveRunNum :: Maybe Int -> Either String Int +resolveRunNum Nothing = Right defaultRunNum +resolveRunNum (Just n) + | n > 0 = Right n + | otherwise = Left ("invalid value " ++ show n ++ ": must be a positive integer") + +-- | The raw @maxRunNum@ block as parsed from @config.yml@; every key is +-- optional. JSON keys mirror the HTTP endpoint names. +data RunLimitsRaw = RunLimitsRaw + { rawRunPoolByScenarios :: Maybe Int + , rawRunDealByScenarios :: Maybe Int + , rawRunMultiDeals :: Maybe Int + , rawRunDealByRunScenarios :: Maybe Int + , rawRunByCombo :: Maybe Int + } deriving (Show,Generic) + +-- | A @maxRunNum@ block entirely absent from @config.yml@. +emptyRunLimitsRaw :: RunLimitsRaw +emptyRunLimitsRaw = RunLimitsRaw Nothing Nothing Nothing Nothing Nothing + +instance FromJSON RunLimitsRaw where + parseJSON = withObject "maxRunNum" $ \v -> RunLimitsRaw + <$> v .:? "runPoolByScenarios" + <*> v .:? "runDealByScenarios" + <*> v .:? "runMultiDeals" + <*> v .:? "runDealByRunScenarios" + <*> v .:? "runByCombo" + +-- | Resolved per-endpoint total-run caps. Field names mirror the HTTP +-- endpoints; the @config.yml@ keys are @maxRunNum.\@. +data RunLimits = RunLimits + { maxRunPoolByScenarios :: Int + , maxRunDealByScenarios :: Int + , maxRunMultiDeals :: Int + , maxRunDealByRunScenarios :: Int + , maxRunByCombo :: Int + } deriving (Show,Eq) + +-- | Fill the per-endpoint defaults and validate every cap, naming the +-- offending key in the error. +resolveRunLimits :: RunLimitsRaw -> Either String RunLimits +resolveRunLimits (RunLimitsRaw a b c d e) + = RunLimits <$> key "runPoolByScenarios" a + <*> key "runDealByScenarios" b + <*> key "runMultiDeals" c + <*> key "runDealByRunScenarios" d + <*> key "runByCombo" e + where + key nm mv = case resolveRunNum mv of + Right n -> Right n + Left msg -> Left ("maxRunNum." ++ nm ++ ": " ++ msg) + +-- | Reject a multi-run request whose total run count exceeds the endpoint +-- cap. @ep@ is the endpoint name; it is both the subject of the message and +-- the @maxRunNum.\@ config key path quoted in it. +checkRunNumLimit :: String -> Int -> Int -> Either String () +checkRunNumLimit ep lim n + | n <= lim = Right () + | otherwise = + let key = "maxRunNum." ++ ep + in Left ( ep ++ " would run " ++ show n ++ " runs, exceeding " ++ key ++ " " ++ show lim + ++ " (config.yml); reduce the request size or raise " ++ key + ++ " in config.yml and restart the engine" ) + +-- | Resolve the in-flight worker cap for the multi-run endpoints. Precedence: +-- the @HASTRUCTURE_WORKERS@ environment variable when it parses to a positive +-- 'Int' (kept for container deployments that set it today), then the +-- @workerNum@ key in @config.yml@, then the RTS capability count (@-N@). +-- A present-but-invalid value at either layer falls back to the next one — +-- workers is a performance knob, unlike 'RunLimits' which fails fast. +resolveWorkerNum :: Int -> Maybe Int -> Maybe String -> Int +resolveWorkerNum caps mCfg mEnv + | Just n <- mEnv >>= readMaybe, n > 0 = n + | Just n <- mCfg, n > 0 = n + | otherwise = caps + +-- | Two-layer special case of 'resolveWorkerNum' (RTS caps \/ environment), +-- preserved for existing callers and tests. +resolveWorkerCap :: Int -> Maybe String -> Int +resolveWorkerCap caps mEnv = resolveWorkerNum caps Nothing mEnv diff --git a/src/Util.hs b/src/Util.hs index 872bf0fc..72e8c832 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -13,7 +13,7 @@ module Util ,lastOf,findBox,safeDivide', safeDiv ,safeDivide,lstToMapByFn,paySequentially,payProRata,mapWithinMap ,payInMap,payInMapM,adjustM,adjustMs,mapInMapM,lookupAndApply,lookupAndUpdate,lookupAndApplies - ,lookupInMap,selectInMap,scaleByFstElement,boundedParMap,resolveWorkerCap + ,lookupInMap,selectInMap,scaleByFstElement,boundedParMap ,lookupTuple6 ,lookupTuple7,diffNum,splitBal,lookupM,lookupVs ,lookupMM -- for debug @@ -38,7 +38,6 @@ import Text.Printf import Control.Exception import Control.Parallel.Strategies (parBuffer, rseq, using) -import Text.Read (readMaybe) import Data.Time (addDays) import Debug.Trace debug = flip trace @@ -278,19 +277,6 @@ boundedParMap n f m = vs' = (map f vs) `using` parBuffer (max 1 n) rseq in Map.fromList (zip ks vs') --- | Resolve the parallel-worker cap used by the multi-scenario\/multi-deal --- endpoints (see 'boundedParMap'). @caps@ is the RTS capability count (@-N@) --- and @mEnv@ is the value of the @HASTRUCTURE_WORKERS@ environment variable. --- An explicit override wins when it parses to a positive 'Int' — it may exceed --- @caps@, because the bound caps in-flight evaluation (peak heap) rather than --- real concurrency. Missing, unparsable, zero or negative values fall back to --- @caps@. -resolveWorkerCap :: Int -> Maybe String -> Int -resolveWorkerCap caps mEnv = - case mEnv >>= readMaybe of - Just n | n > 0 -> n - _ -> caps - lastOf:: [a] -> (a->Bool) -> Maybe a lastOf [] fn = Nothing lastOf xs fn = diff --git a/swagger.json b/swagger.json index 468c9c00..531a05c3 100644 --- a/swagger.json +++ b/swagger.json @@ -3302,6 +3302,26 @@ "title": "PrepaymentCPR", "type": "object" }, + { + "properties": { + "contents": { + "format": "double", + "type": "number" + }, + "tag": { + "enum": [ + "PrepaymentABS" + ], + "type": "string" + } + }, + "required": [ + "tag", + "contents" + ], + "title": "PrepaymentABS", + "type": "object" + }, { "properties": { "contents": { @@ -21464,12 +21484,12 @@ } }, "info": { - "description": "Hastructure is a white-label friendly Cashflow & Analytics Engine for MBS/ABS and REITs", + "description": "Hastructure is a white-label friendly Cashflow & Analytics Engine for MBS/ABS and REITs. Multi-run endpoints (runPoolByScenarios, runDealByScenarios, runMultiDeals, runDealByRunScenarios, runByCombo) are capped per request by the maxRunNum. keys in config.yml (default 1000); oversized requests are rejected with HTTP 400.", "license": { "name": "BSD 3" }, "title": "Hastructure API", - "version": "0.52.4" + "version": "0.52.9" }, "openapi": "3.0.0", "paths": { diff --git a/test/MainTest.hs b/test/MainTest.hs index c7022789..1fba81a5 100644 --- a/test/MainTest.hs +++ b/test/MainTest.hs @@ -112,6 +112,8 @@ tests = testGroup "Tests" [AT.mortgageTests ,UtilT.mapUpdateTest ,UtilT.boundedParMapTest ,UtilT.resolveWorkerCapTest + ,UtilT.workerNumTest + ,UtilT.serverConfigLimitTest ,AccT.intTests ,AccT.investTests ,AccT.reserveAccTest diff --git a/test/UT/UtilTest.hs b/test/UT/UtilTest.hs index 9ea4a0b9..c0c197f6 100644 --- a/test/UT/UtilTest.hs +++ b/test/UT/UtilTest.hs @@ -3,7 +3,8 @@ module UT.UtilTest(daycountTests1,daycountTests2,daycountTests3,daycountTests4 ,tsTest,ts2Test,ts3Test,dateVectorPatternTest,paddingTest,dateSliceTest ,capTest,roundingTest,sliceTest,splitTsTest,tableTest,lastOftest,paySeqTest - ,scaleListTest,mapUpdateTest,boundedParMapTest,resolveWorkerCapTest)--,daycountTests3,daycountTests4) + ,scaleListTest,mapUpdateTest,boundedParMapTest,resolveWorkerCapTest + ,workerNumTest,serverConfigLimitTest)--,daycountTests3,daycountTests4) where import Test.Tasty @@ -23,7 +24,9 @@ import qualified Data.DList as DL import Data.Ratio ((%)) import qualified Data.Map as Map import Data.Either +import Data.List (isInfixOf) +import ServerConfig import Debug.Trace debug = flip trace @@ -730,4 +733,55 @@ resolveWorkerCapTest = assertEqual "negative" 4 (resolveWorkerCap 4 (Just "-3")) , testCase "unparsable override falls back" $ assertEqual "garbage" 4 (resolveWorkerCap 4 (Just "garbage")) + ] + +workerNumTest :: TestTree +workerNumTest = + testGroup "resolveWorkerNum" + [ testCase "config wins over capability count" $ + assertEqual "config" 8 (resolveWorkerNum 4 (Just 8) Nothing) + , testCase "env wins over config and capability count" $ + assertEqual "env" 16 (resolveWorkerNum 4 (Just 8) (Just "16")) + , testCase "unparsable env falls back to config" $ + assertEqual "garbage-env" 8 (resolveWorkerNum 4 (Just 8) (Just "garbage")) + , testCase "negative env falls back to config" $ + assertEqual "neg-env" 8 (resolveWorkerNum 4 (Just 8) (Just "-3")) + , testCase "invalid config falls back to capability count" $ + assertEqual "bad-config" 4 (resolveWorkerNum 4 (Just 0) Nothing) + , testCase "nothing set falls back to capability count" $ + assertEqual "caps" 4 (resolveWorkerNum 4 Nothing Nothing) + ] + +serverConfigLimitTest :: TestTree +serverConfigLimitTest = + testGroup "ServerConfig run limits" + [ testCase "resolveRunNum defaults when key is missing" $ + assertEqual "default" (Right 1000) (resolveRunNum Nothing) + , testCase "resolveRunNum accepts a positive value" $ + assertEqual "positive" (Right 1) (resolveRunNum (Just 1)) + , testCase "resolveRunNum rejects zero" $ + assertBool "zero" (isLeft (resolveRunNum (Just 0))) + , testCase "resolveRunNum rejects a negative value" $ + assertBool "negative" (isLeft (resolveRunNum (Just (-3)))) + , testCase "checkRunNumLimit passes at the limit" $ + assertEqual "at-limit" (Right ()) (checkRunNumLimit "runByCombo" 100 100) + , testCase "checkRunNumLimit passes with zero runs" $ + assertEqual "zero" (Right ()) (checkRunNumLimit "runByCombo" 100 0) + , testCase "checkRunNumLimit rejects over the limit with endpoint, key, limit and config suggestion" $ + case checkRunNumLimit "runByCombo" 100 150 of + Left msg -> do + assertBool "mentions endpoint and actual" ("runByCombo would run 150" `isInfixOf` msg) + assertBool "mentions key path" ("exceeding maxRunNum.runByCombo 100" `isInfixOf` msg) + assertBool "suggests config change" ("raise maxRunNum.runByCombo in config.yml" `isInfixOf` msg) + Right () -> assertFailure "expected Left" + , testCase "resolveRunLimits fills defaults for missing keys" $ + assertEqual "defaults" (Right (RunLimits 1000 1000 1000 1000 1000)) + (resolveRunLimits (RunLimitsRaw Nothing Nothing Nothing Nothing Nothing)) + , testCase "resolveRunLimits keeps explicit values" $ + assertEqual "explicit" (Right (RunLimits 1 2 3 4 5)) + (resolveRunLimits (RunLimitsRaw (Just 1) (Just 2) (Just 3) (Just 4) (Just 5))) + , testCase "resolveRunLimits rejects a bad key naming it" $ + case resolveRunLimits (RunLimitsRaw Nothing Nothing Nothing (Just 0) Nothing) of + Left msg -> assertBool "names the offending key" ("maxRunNum.runDealByRunScenarios" `isInfixOf` msg) + Right _ -> assertFailure "expected Left" ] \ No newline at end of file From e55f7ed7daf48d27fe126547893e2347b5697abf Mon Sep 17 00:00:00 2001 From: yellowbean Date: Sat, 17 Oct 2026 12:47:28 +0800 Subject: [PATCH 27/40] Fix#344: add json error boundary on warp --- CHANGELOG.md | 1 + Hastructure.cabal | 2 ++ app/Main.hs | 28 ++++++++++++++++++++++++++-- 3 files changed, 29 insertions(+), 2 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 29835122..86850090 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,6 +3,7 @@ ## 0.52.9 ### 2026-10-17 +* FIX: #344 add a JSON error boundary at the Warp level: exceptions escaping the request pipeline (pure `error` calls, partial accessors, pattern failures) now answer 500 with the same envelope as in-band failures (`{"Left":"engine error: …"}`) and the CORS header, instead of Warp's opaque plain-text 500; server-side exception logging is unchanged * FIX: #345 the `maxScenario` / `maxDealNum` limits declared in `config.yml` were dead configuration: the engine never read them and scenario/deal grids were unbounded (DoS via large `runByCombo` cartesian products). Each multi-run endpoint (`runPoolByScenarios`, `runDealByScenarios`, `runMultiDeals`, `runDealByRunScenarios`, `runByCombo`) now enforces a per-request total-run cap, default 1000, configurable per endpoint via the new `maxRunNum.` keys in `config.yml`; `runByCombo` sizes the cartesian product before materialising it, so oversized grids are rejected without allocation. Oversized requests are rejected with HTTP 400 naming the endpoint, the configured limit and the key to raise. The in-flight worker cap is now configurable via `workerNum` in `config.yml` (precedence: `HASTRUCTURE_WORKERS` env > `workerNum` > RTS `-N`); the internal `unsafePerformIO` global is gone. * FIX: BEHAVIOR CHANGE: a malformed `config.yml`, a missing `port` or a non-positive `maxRunNum.*` value now aborts startup with a descriptive error instead of silently falling back to defaults; the startup log prints the effective port, worker count and per-endpoint limits. The unused `maxScenario`/`maxDealNum` keys are removed from `config.yml`. ## 0.52.8 diff --git a/Hastructure.cabal b/Hastructure.cabal index 3d20c668..a2868599 100644 --- a/Hastructure.cabal +++ b/Hastructure.cabal @@ -160,6 +160,8 @@ executable Hastructure-exe servant-openapi3, servant-server, wai, + http-types, + case-insensitive, warp, split, string-conversions, diff --git a/app/Main.hs b/app/Main.hs index 3fd2263b..29fb9e08 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -18,7 +18,7 @@ import System.Environment import GHC.Conc (getNumCapabilities) import Control.Monad.IO.Class (liftIO) import Control.Monad (mapM) -import Control.Exception (Exception,throwIO,throw) +import Control.Exception (Exception,throwIO,throw,SomeException,displayException) import Control.Monad.Except import Control.Monad.Reader import Data.Aeson @@ -50,6 +50,12 @@ import Network.Wai.Middleware.Cors -- import qualified Data.Aeson.Parser import Language.Haskell.TH --import Network.HTTP.Types.Status +import Network.HTTP.Types (status500,hContentType) +import Data.CaseInsensitive (mk) +import qualified Network.Wai as Wai +import qualified Data.Aeson as Aeson +import Network.HTTP.Types (status500,hContentType) +import Data.CaseInsensitive (mk) import Servant.OpenApi import Servant import Servant.Types.SourceT (source) @@ -498,6 +504,24 @@ instance FromJSON Config app :: ResolvedConfig -> Application app rc = simpleCors $ serve (Proxy :: Proxy API) (myServer rc) +-- | Render any exception escaping the request pipeline in the SAME JSON +-- envelope that in-band 'Either ErrorRep' responses use (@{"Left":"…"}@), plus +-- the CORS header so browser clients can read it. Logging stays on Warp's +-- default logger — this only changes the rendering. Connection-level failures +-- (resets\/timeouts) keep Warp's default rendering behavior: they should not +-- receive an HTTP response at all. +errorBoundary :: SomeException -> Wai.Response +errorBoundary e = + responseLBS status500 + [ (hContentType, "application/json") + , (mk "Access-Control-Allow-Origin", "*") + ] + (Aeson.encode (Left (T.pack ("engine error: " ++ displayException e)) :: Either T.Text Value)) + +-- | Server settings: port from @config.yml@ plus the JSON error boundary. +warpSettings :: Int -> Settings +warpSettings p = setPort p $ setOnExceptionResponse errorBoundary defaultSettings + main :: IO () main = do @@ -515,7 +539,7 @@ main = ++ ";running at Port:" ++ show (rcPort rc) ++ ";workers:" ++ show (rcWorkers rc) ++ ";maxRunNum:" ++ show (rcLimits rc)) - run (rcPort rc) (app rc) + runSettings (warpSettings (rcPort rc)) (app rc) where failConfig :: String -> IO a failConfig msg = throwIO (userError ("invalid config.yml: " ++ msg)) From 742df51c0d3f0d081a3035ceb558dffa7607eda1 Mon Sep 17 00:00:00 2001 From: yellowbean Date: Sat, 17 Oct 2026 20:48:42 +0800 Subject: [PATCH 28/40] Fix#329: make API handlers total over request types - misroutes reject in-band (Left) or with HTTP 400; legacy RootFind shapes handled; CI pattern lock; bump to 0.52.10 --- CHANGELOG.md | 4 +++ Hastructure.cabal | 4 +-- app/Main.hs | 84 +++++++++++++++++++++++++++++++++++++---------- swagger.json | 2 +- 4 files changed, 74 insertions(+), 20 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 86850090..d4801464 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,10 @@ # Changelog for Hastructure +## 0.52.10 +### 2026-10-17 +* FIX: #329 the multi-run / single-run request handlers were non-exhaustive over `RunDealReq` / `RunPoolReq` / `RunAssetReq` / `RootFindReq`: a request decoded with the wrong constructor for the routed endpoint crashed with a pattern-match failure (now rendered as an opaque `engine error:` 500 by the #344 boundary). Every handler is now total. A misrouted request to a single-run endpoint (`runDeal`, `runPool`, `runAsset`) returns the reason in-band as `Left ": expected "`; map-valued multi-run endpoints (whose response type has no error slot) answer HTTP 400 with the same message, uniform with the #345 run-cap rejections. `wrapRunAsset` rejects non-`PoolLevel` assumption shapes (per-pool / per-index / obligor strategies and pricing without assumptions) in-band. +* FIX: #329 `runByRootFinder` no longer crashes on the legacy `FirstLossReq` / `MaxSpreadToFaceReq` request shapes (kept on the wire but unsupported; absbox composes `RootFinderReq` for both `runFirstLoss` and `runRootFinder`); a stress tweak (`stressDefault` / `stressPrepayment`) without pool assumptions is rejected with a descriptive error instead of crashing; the `BalanceFormula` stop condition is rejected as not implemented yet. The executable now compiles with `-Wincomplete-patterns -Werror=incomplete-patterns`, so any future non-exhaustive match in the API layer fails the build (the library is unchanged); note locally cabal needs one clean rebuild to pick up the new flags. ## 0.52.9 ### 2026-10-17 * FIX: #344 add a JSON error boundary at the Warp level: exceptions escaping the request pipeline (pure `error` calls, partial accessors, pattern failures) now answer 500 with the same envelope as in-band failures (`{"Left":"engine error: …"}`) and the CORS header, instead of Warp's opaque plain-text 500; server-side exception logging is unchanged diff --git a/Hastructure.cabal b/Hastructure.cabal index a2868599..3bf49d81 100644 --- a/Hastructure.cabal +++ b/Hastructure.cabal @@ -5,7 +5,7 @@ cabal-version: 3.0 -- see: https://github.com/sol/hpack name: Hastructure -version: 0.52.9 +version: 0.52.10 synopsis: Cashflow modeling library for structured finance description: Please see the README on GitHub at category: StructuredFinance,Securitisation,Cashflow @@ -129,7 +129,7 @@ executable Hastructure-exe Paths_Hastructure hs-source-dirs: app - ghc-options: -threaded -rtsopts -with-rtsopts=-N -Werror=missing-fields + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Werror=missing-fields -Wincomplete-patterns -Werror=incomplete-patterns build-depends: Hastructure, Decimal, diff --git a/app/Main.hs b/app/Main.hs index 29fb9e08..1d92db45 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -54,8 +54,6 @@ import Network.HTTP.Types (status500,hContentType) import Data.CaseInsensitive (mk) import qualified Network.Wai as Wai import qualified Data.Aeson as Aeson -import Network.HTTP.Types (status500,hContentType) -import Data.CaseInsensitive (mk) import Servant.OpenApi import Servant import Servant.Types.SourceT (source) @@ -182,6 +180,9 @@ wrapRunAsset (RunAssetReq d assets (Just (AP.PoolLevel assumps)) mRates (Just pm pricingResult <- traverse (\a -> D.priceAssetUnion a d pm assumps mRates) assets let (assetCf,_) = P.aggPool Nothing cfs return (assetCf , Just pricingResult) +-- asset projection supports pool-level assumptions only; anything else (per-pool/per-index/ +-- obligor strategies, or pricing without assumptions) is rejected without a run +wrapRunAsset _ = Left "runAsset: unsupported pool assumption shape" -- Swagger API type SwaggerAPI = "swagger.json" :> Get '[JSON] OpenApi @@ -222,6 +223,7 @@ runPool :: RunPoolReq -> Handler PoolRunResp runPool (SingleRunPoolReq f pt passumption mRates) = return $ patchCumulativeToPoolRun <$> wrapRunPoolType f pt passumption mRates +runPool (MultiScenarioRunPoolReq _ _ _ _) = return $ Left "runPool: expected SingleRunPoolReq" -- | Per-request run bounding for a multi-run endpoint: the resolved worker -- cap ('boundedParMap') plus the endpoint's total-run limit (#345). @@ -245,6 +247,13 @@ enforceRunCap ep cap n Left msg -> throwError (err400 { errBody = cs msg }) Right () -> return () +-- | Reject a request routed to an endpoint whose payload shape it does not +-- match (#329). Map-valued multi-run responses have no error slot, so the +-- rejection rides the HTTP status code instead; single-run endpoints return +-- the message as 'Left' in-band, matching the existing run-error convention. +badRequest :: String -> Handler a +badRequest msg = throwError (err400 { errBody = cs msg }) + runPoolScenarios :: MultiRunCap -> RunPoolReq -> Handler (Map.Map ScenarioName PoolRunResp) runPoolScenarios cap (MultiScenarioRunPoolReq f pt mAssumps mRates) = do @@ -252,9 +261,12 @@ runPoolScenarios cap (MultiScenarioRunPoolReq f pt mAssumps mRates) return $ boundedParMap (mcWorkers cap) (\assump -> patchCumulativeToPoolRun <$> wrapRunPoolType f pt (Just assump) mRates) mAssumps +runPoolScenarios _ _ + = badRequest "runPoolByScenarios: expected MultiScenarioRunPoolReq" runDeal :: RunDealReq -> Handler RunResp runDeal (SingleRunReq f dt assump nonPerfAssump) = return $ wrapRun f dt assump nonPerfAssump +runDeal _ = return $ Left "runDeal: expected SingleRunReq" -- Stressing default assumption from AssetPerfAssumption @@ -341,6 +353,9 @@ getDealFeeMap (VDeal d) = DB.fees d getDealFeeMap (PDeal d) = DB.fees d doTweak :: Double -> RootFindTweak -> DealRunInput -> DealRunInput +-- unreachable: 'runRootFinderBy' rejects stress tweaks when pool assumptions are absent +doTweak _ (StressPoolDefault _) inp@(_, Nothing, _, _) = inp + doTweak r (StressPoolDefault _) (dt , Just assumps, nonPerfAssump@AP.NonPerfAssumption{AP.revolving = mRevolving}, f) = let stressed = over (AP.applyAssumptionTypeAssetPerf . _1 ) (stressDefaultAssetPerf (toRational r)) assumps @@ -348,6 +363,9 @@ doTweak r (StressPoolDefault _) (dt , Just assumps, nonPerfAssump@AP.NonPerfAssu in (dt ,Just stressed, stressedNonPerf, f) +-- unreachable: 'runRootFinderBy' rejects stress tweaks when pool assumptions are absent +doTweak _ (StressPoolPrepayment _) inp@(_, Nothing, _, _) = inp + doTweak r (StressPoolPrepayment _) (dt , Just assumps, nonPerfAssump@AP.NonPerfAssumption{AP.revolving = mRevolving}, f) = let stressed = over (AP.applyAssumptionTypeAssetPerf . _1 ) (stressPrepayAssetPerf (toRational r)) assumps @@ -406,6 +424,9 @@ evalRootFindStop (BondMetTargetIrr bn target) (dt,_,_,pResult,osPflow) Nothing -> -1 -- `debug` ("No IRR found for bond:"++ show bn) Just irr -> (fromRational . toRational) $ irr - target -- `debug` ("IRR for bond:"++ show target ++" is "++ show irr) +-- unreachable: 'runRootFinderBy' rejects BalanceFormula stops before the search +evalRootFindStop (BalanceFormula _ _) _ = -1 + @@ -419,33 +440,58 @@ rootFindAlgo (dt ,poolAssumps, runAssumps, f) tweak stop r Left errorMsg -> -1 runRootFinderBy :: RootFindReq -> Handler (Either String RootFindResp) -runRootFinderBy (RootFinderReq req@(dt,Just assumps,nonPerfAssump@AP.NonPerfAssumption{AP.revolving = mRevolving},f) tweak stop) - = return $ - let - itertimes = 1000 - def = RiddersParam { riddersMaxIter = itertimes, riddersTol = RelTol 0.000001} - riddersFn = case tweak of - SplitFixedBalance _ _ (l,h) -> ridders def (min h 0.99, max l 0.00001) - StressPoolDefault (l,h) -> ridders def (h ,max l 0.00) - StressPoolPrepayment (l,h) -> ridders def (h ,max l 0.00) - MaxSpreadTo _ (l,h) -> ridders def (h ,max l 0.00) - in - case riddersFn (rootFindAlgo req tweak stop) of - Root r -> return $ RFResult r (doTweak r tweak req) - NotBracketed -> Left "Not able to bracket the root" - SearchFailed -> Left "Not able to find the root" +runRootFinderBy (FirstLossReq _ _) + = return $ Left "rootFinder: FirstLossReq is a legacy request type; compose RootFinderReq (absbox runFirstLoss does)" +runRootFinderBy (MaxSpreadToFaceReq _ _ _ _) + = return $ Left "rootFinder: MaxSpreadToFaceReq is a legacy request type; compose RootFinderReq (absbox runRootFinder does)" +runRootFinderBy req@(RootFinderReq runInput@(_,mAssumps,_,_) tweak stop) + | tweakNeedsPoolAssump tweak && isNothing mAssumps + = return $ Left "rootFinder: stressDefault/stressPrepayment requires pool assumptions" + | BalanceFormula{} <- stop + = return $ Left "rootFinder: BalanceFormula stop is not implemented yet" + | otherwise + = return $ runRidders runInput tweak stop + +-- | Bond-only tweaks modify the deal structure and need no pool assumptions; +-- the stress tweaks vary pool performance, so they do. +tweakNeedsPoolAssump :: RootFindTweak -> Bool +tweakNeedsPoolAssump (StressPoolDefault _) = True +tweakNeedsPoolAssump (StressPoolPrepayment _) = True +tweakNeedsPoolAssump _ = False + +-- | The ridders search itself; reached only after the guards in +-- 'runRootFinderBy' (legacy shapes, missing assumptions, unimplemented stops). +runRidders :: DealRunInput -> RootFindTweak -> RootFindStop -> Either String RootFindResp +runRidders runInput tweak stop + = let + itertimes = 1000 + def = RiddersParam { riddersMaxIter = itertimes, riddersTol = RelTol 0.000001} + riddersFn = case tweak of + SplitFixedBalance _ _ (l,h) -> ridders def (min h 0.99, max l 0.00001) + StressPoolDefault (l,h) -> ridders def (h ,max l 0.00) + StressPoolPrepayment (l,h) -> ridders def (h ,max l 0.00) + MaxSpreadTo _ (l,h) -> ridders def (h ,max l 0.00) + in + case riddersFn (rootFindAlgo runInput tweak stop) of + Root r -> return $ RFResult r (doTweak r tweak runInput) + NotBracketed -> Left "Not able to bracket the root" + SearchFailed -> Left "Not able to find the root" runDealScenarios :: MultiRunCap -> RunDealReq -> Handler (Map.Map ScenarioName RunResp) runDealScenarios cap (MultiScenarioRunReq f dt mAssumps nonPerfAssump) = do enforceRunCap "runDealByScenarios" cap (Map.size mAssumps) return $ boundedParMap (mcWorkers cap) (\singleAssump -> wrapRun f dt (Just singleAssump) nonPerfAssump) mAssumps +runDealScenarios _ _ + = badRequest "runDealByScenarios: expected MultiScenarioRunReq" runMultiDeals :: MultiRunCap -> RunDealReq -> Handler (Map.Map ScenarioName RunResp) runMultiDeals cap (MultiDealRunReq f mDts assump nonPerfAssump) = do enforceRunCap "runMultiDeals" cap (Map.size mDts) return $ boundedParMap (mcWorkers cap) (\singleDealType -> wrapRun f singleDealType assump nonPerfAssump) mDts +runMultiDeals _ _ + = badRequest "runMultiDeals: expected MultiDealRunReq" runDate :: RunDateReq -> Handler [Date] runDate (RunDateReq sd dp md) @@ -459,6 +505,8 @@ runDealByRunScenarios cap (MultiRunAssumpReq f dt mAssump nonPerfAssumpMap) = do enforceRunCap "runDealByRunScenarios" cap (Map.size nonPerfAssumpMap) return $ boundedParMap (mcWorkers cap) (wrapRun f dt mAssump) nonPerfAssumpMap +runDealByRunScenarios _ _ + = badRequest "runDealByRunScenarios: expected MultiRunAssumpReq" runDealByCombo :: MultiRunCap -> RunDealReq -> Handler (Map.Map String RunResp) runDealByCombo cap (MultiComboReq f dMap assumpMap nonPerfAssumpMap) @@ -473,6 +521,8 @@ runDealByCombo cap (MultiComboReq f dMap assumpMap nonPerfAssumpMap) , (ak,a) <- Map.toList assumpMap , (nk,n) <- Map.toList nonPerfAssumpMap ] return $ boundedParMap (mcWorkers cap) (\(d,a,n) -> wrapRun f d a n) inputs +runDealByCombo _ _ + = badRequest "runByCombo: expected MultiComboReq" myServer :: ResolvedConfig -> ServerT API Handler myServer rc = diff --git a/swagger.json b/swagger.json index 531a05c3..eff1b6af 100644 --- a/swagger.json +++ b/swagger.json @@ -21489,7 +21489,7 @@ "name": "BSD 3" }, "title": "Hastructure API", - "version": "0.52.9" + "version": "0.52.10" }, "openapi": "3.0.0", "paths": { From e33a7d9d43b7c636c0d31ab5c5935baa6b276409 Mon Sep 17 00:00:00 2001 From: yellowbean Date: Sat, 17 Oct 2026 21:33:52 +0800 Subject: [PATCH 29/40] Fix#332: totalize cashflow aggregation (NonEmpty sumTsCF, firstDate empty, CashFlow zero rows) --- CHANGELOG.md | 1 + src/Cashflow.hs | 26 ++++++++++++-------------- test/MainTest.hs | 1 + test/UT/CashflowTest.hs | 41 ++++++++++++++++++++++++++++++++++++++++- 4 files changed, 54 insertions(+), 15 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index d4801464..cf801571 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,6 +3,7 @@ ## 0.52.10 ### 2026-10-17 +* FIX: #332 `sumTsCF` now takes `NonEmpty TsRow` (source-level breaking for library consumers) instead of throwing on an empty group; the dead, unexported partial `sumTs` (`foldr1`) is removed; `firstDate` returns the frame's begin date for an empty frame (`epocDate` for `DummyCF`) instead of failing; `emptyTsRow` and `viewTsRow` gained the missing `CashFlow` clause so `extendCashFlow` / `buildCollectedCF` zero-row synthesis no longer crash on generic rows; `buildCollectedCF` lost its unreachable `error` clause. `aggTsByDates` keeps its signature and behavior (empty groups are skipped via `NE.nonEmpty`). * FIX: #329 the multi-run / single-run request handlers were non-exhaustive over `RunDealReq` / `RunPoolReq` / `RunAssetReq` / `RootFindReq`: a request decoded with the wrong constructor for the routed endpoint crashed with a pattern-match failure (now rendered as an opaque `engine error:` 500 by the #344 boundary). Every handler is now total. A misrouted request to a single-run endpoint (`runDeal`, `runPool`, `runAsset`) returns the reason in-band as `Left ": expected "`; map-valued multi-run endpoints (whose response type has no error slot) answer HTTP 400 with the same message, uniform with the #345 run-cap rejections. `wrapRunAsset` rejects non-`PoolLevel` assumption shapes (per-pool / per-index / obligor strategies and pricing without assumptions) in-band. * FIX: #329 `runByRootFinder` no longer crashes on the legacy `FirstLossReq` / `MaxSpreadToFaceReq` request shapes (kept on the wire but unsupported; absbox composes `RootFinderReq` for both `runFirstLoss` and `runRootFinder`); a stress tweak (`stressDefault` / `stressPrepayment`) without pool assumptions is rejected with a descriptive error instead of crashing; the `BalanceFormula` stop condition is rejected as not implemented yet. The executable now compiles with `-Wincomplete-patterns -Werror=incomplete-patterns`, so any future non-exhaustive match in the API layer fails the build (the library is unchanged); note locally cabal needs one clean rebuild to pick up the new flags. ## 0.52.9 diff --git a/src/Cashflow.hs b/src/Cashflow.hs index d2e18a17..4da8147b 100644 --- a/src/Cashflow.hs +++ b/src/Cashflow.hs @@ -41,6 +41,7 @@ import qualified Data.Map as Map import qualified Data.Time as T import qualified Data.List as L import Data.Maybe +import Data.List.NonEmpty (NonEmpty(..), nonEmpty) import Data.Aeson hiding (json) import Language.Haskell.TH @@ -450,14 +451,11 @@ buildBegBal [] = 0 buildBegBal (x:xs) = mflowBegBalance x -sumTs :: [TsRow] -> Date -> TsRow -sumTs trs d = set tsDate d (foldr1 addTs trs) - --- ^ group cashflow from same entity by a single date -sumTsCF :: [TsRow] -> Date -> TsRow --- sumTsCF [] = tsSetDate (foldl1 addTsCF trs) -- `debug` ("Summing"++show trs++">>"++ show (tsSetDate (foldr1 addTsCF trs) d)) -sumTsCF [] _ = error "sumTsCF failed with empty list" -sumTsCF trs d = set tsDate d (foldl1 addTsCF trs) -- `debug` ("Summing"++show trs++">>"++ show (tsSetDate (foldr1 addTsCF trs) d)) +-- | Group cashflow rows from the same entity by a single date. The input is +-- 'NonEmpty' by construction: a group with no rows has no result row to +-- produce, so callers decide what "no group" means (see 'aggTsByDates'). +sumTsCF :: NonEmpty TsRow -> Date -> TsRow +sumTsCF (r :| rs) d = set tsDate d (L.foldl addTsCF r rs) tsTotalCash :: TsRow -> Balance tsTotalCash (CashFlow _ x) = x @@ -574,9 +572,9 @@ aggregateTsByDate (r:rs) (tr:trs) firstDate :: CashFlowFrame -> Date -firstDate (CashFlowFrame _ []) = error "empty cashflow frame to get first date" -firstDate (CashFlowFrame _ [r]) = getDate r -firstDate (CashFlowFrame _ (r:rs)) = getDate r +firstDate (CashFlowFrame (_,bd,_) []) = bd +firstDate (CashFlowFrame _ (r:_)) = getDate r +firstDate DummyCF = epocDate -- ! combine two cashflow frames from two entities @@ -609,12 +607,10 @@ buildCollectedCF trs (d:ds) _trs = where (newFlow, remains) = splitBy d Inc _trs -buildCollectedCF a b c = error $ "buildCollectedCF failed"++ show a++">>"++ show b++">>"++ show c - aggTsByDates :: [TsRow] -> [Date] -> [TsRow] aggTsByDates [] ds = [] -aggTsByDates trs ds = uncurry sumTsCF <$> filter (\(cfs,_d) -> (not . null) cfs) (zip (buildCollectedCF [] ds trs) ds) -- `debug` (">>> to sumTsCF "++ show (zip (buildCollectedCF [] ds trs) ds )) +aggTsByDates trs ds = mapMaybe (\(cfs,d) -> (\ne -> sumTsCF ne d) <$> nonEmpty cfs) (zip (buildCollectedCF [] ds trs) ds) mflowPrincipal :: TsRow -> Balance mflowPrincipal (BondFlow _ _ p _) = p @@ -634,6 +630,7 @@ mflowInterest x = error $ "not supported: getting interest from row" ++ show x viewTsRow :: Date -> TsRow -> TsRow -- ^ take a snapshot of a record from record balance/stats and a new date +viewTsRow _d (CashFlow _ _) = CashFlow _d 0 viewTsRow _d (MortgageDelinqFlow a b c d e f g h i j k l m) = MortgageDelinqFlow _d b 0 0 0 0 0 0 0 j k l m viewTsRow _d (MortgageFlow a b c d e f g h i j k l) = MortgageFlow _d b 0 0 0 0 0 0 i j k l viewTsRow _d (LoanFlow a b c d e f g i j k) = LoanFlow _d b 0 0 0 0 0 0 j k @@ -760,6 +757,7 @@ mflowWeightAverageBalance sd ed trs emptyTsRow :: Date -> TsRow -> TsRow -- ^ reset all cashflow fields to zero and init with a date +emptyTsRow _d (CashFlow _ _) = CashFlow _d 0 emptyTsRow _d (MortgageDelinqFlow a x c d e f g h i j k l m) = MortgageDelinqFlow _d 0 0 0 0 0 0 0 0 0 Nothing Nothing Nothing emptyTsRow _d (MortgageFlow a x c d e f g h i j k l) = MortgageFlow _d 0 0 0 0 0 0 0 0 Nothing Nothing Nothing emptyTsRow _d (LoanFlow a x c d e f g i j k) = LoanFlow _d 0 0 0 0 0 0 0 0 Nothing diff --git a/test/MainTest.hs b/test/MainTest.hs index 1fba81a5..36fad80b 100644 --- a/test/MainTest.hs +++ b/test/MainTest.hs @@ -63,6 +63,7 @@ tests = testGroup "Tests" [AT.mortgageTests ,CFT.testPoolAggTest ,CFT.testMflowAccessors ,CFT.testCollectedCfSafety + ,CFT.testEmptyInputSafety ,BT.pricingTests ,BT.bndConsolTest ,BT.writeOffTest diff --git a/test/UT/CashflowTest.hs b/test/UT/CashflowTest.hs index 0abd0119..7b258585 100644 --- a/test/UT/CashflowTest.hs +++ b/test/UT/CashflowTest.hs @@ -1,6 +1,6 @@ module UT.CashflowTest(cfTests,tsSplitTests,testMergePoolCf,combineTest,testHaircut ,testMergeTsRowsFromTwoEntities,testCumStat,testClawIntTest,testPoolAggTest - ,testMflowAccessors,testCollectedCfSafety) + ,testMflowAccessors,testCollectedCfSafety,testEmptyInputSafety) where import Test.Tasty @@ -16,6 +16,7 @@ import qualified Cashflow as CF import Types import Util import DateUtil +import Data.List.NonEmpty (NonEmpty(..)) import Debug.Trace debug = flip trace @@ -488,3 +489,41 @@ testCollectedCfSafety = ,testCase "empty trs with dates returns empty rows instead of crashing" $ assertEqual "two empty rows" [[],[]] (CF.buildCollectedCF [] [L.toDate "20220101",L.toDate "20220201"] []) ] + +-- | #332: empty-input and CashFlow-row safety for the cashflow aggregation +testEmptyInputSafety = testGroup "Cashflow empty-input safety" + [ + testCase "firstDate of an empty frame returns its begin date" $ + assertEqual "begin date" (L.toDate "20200101") + (CF.firstDate (CF.CashFlowFrame (0, L.toDate "20200101", Nothing) [])) + + ,testCase "firstDate of emptyCashflow returns epocDate" $ + assertEqual "epocDate" epocDate (CF.firstDate CF.emptyCashflow) + + ,testCase "firstDate of DummyCF returns epocDate" $ + assertEqual "epocDate" epocDate (CF.firstDate CF.DummyCF) + + ,testCase "aggTsByDates over an empty pool returns []" $ + assertEqual "empty" ([] :: [CF.TsRow]) (CF.aggTsByDates [] [L.toDate "20220101"]) + + ,testCase "aggTsByDates drops groups with no rows (rows after the cutoffs)" $ + assertEqual "no groups" ([] :: [CF.TsRow]) + (CF.aggTsByDates [CF.MortgageFlow (L.toDate "20220211") 80 10 10 0 0 0 0 0 Nothing Nothing Nothing] + [L.toDate "20220101"]) + + ,testCase "sumTsCF sums a NonEmpty group" $ + assertEqual "summed" (CF.CashFlow (L.toDate "20220103") 15) + (CF.sumTsCF (CF.CashFlow (L.toDate "20220101") 10 :| [CF.CashFlow (L.toDate "20220102") 5]) + (L.toDate "20220103")) + + ,testCase "aggTsByDates handles CashFlow-shaped rows (zero-row synthesis)" $ + assertEqual "cashflow rows" + [CF.CashFlow (L.toDate "20220101") 100, CF.CashFlow (L.toDate "20220201") 0] + (CF.aggTsByDates [CF.CashFlow (L.toDate "20220101") 100] + [L.toDate "20220101", L.toDate "20220201"]) + + ,testCase "extendCashFlow appends a zeroed CashFlow row" $ + assertEqual "extended" + (CF.CashFlowFrame dummySt [CF.CashFlow (L.toDate "20220101") 100, CF.CashFlow (L.toDate "20220201") 0]) + (CF.extendCashFlow (L.toDate "20220201") (CF.CashFlowFrame dummySt [CF.CashFlow (L.toDate "20220101") 100])) + ] From ec21f100e2091206406fe8c3d21e0d2038cbabf9 Mon Sep 17 00:00:00 2001 From: yellowbean Date: Sat, 17 Oct 2026 23:18:31 +0800 Subject: [PATCH 30/40] Fix#323: PrepaymentABS SMM=0 at/after implied balance exhaustion (no zero denominator) --- CHANGELOG.md | 1 + src/Asset.hs | 7 ++++++- test/UT/AssetTest.hs | 20 ++++++++++++++++++++ 3 files changed, 27 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index cf801571..9fd925e2 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,7 @@ ## 0.52.10 ### 2026-10-17 * FIX: #332 `sumTsCF` now takes `NonEmpty TsRow` (source-level breaking for library consumers) instead of throwing on an empty group; the dead, unexported partial `sumTs` (`foldr1`) is removed; `firstDate` returns the frame's begin date for an empty frame (`epocDate` for `DummyCF`) instead of failing; `emptyTsRow` and `viewTsRow` gained the missing `CashFlow` clause so `extendCashFlow` / `buildCollectedCF` zero-row synthesis no longer crash on generic rows; `buildCollectedCF` lost its unreachable `error` clause. `aggTsByDates` keeps its signature and behavior (empty groups are skipped via `NE.nonEmpty`). +* FIX: #323 PrepaymentABS: SMM is now 0 at and after the implied balance-exhaustion month (`m >= 1 + 1/r`) instead of dividing by zero (Rational exception) or emitting negative SMM; 100% rate edge covered. The remaining over-reporting when SMM > 1 before exhaustion is tracked in #358. * FIX: #329 the multi-run / single-run request handlers were non-exhaustive over `RunDealReq` / `RunPoolReq` / `RunAssetReq` / `RootFindReq`: a request decoded with the wrong constructor for the routed endpoint crashed with a pattern-match failure (now rendered as an opaque `engine error:` 500 by the #344 boundary). Every handler is now total. A misrouted request to a single-run endpoint (`runDeal`, `runPool`, `runAsset`) returns the reason in-band as `Left ": expected "`; map-valued multi-run endpoints (whose response type has no error slot) answer HTTP 400 with the same message, uniform with the #345 run-cap rejections. `wrapRunAsset` rejects non-`PoolLevel` assumption shapes (per-pool / per-index / obligor strategies and pricing without assumptions) in-band. * FIX: #329 `runByRootFinder` no longer crashes on the legacy `FirstLossReq` / `MaxSpreadToFaceReq` request shapes (kept on the wire but unsupported; absbox composes `RootFinderReq` for both `runFirstLoss` and `runRootFinder`); a stress tweak (`stressDefault` / `stressPrepayment`) without pool assumptions is rejected with a descriptive error instead of crashing; the `BalanceFormula` stop condition is rejected as not implemented yet. The executable now compiles with `-Wincomplete-patterns -Werror=incomplete-patterns`, so any future non-exhaustive match in the API layer fails the build (the library is unchanged); note locally cabal needs one clean rebuild to pick up the new flags. ## 0.52.9 diff --git a/src/Asset.hs b/src/Asset.hs index 6ac914df..8c6598e0 100644 --- a/src/Asset.hs +++ b/src/Asset.hs @@ -194,7 +194,12 @@ buildPrepayRates a ds (Just (A.PrepaymentABS r)) = let originDate = getOriginDate a pojectedMonthAges = (monthsBetween originDate) <$> ds - smm m = r / (1 - r * fromIntegral (pred m)) + -- r is a monthly prepayment on the ORIGINAL balance, so the implied + -- outstanding fraction at month m is 1 - r*(m-1). Once it reaches zero + -- (m >= 1 + 1/r) there is no balance left to prepay: SMM = 0. + smm m = + let denom = 1 - r * fromIntegral (pred m) + in if denom <= 0 then 0 else r / denom smmVector = smm <$> pojectedMonthAges in case period (getOriginInfo a) of diff --git a/test/UT/AssetTest.hs b/test/UT/AssetTest.hs index cce105b5..d7998f03 100644 --- a/test/UT/AssetTest.hs +++ b/test/UT/AssetTest.hs @@ -630,6 +630,14 @@ ppyVectorTest = absDs = L.toDate <$> ["20210701","20210801","20210901","20211001"] absRatesFirst r = Ast.buildPrepayRates tm absDsFirst (Just (A.PrepaymentABS r)) absRates r = Ast.buildPrepayRates tm absDs (Just (A.PrepaymentABS r)) + -- month ages 49,50,51,52,53 relative to tm's 2021-01-01 origin; + -- a 2% ABS rate is exhausted at month 1 + 1/0.02 = 51. + exhaustionDs = L.toDate <$> ["20250201","20250301","20250401","20250501","20250601"] + -- month ages 17,18; a 6% ABS rate's implied balance is exhausted at 17.67, + -- so month 18 previously produced a negative SMM. + pastExhaustionDs = L.toDate <$> ["20220601","20220701"] + -- month ages 1,2; a 100% ABS rate exhausts the implied balance at month 2. + fullRateDs = L.toDate <$> ["20210201","20210301"] in testGroup "Prepayment vector tests" [ testCase "PrepaymentABS 2% => SMM by month age | fisth 4 months" $ @@ -648,6 +656,18 @@ ppyVectorTest = assertBool "rate > 1 should be Left" (isLeft (absRates 1.5)) ,testCase "PrepaymentABS rejects negative rate" $ assertBool "negative rate should be Left" (isLeft (absRates (-0.1))) + ,testCase "PrepaymentABS 2% => SMM is 0 at and after the exhaustion month" $ + assertEqual "exhaustion month and beyond" + (Right [1/2, 1, 0, 0, 0]) + (Ast.buildPrepayRates tm exhaustionDs (Just (A.PrepaymentABS 0.02))) + ,testCase "PrepaymentABS 6% => no negative SMM past exhaustion" $ + assertEqual "past exhaustion" + (Right [3/2, 0]) + (Ast.buildPrepayRates tm pastExhaustionDs (Just (A.PrepaymentABS 0.06))) + ,testCase "PrepaymentABS 100% => SMM is 1 in month 1 and 0 afterwards" $ + assertEqual "100% rate" + (Right [1, 0]) + (Ast.buildPrepayRates tm fullRateDs (Just (A.PrepaymentABS 1.0))) ] delinqScheduleCFTest = From d7b1565b274cfa4c54af1b234f9f8281be3621c3 Mon Sep 17 00:00:00 2001 From: yellowbean Date: Sat, 17 Oct 2026 23:27:51 +0800 Subject: [PATCH 31/40] CI: build multi-arch Docker images natively per platform + smoke test (fix arm64, PR #322 H2) --- .github/workflows/docker-image-dev-by-tag.yml | 144 +++++++++++++----- Dockerfile | 10 +- 2 files changed, 109 insertions(+), 45 deletions(-) diff --git a/.github/workflows/docker-image-dev-by-tag.yml b/.github/workflows/docker-image-dev-by-tag.yml index 97af02cf..f0d392f3 100644 --- a/.github/workflows/docker-image-dev-by-tag.yml +++ b/.github/workflows/docker-image-dev-by-tag.yml @@ -5,36 +5,45 @@ on: tags: - 'a*' -jobs: +# Multi-arch strategy: each platform is built natively on a runner of the same +# architecture (no QEMU, no cross-compilation), pushed by digest, and the +# per-platform digests are merged into one multi-arch manifest at the end. +# This fixes the previous setup where the build stage was pinned to +# $BUILDPLATFORM: on an amd64 runner that produced an amd64 binary for the +# arm64 image ("exec format error" at runtime). +# +# NOTE: linux/arm64 uses GitHub-hosted arm64 runners. If the repository does +# not have access to them, replace `ubuntu-24.04-arm` with `ubuntu-22.04-arm`, +# or fall back to the QEMU variant described in the PR #322 review (drop the +# platform pin in the Dockerfile, add the QEMU setup step back, and build both +# platforms in one job). - build: - - runs-on: ubuntu-latest +env: + IMAGE: ${{ secrets.DOCKER_HUB_USERNAME }}/hastructure +jobs: + build: + strategy: + fail-fast: false + matrix: + include: + - platform: linux/amd64 + arch: amd64 + runner: ubuntu-latest + - platform: linux/arm64 + arch: arm64 + runner: ubuntu-24.04-arm + runs-on: ${{ matrix.runner }} steps: - - - name: Set up QEMU - uses: docker/setup-qemu-action@v2 - - - name: Set up Docker Buildx + - name: Set up Docker Buildx uses: docker/setup-buildx-action@v3 - - - name: Login to Docker Hub - uses: docker/login-action@v2 + + - name: Login to Docker Hub + uses: docker/login-action@v3 with: username: ${{ secrets.DOCKER_HUB_USERNAME }} password: ${{ secrets.DOCKER_HUB_PW }} - - name: Extract metadata (tags, labels) for Docker - id: meta - uses: docker/metadata-action@v5 - with: - images: yellowbean/hastructure - tags: | - type=match,pattern=(a\d+.\d+.\d+),group=1 - flavor: | - latest=false - - name: 'Cleanup build folder' run: | ls -la ./ @@ -43,18 +52,81 @@ jobs: ls -la . rm -rf /opt/ghc rm -rf /opt/hostedtoolcache - - - - name: Build and push - uses: docker/build-push-action@v3 + + - name: Build and push by digest + id: build + uses: docker/build-push-action@v6 + with: + platforms: ${{ matrix.platform }} + outputs: type=image,name=${{ env.IMAGE }},push-by-digest=true,name-canonical=true,push=true + cache-from: type=registry,ref=${{ env.IMAGE }}:buildcache-${{ matrix.arch }} + cache-to: type=registry,ref=${{ env.IMAGE }}:buildcache-${{ matrix.arch }},mode=max + + - name: Smoke test (the image must start and answer /version) + run: | + docker run -d --name smoke-${{ matrix.arch }} \ + --platform ${{ matrix.platform }} \ + -p 18081:8081 \ + ${{ env.IMAGE }}@${{ steps.build.outputs.digest }} + ok=0 + for i in $(seq 1 15); do + if curl -fsS http://localhost:18081/version; then ok=1; break; fi + sleep 1 + done + docker rm -f smoke-${{ matrix.arch }} + test "$ok" = "1" + + - name: Export digest + run: | + mkdir -p /tmp/digests + digest="${{ steps.build.outputs.digest }}" + touch "/tmp/digests/${digest#sha256:}" + + - name: Upload digest + uses: actions/upload-artifact@v4 with: - platforms: linux/amd64,linux/arm64 - push: true - build-args: | - CFLAGS=-march=armv8-a - CPPFLAGS=-march=armv8-a - tags: ${{ secrets.DOCKER_HUB_USERNAME }}/hastructure:dev, ${{ steps.meta.outputs.tags }} - cache-from: type=registry,ref=${{ secrets.DOCKER_HUB_USERNAME }}/hastructure:buildcache - cache-to: type=registry,ref=${{ secrets.DOCKER_HUB_USERNAME }}/hastructure:buildcache,mode=max - - + name: digests-${{ matrix.arch }} + path: /tmp/digests/* + if-no-files-found: error + retention-days: 1 + + merge: + runs-on: ubuntu-latest + needs: build + steps: + - name: Download digests + uses: actions/download-artifact@v4 + with: + path: /tmp/digests + pattern: digests-* + merge-multiple: true + + - name: Set up Docker Buildx + uses: docker/setup-buildx-action@v3 + + - name: Login to Docker Hub + uses: docker/login-action@v3 + with: + username: ${{ secrets.DOCKER_HUB_USERNAME }} + password: ${{ secrets.DOCKER_HUB_PW }} + + - name: Extract metadata (tags, labels) for Docker + id: meta + uses: docker/metadata-action@v5 + with: + images: ${{ env.IMAGE }} + tags: | + type=match,pattern=(a\d+\.\d+\.\d+),group=1 + type=raw,value=dev + flavor: | + latest=false + + - name: Create multi-arch manifest + working-directory: /tmp/digests + run: | + docker buildx imagetools create \ + $(jq -r '.tags | join(" ")' <<< "$DOCKER_METADATA_OUTPUT_TAGS") \ + $(printf '${{ env.IMAGE }}@sha256:%s ' *) + + - name: Inspect manifest + run: docker buildx imagetools inspect ${{ env.IMAGE }}:dev diff --git a/Dockerfile b/Dockerfile index c4fdeabe..a1d55b4a 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,12 +1,4 @@ -FROM --platform=$BUILDPLATFORM haskell:9.8.4-slim-bullseye AS build - -ARG TARGETPLATFORM -RUN case "$TARGETPLATFORM" in \ - linux/arm64) \ - export CFLAGS="-march=armv8-a" \ - export CPPFLAGS="-march=armv8-a" ;; \ - *) ;; \ - esac +FROM haskell:9.8.4-slim-bullseye AS build WORKDIR /opt/build COPY . /opt/build From c929825265b827084ac13910ea10fa2b7af3a4d8 Mon Sep 17 00:00:00 2001 From: yellowbean Date: Sat, 17 Oct 2026 23:48:23 +0800 Subject: [PATCH 32/40] Fix#344: force handler responses before warp starts the response (value-level escapes now enveloped) --- CHANGELOG.md | 3 ++- app/Main.hs | 24 ++++++++++++------------ src/Util.hs | 14 ++++++++++++-- test/MainTest.hs | 1 + test/UT/UtilTest.hs | 20 +++++++++++++++++++- 5 files changed, 46 insertions(+), 16 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 9fd925e2..b9ce96e6 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,11 +5,12 @@ ### 2026-10-17 * FIX: #332 `sumTsCF` now takes `NonEmpty TsRow` (source-level breaking for library consumers) instead of throwing on an empty group; the dead, unexported partial `sumTs` (`foldr1`) is removed; `firstDate` returns the frame's begin date for an empty frame (`epocDate` for `DummyCF`) instead of failing; `emptyTsRow` and `viewTsRow` gained the missing `CashFlow` clause so `extendCashFlow` / `buildCollectedCF` zero-row synthesis no longer crash on generic rows; `buildCollectedCF` lost its unreachable `error` clause. `aggTsByDates` keeps its signature and behavior (empty groups are skipped via `NE.nonEmpty`). * FIX: #323 PrepaymentABS: SMM is now 0 at and after the implied balance-exhaustion month (`m >= 1 + 1/r`) instead of dividing by zero (Rational exception) or emitting negative SMM; 100% rate edge covered. The remaining over-reporting when SMM > 1 before exhaustion is tracked in #358. +* FIX: #344 handler responses are now forced inside the handler action — single-run `Either` results to WHNF and every value of the multi-run response maps via `Util.forceMapValues` — so engine exceptions surface before Warp starts the response and are rendered by the JSON error boundary. Previously the response body was only forced while Warp was already streaming it, so `error`/partial-function failures inside computed responses aborted the connection (empty reply) instead of returning the JSON envelope. Deep laziness inside response payloads may still surface during streaming (see `forceMapValues`). * FIX: #329 the multi-run / single-run request handlers were non-exhaustive over `RunDealReq` / `RunPoolReq` / `RunAssetReq` / `RootFindReq`: a request decoded with the wrong constructor for the routed endpoint crashed with a pattern-match failure (now rendered as an opaque `engine error:` 500 by the #344 boundary). Every handler is now total. A misrouted request to a single-run endpoint (`runDeal`, `runPool`, `runAsset`) returns the reason in-band as `Left ": expected "`; map-valued multi-run endpoints (whose response type has no error slot) answer HTTP 400 with the same message, uniform with the #345 run-cap rejections. `wrapRunAsset` rejects non-`PoolLevel` assumption shapes (per-pool / per-index / obligor strategies and pricing without assumptions) in-band. * FIX: #329 `runByRootFinder` no longer crashes on the legacy `FirstLossReq` / `MaxSpreadToFaceReq` request shapes (kept on the wire but unsupported; absbox composes `RootFinderReq` for both `runFirstLoss` and `runRootFinder`); a stress tweak (`stressDefault` / `stressPrepayment`) without pool assumptions is rejected with a descriptive error instead of crashing; the `BalanceFormula` stop condition is rejected as not implemented yet. The executable now compiles with `-Wincomplete-patterns -Werror=incomplete-patterns`, so any future non-exhaustive match in the API layer fails the build (the library is unchanged); note locally cabal needs one clean rebuild to pick up the new flags. ## 0.52.9 ### 2026-10-17 -* FIX: #344 add a JSON error boundary at the Warp level: exceptions escaping the request pipeline (pure `error` calls, partial accessors, pattern failures) now answer 500 with the same envelope as in-band failures (`{"Left":"engine error: …"}`) and the CORS header, instead of Warp's opaque plain-text 500; server-side exception logging is unchanged +* FIX: #344 add a JSON error boundary at the Warp level: exceptions raised while a handler computes its response (pure `error` calls, partial accessors, pattern failures) now answer 500 with the same envelope as in-band failures (`{"Left":"engine error: …"}`) and the CORS header, instead of Warp's opaque plain-text 500; server-side exception logging is unchanged * FIX: #345 the `maxScenario` / `maxDealNum` limits declared in `config.yml` were dead configuration: the engine never read them and scenario/deal grids were unbounded (DoS via large `runByCombo` cartesian products). Each multi-run endpoint (`runPoolByScenarios`, `runDealByScenarios`, `runMultiDeals`, `runDealByRunScenarios`, `runByCombo`) now enforces a per-request total-run cap, default 1000, configurable per endpoint via the new `maxRunNum.` keys in `config.yml`; `runByCombo` sizes the cartesian product before materialising it, so oversized grids are rejected without allocation. Oversized requests are rejected with HTTP 400 naming the endpoint, the configured limit and the key to raise. The in-flight worker cap is now configurable via `workerNum` in `config.yml` (precedence: `HASTRUCTURE_WORKERS` env > `workerNum` > RTS `-N`); the internal `unsafePerformIO` global is gone. * FIX: BEHAVIOR CHANGE: a malformed `config.yml`, a missing `port` or a non-positive `maxRunNum.*` value now aborts startup with a descriptive error instead of silently falling back to defaults; the startup log prints the effective port, worker count and per-endpoint limits. The unused `maxScenario`/`maxDealNum` keys are removed from `config.yml`. ## 0.52.8 diff --git a/app/Main.hs b/app/Main.hs index 1d92db45..267badc5 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -61,7 +61,7 @@ import Servant.API.ContentTypes (contentType) import Types import MainBase -import Util (boundedParMap) +import Util (boundedParMap,forceMapValues) import ServerConfig import qualified Deal as D import qualified Deal.DealBase as DB @@ -214,14 +214,14 @@ engineSwagger = toOpenApi engineAPI -- showVersion :: Handler (Envelope '[] Version) showVersion :: Handler Version -showVersion = return version1 +showVersion = return $! version1 runAsset :: RunAssetReq -> Handler RunAssetResp -runAsset req = return $ wrapRunAsset req +runAsset req = return $! wrapRunAsset req runPool :: RunPoolReq -> Handler PoolRunResp runPool (SingleRunPoolReq f pt passumption mRates) - = return $ + = return $! patchCumulativeToPoolRun <$> wrapRunPoolType f pt passumption mRates runPool (MultiScenarioRunPoolReq _ _ _ _) = return $ Left "runPool: expected SingleRunPoolReq" @@ -258,14 +258,14 @@ runPoolScenarios :: MultiRunCap -> RunPoolReq -> Handler (Map.Map ScenarioName P runPoolScenarios cap (MultiScenarioRunPoolReq f pt mAssumps mRates) = do enforceRunCap "runPoolByScenarios" cap (Map.size mAssumps) - return $ boundedParMap (mcWorkers cap) + return $! forceMapValues $ boundedParMap (mcWorkers cap) (\assump -> patchCumulativeToPoolRun <$> wrapRunPoolType f pt (Just assump) mRates) mAssumps runPoolScenarios _ _ = badRequest "runPoolByScenarios: expected MultiScenarioRunPoolReq" runDeal :: RunDealReq -> Handler RunResp -runDeal (SingleRunReq f dt assump nonPerfAssump) = return $ wrapRun f dt assump nonPerfAssump +runDeal (SingleRunReq f dt assump nonPerfAssump) = return $! wrapRun f dt assump nonPerfAssump runDeal _ = return $ Left "runDeal: expected SingleRunReq" @@ -450,7 +450,7 @@ runRootFinderBy req@(RootFinderReq runInput@(_,mAssumps,_,_) tweak stop) | BalanceFormula{} <- stop = return $ Left "rootFinder: BalanceFormula stop is not implemented yet" | otherwise - = return $ runRidders runInput tweak stop + = return $! runRidders runInput tweak stop -- | Bond-only tweaks modify the deal structure and need no pool assumptions; -- the stress tweaks vary pool performance, so they do. @@ -481,7 +481,7 @@ runDealScenarios :: MultiRunCap -> RunDealReq -> Handler (Map.Map ScenarioName R runDealScenarios cap (MultiScenarioRunReq f dt mAssumps nonPerfAssump) = do enforceRunCap "runDealByScenarios" cap (Map.size mAssumps) - return $ boundedParMap (mcWorkers cap) (\singleAssump -> wrapRun f dt (Just singleAssump) nonPerfAssump) mAssumps + return $! forceMapValues $ boundedParMap (mcWorkers cap) (\singleAssump -> wrapRun f dt (Just singleAssump) nonPerfAssump) mAssumps runDealScenarios _ _ = badRequest "runDealByScenarios: expected MultiScenarioRunReq" @@ -489,13 +489,13 @@ runMultiDeals :: MultiRunCap -> RunDealReq -> Handler (Map.Map ScenarioName RunR runMultiDeals cap (MultiDealRunReq f mDts assump nonPerfAssump) = do enforceRunCap "runMultiDeals" cap (Map.size mDts) - return $ boundedParMap (mcWorkers cap) (\singleDealType -> wrapRun f singleDealType assump nonPerfAssump) mDts + return $! forceMapValues $ boundedParMap (mcWorkers cap) (\singleDealType -> wrapRun f singleDealType assump nonPerfAssump) mDts runMultiDeals _ _ = badRequest "runMultiDeals: expected MultiDealRunReq" runDate :: RunDateReq -> Handler [Date] runDate (RunDateReq sd dp md) - = return $ + = return $! case md of Nothing -> DU.genSerialDatesTill2 IE sd dp (Lib.toDate "20990101") Just d -> DU.genSerialDatesTill2 IE sd dp d @@ -504,7 +504,7 @@ runDealByRunScenarios :: MultiRunCap -> RunDealReq -> Handler (Map.Map ScenarioN runDealByRunScenarios cap (MultiRunAssumpReq f dt mAssump nonPerfAssumpMap) = do enforceRunCap "runDealByRunScenarios" cap (Map.size nonPerfAssumpMap) - return $ boundedParMap (mcWorkers cap) (wrapRun f dt mAssump) nonPerfAssumpMap + return $! forceMapValues $ boundedParMap (mcWorkers cap) (wrapRun f dt mAssump) nonPerfAssumpMap runDealByRunScenarios _ _ = badRequest "runDealByRunScenarios: expected MultiRunAssumpReq" @@ -520,7 +520,7 @@ runDealByCombo cap (MultiComboReq f dMap assumpMap nonPerfAssumpMap) | (dk,d) <- Map.toList dMap , (ak,a) <- Map.toList assumpMap , (nk,n) <- Map.toList nonPerfAssumpMap ] - return $ boundedParMap (mcWorkers cap) (\(d,a,n) -> wrapRun f d a n) inputs + return $! forceMapValues $ boundedParMap (mcWorkers cap) (\(d,a,n) -> wrapRun f d a n) inputs runDealByCombo _ _ = badRequest "runByCombo: expected MultiComboReq" diff --git a/src/Util.hs b/src/Util.hs index 72e8c832..f9182f15 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -13,7 +13,7 @@ module Util ,lastOf,findBox,safeDivide', safeDiv ,safeDivide,lstToMapByFn,paySequentially,payProRata,mapWithinMap ,payInMap,payInMapM,adjustM,adjustMs,mapInMapM,lookupAndApply,lookupAndUpdate,lookupAndApplies - ,lookupInMap,selectInMap,scaleByFstElement,boundedParMap + ,lookupInMap,selectInMap,scaleByFstElement,boundedParMap,forceMapValues ,lookupTuple6 ,lookupTuple7,diffNum,splitBal,lookupM,lookupVs ,lookupMM -- for debug @@ -270,13 +270,23 @@ debugLine xs = "" -- still limited by the RTS capabilities (@-N@). Values are forced only to WHNF, -- which is enough for computations expressed in a strict monad such as 'Either' -- (e.g. 'runDeal'), where reducing the result to a constructor runs the work; --- deeply-lazy results would need an 'NFData'-based variant instead. +-- deeply-lazy results would need an 'NFData'-based variant instead. Note the +-- values stay lazy until demanded — the HTTP handlers apply 'forceMapValues' so +-- engine failures surface while the error boundary can still respond (#344). boundedParMap :: Ord k => Int -> (a -> b) -> Map.Map k a -> Map.Map k b boundedParMap n f m = let (ks, vs) = unzip (Map.toList m) vs' = (map f vs) `using` parBuffer (max 1 n) rseq in Map.fromList (zip ks vs') +-- | Force every Map value to WHNF, then return the map. 'Map.fromList' keeps +-- the values lazy, so without this the response body would only be forced +-- while Warp is already streaming it — too late for the JSON error boundary to +-- render an engine failure (#344). A 'BondGroup'-style deep thunk inside a +-- value is not forced by this; use an 'NFData'-based variant if ever needed. +forceMapValues :: Map.Map k a -> Map.Map k a +forceMapValues m = Map.foldrWithKey (\_ v acc -> v `seq` acc) () m `seq` m + lastOf:: [a] -> (a->Bool) -> Maybe a lastOf [] fn = Nothing lastOf xs fn = diff --git a/test/MainTest.hs b/test/MainTest.hs index 36fad80b..a5870c29 100644 --- a/test/MainTest.hs +++ b/test/MainTest.hs @@ -113,6 +113,7 @@ tests = testGroup "Tests" [AT.mortgageTests ,UtilT.mapUpdateTest ,UtilT.boundedParMapTest ,UtilT.resolveWorkerCapTest + ,UtilT.forceMapValuesTest ,UtilT.workerNumTest ,UtilT.serverConfigLimitTest ,AccT.intTests diff --git a/test/UT/UtilTest.hs b/test/UT/UtilTest.hs index c0c197f6..65568fab 100644 --- a/test/UT/UtilTest.hs +++ b/test/UT/UtilTest.hs @@ -3,7 +3,7 @@ module UT.UtilTest(daycountTests1,daycountTests2,daycountTests3,daycountTests4 ,tsTest,ts2Test,ts3Test,dateVectorPatternTest,paddingTest,dateSliceTest ,capTest,roundingTest,sliceTest,splitTsTest,tableTest,lastOftest,paySeqTest - ,scaleListTest,mapUpdateTest,boundedParMapTest,resolveWorkerCapTest + ,scaleListTest,mapUpdateTest,boundedParMapTest,resolveWorkerCapTest,forceMapValuesTest ,workerNumTest,serverConfigLimitTest)--,daycountTests3,daycountTests4) where @@ -22,6 +22,7 @@ import Stmt import Data.Fixed import qualified Data.DList as DL import Data.Ratio ((%)) +import Control.Exception (ErrorCall(..), evaluate, try) import qualified Data.Map as Map import Data.Either import Data.List (isInfixOf) @@ -735,6 +736,23 @@ resolveWorkerCapTest = assertEqual "garbage" 4 (resolveWorkerCap 4 (Just "garbage")) ] +forceMapValuesTest :: TestTree +forceMapValuesTest = + let m = Map.fromList [(1::Int,10::Int),(2,20),(3,30)] + in + testGroup "forceMapValues" + [ testCase "preserves the map" $ + assertEqual "same map" m (forceMapValues m) + , testCase "empty map stays empty" $ + assertEqual "empty" (Map.empty :: Map.Map Int Int) (forceMapValues Map.empty) + , testCase "forces every value so exceptions surface eagerly" $ do + r <- (try (evaluate (forceMapValues (Map.fromList [(1::Int, error "boom" :: Int)]))) + :: IO (Either ErrorCall (Map.Map Int Int))) + case r of + Left (ErrorCall msg) -> assertEqual "message" "boom" msg + Right _ -> assertFailure "expected the forced value to throw" + ] + workerNumTest :: TestTree workerNumTest = testGroup "resolveWorkerNum" From 9be2aeef72a51975ca1b7b0157e6cce026062ae9 Mon Sep 17 00:00:00 2001 From: yellowbean Date: Sun, 18 Oct 2026 00:06:22 +0800 Subject: [PATCH 33/40] Fix#329: use the JSON envelope for HTTP 400 request rejections (PR #322 M1) --- CHANGELOG.md | 1 + Hastructure.cabal | 2 ++ app/Main.hs | 6 +++--- src/ServerConfig.hs | 14 +++++++++++++- test/MainTest.hs | 1 + test/UT/UtilTest.hs | 25 +++++++++++++++++++++++-- 6 files changed, 43 insertions(+), 6 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index b9ce96e6..80977a0d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,6 +5,7 @@ ### 2026-10-17 * FIX: #332 `sumTsCF` now takes `NonEmpty TsRow` (source-level breaking for library consumers) instead of throwing on an empty group; the dead, unexported partial `sumTs` (`foldr1`) is removed; `firstDate` returns the frame's begin date for an empty frame (`epocDate` for `DummyCF`) instead of failing; `emptyTsRow` and `viewTsRow` gained the missing `CashFlow` clause so `extendCashFlow` / `buildCollectedCF` zero-row synthesis no longer crash on generic rows; `buildCollectedCF` lost its unreachable `error` clause. `aggTsByDates` keeps its signature and behavior (empty groups are skipped via `NE.nonEmpty`). * FIX: #323 PrepaymentABS: SMM is now 0 at and after the implied balance-exhaustion month (`m >= 1 + 1/r`) instead of dividing by zero (Rational exception) or emitting negative SMM; 100% rate edge covered. The remaining over-reporting when SMM > 1 before exhaustion is tracked in #358. +* FIX: #329 / #345 request rejections (misrouted request shapes and oversized multi-run grids) now answer 400 with the standard JSON error envelope (`{"Left":"…"}` and `application/json`) instead of a plain-text body with no content type, matching the in-band errors and the #344 boundary (PR #322 review M1). * FIX: #344 handler responses are now forced inside the handler action — single-run `Either` results to WHNF and every value of the multi-run response maps via `Util.forceMapValues` — so engine exceptions surface before Warp starts the response and are rendered by the JSON error boundary. Previously the response body was only forced while Warp was already streaming it, so `error`/partial-function failures inside computed responses aborted the connection (empty reply) instead of returning the JSON envelope. Deep laziness inside response payloads may still surface during streaming (see `forceMapValues`). * FIX: #329 the multi-run / single-run request handlers were non-exhaustive over `RunDealReq` / `RunPoolReq` / `RunAssetReq` / `RootFindReq`: a request decoded with the wrong constructor for the routed endpoint crashed with a pattern-match failure (now rendered as an opaque `engine error:` 500 by the #344 boundary). Every handler is now total. A misrouted request to a single-run endpoint (`runDeal`, `runPool`, `runAsset`) returns the reason in-band as `Left ": expected "`; map-valued multi-run endpoints (whose response type has no error slot) answer HTTP 400 with the same message, uniform with the #345 run-cap rejections. `wrapRunAsset` rejects non-`PoolLevel` assumption shapes (per-pool / per-index / obligor strategies and pricing without assumptions) in-band. * FIX: #329 `runByRootFinder` no longer crashes on the legacy `FirstLossReq` / `MaxSpreadToFaceReq` request shapes (kept on the wire but unsupported; absbox composes `RootFinderReq` for both `runFirstLoss` and `runRootFinder`); a stress tweak (`stressDefault` / `stressPrepayment`) without pool assumptions is rejected with a descriptive error instead of crashing; the `BalanceFormula` stop condition is rejected as not implemented yet. The executable now compiles with `-Wincomplete-patterns -Werror=incomplete-patterns`, so any future non-exhaustive match in the API layer fails the build (the library is unchanged); note locally cabal needs one clean rebuild to pick up the new flags. diff --git a/Hastructure.cabal b/Hastructure.cabal index 3bf49d81..d6dbd5cb 100644 --- a/Hastructure.cabal +++ b/Hastructure.cabal @@ -108,6 +108,7 @@ library servant >= 0.20.2 && < 0.21, servant-openapi3 >= 2.0.1 && < 2.1, servant-server >= 0.20.2 && < 0.21, + http-types >= 0.12 && < 0.13, wai >= 3.2.4 && < 3.3, warp >= 3.4.7 && < 3.5, split >= 0.2.5 && < 0.3, @@ -241,6 +242,7 @@ test-suite Hastructure-test tabular, wai-cors, yaml, + http-types, tasty, tasty-golden, tasty-hspec, diff --git a/app/Main.hs b/app/Main.hs index 267badc5..ad352ab1 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -38,7 +38,6 @@ import Data.Maybe import Data.Yaml as Y import Data.OpenApi hiding (Server,contentType) import qualified Data.Map as Map -import Data.String.Conversions import Data.Time.Calendar import GHC.Generics import GHC.Real @@ -244,15 +243,16 @@ mkRunCap rc getLim = MultiRunCap (rcWorkers rc) (getLim (rcLimits rc)) enforceRunCap :: String -> MultiRunCap -> Int -> Handler () enforceRunCap ep cap n = case checkRunNumLimit ep (mcMaxRuns cap) n of - Left msg -> throwError (err400 { errBody = cs msg }) + Left msg -> throwError (badRequestJSON msg) Right () -> return () -- | Reject a request routed to an endpoint whose payload shape it does not -- match (#329). Map-valued multi-run responses have no error slot, so the -- rejection rides the HTTP status code instead; single-run endpoints return -- the message as 'Left' in-band, matching the existing run-error convention. +-- The body uses the standard JSON error envelope (#'badRequestJSON'). badRequest :: String -> Handler a -badRequest msg = throwError (err400 { errBody = cs msg }) +badRequest msg = throwError (badRequestJSON msg) runPoolScenarios :: MultiRunCap -> RunPoolReq -> Handler (Map.Map ScenarioName PoolRunResp) runPoolScenarios cap (MultiScenarioRunPoolReq f pt mAssumps mRates) diff --git a/src/ServerConfig.hs b/src/ServerConfig.hs index c8bd2107..5ebed059 100644 --- a/src/ServerConfig.hs +++ b/src/ServerConfig.hs @@ -20,13 +20,25 @@ module ServerConfig , checkRunNumLimit , resolveWorkerNum , resolveWorkerCap + , badRequestJSON ) where -import Data.Aeson (FromJSON(..), withObject, (.:?)) +import Data.Aeson (FromJSON(..), withObject, (.:?), encode, Value) import GHC.Generics (Generic) +import Network.HTTP.Types (hContentType) +import Servant.Server (ServerError(..), err400) import Text.Read (readMaybe) +-- | A 400 rejection rendered in the standard JSON error envelope used by the +-- in-band 'Either' errors and the #344 exception boundary: @{"Left":"…"}@ with +-- an @application\/json@ content type (#322 review M1). +badRequestJSON :: String -> ServerError +badRequestJSON msg = err400 + { errHeaders = [(hContentType, "application/json")] + , errBody = encode (Left msg :: Either String Value) + } + -- | Default total-run cap per multi-run request. defaultRunNum :: Int defaultRunNum = 1000 diff --git a/test/MainTest.hs b/test/MainTest.hs index a5870c29..ac176f42 100644 --- a/test/MainTest.hs +++ b/test/MainTest.hs @@ -116,6 +116,7 @@ tests = testGroup "Tests" [AT.mortgageTests ,UtilT.forceMapValuesTest ,UtilT.workerNumTest ,UtilT.serverConfigLimitTest + ,UtilT.badRequestJSONTest ,AccT.intTests ,AccT.investTests ,AccT.reserveAccTest diff --git a/test/UT/UtilTest.hs b/test/UT/UtilTest.hs index 65568fab..ebedd60d 100644 --- a/test/UT/UtilTest.hs +++ b/test/UT/UtilTest.hs @@ -4,7 +4,7 @@ module UT.UtilTest(daycountTests1,daycountTests2,daycountTests3,daycountTests4 ,tsTest,ts2Test,ts3Test,dateVectorPatternTest,paddingTest,dateSliceTest ,capTest,roundingTest,sliceTest,splitTsTest,tableTest,lastOftest,paySeqTest ,scaleListTest,mapUpdateTest,boundedParMapTest,resolveWorkerCapTest,forceMapValuesTest - ,workerNumTest,serverConfigLimitTest)--,daycountTests3,daycountTests4) + ,workerNumTest,serverConfigLimitTest,badRequestJSONTest)--,daycountTests3,daycountTests4) where import Test.Tasty @@ -23,6 +23,10 @@ import Data.Fixed import qualified Data.DList as DL import Data.Ratio ((%)) import Control.Exception (ErrorCall(..), evaluate, try) +import Network.HTTP.Types (hContentType) +import Servant.Server (ServerError(..)) +import qualified Data.ByteString.Lazy.Char8 as BL8 +import qualified Data.ByteString.Char8 as BS8 import qualified Data.Map as Map import Data.Either import Data.List (isInfixOf) @@ -802,4 +806,21 @@ serverConfigLimitTest = case resolveRunLimits (RunLimitsRaw Nothing Nothing Nothing (Just 0) Nothing) of Left msg -> assertBool "names the offending key" ("maxRunNum.runDealByRunScenarios" `isInfixOf` msg) Right _ -> assertFailure "expected Left" - ] \ No newline at end of file + ] + + +-- | #322 review M1: HTTP 400 request rejections must use the standard JSON +-- error envelope, not a plain-text body without a content type. +badRequestJSONTest :: TestTree +badRequestJSONTest = + let e = badRequestJSON "boom" + in + testGroup "badRequestJSON (HTTP 400 envelope)" + [ testCase "status is 400" $ + assertEqual "400" 400 (errHTTPCode e) + , testCase "content type is application/json" $ + assertEqual "json" (Just "application/json") + (fmap BS8.unpack (lookup hContentType (errHeaders e))) + , testCase "body is the standard Left envelope" $ + assertEqual "envelope" "{\"Left\":\"boom\"}" (BL8.unpack (errBody e)) + ] From e24c500a3fe273d4696f4a9efa14cfddd23d1dd3 Mon Sep 17 00:00:00 2001 From: yellowbean Date: Sun, 18 Oct 2026 00:31:53 +0800 Subject: [PATCH 34/40] L2/L3: track UT.LedgerTest in cabal; prorataFactors clamps negative balances; changelog for periodsBetween removal (PR #322) --- CHANGELOG.md | 1 + Hastructure.cabal | 1 + src/Lib.hs | 4 +++- test/UT/LibTest.hs | 10 ++++++++++ 4 files changed, 15 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 80977a0d..49a71970 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -36,6 +36,7 @@ ### 2026-09-27 * NEW: add new prepayment assumption `PrepaymentABS`, an ABS / absolute prepayment model driven by the asset's seasoning (months elapsed since origin). Supported for `Monthly` assets only. * FIX: pool-level `DefaultByAmt` is now allocated across multiple assets proportionally to their current balance. +* BREAKING (library API): `Lib.periodsBetween` is removed in favor of `Lib.monthsBetween :: Date -> Date -> Integer` (whole calendar months between two dates; partial months clipped, so 2021-01-31 -> 2021-02-01 is 0 months; negative when the second date is earlier). ## 0.52.5 ### 2026-08-23 diff --git a/Hastructure.cabal b/Hastructure.cabal index d6dbd5cb..6936967c 100644 --- a/Hastructure.cabal +++ b/Hastructure.cabal @@ -197,6 +197,7 @@ test-suite Hastructure-test UT.ExpTest UT.InterestRateTest UT.LibTest + UT.LedgerTest UT.PoolTest UT.QueryTest UT.RateHedgeTest diff --git a/src/Lib.hs b/src/Lib.hs index 49dc2bf9..86e2ed2e 100644 --- a/src/Lib.hs +++ b/src/Lib.hs @@ -64,12 +64,14 @@ centiToDecimal c = Decimal 2 (round c * 100) -- method: every allocation is non-negative and allocations sum exactly to -- min (sum of balances) amt (to the cent). Residual cents go to the elements -- with the largest fractional remainders, ties broken by index order. +-- Negative balances carry no weight (treated as zero) instead of producing +-- negative allocations (#322 review L3). prorataFactors :: [Balance] -> Balance -> [Balance] prorataFactors bals amt | totalCents <= 0 = replicate (length bals) 0 | otherwise = map (toEnum . fromInteger) $ zipWith (+) baseAdds extraCents where - centList = toInteger . fromEnum <$> bals + centList = max 0 . toInteger . fromEnum <$> bals totalCents = sum centList payCents = max 0 $ min totalCents (toInteger $ fromEnum amt) baseAdds = [ b * payCents `div` totalCents | b <- centList ] diff --git a/test/UT/LibTest.hs b/test/UT/LibTest.hs index 058717fe..d85d5116 100644 --- a/test/UT/LibTest.hs +++ b/test/UT/LibTest.hs @@ -190,6 +190,16 @@ prorataTests = testGroup "prorata Test" assertEqual "" [0,0] (prorataFactors [0,0] 40) + , + testCase "negative balance carries no weight" $ + assertEqual "" + [50,0,50] + (prorataFactors [100, -50, 100] 100) + , + testCase "all-negative balances give zeros" $ + assertEqual "" + [0,0] + (prorataFactors [-10, -20] 30) ] tsOperationTests = From 9eebc6e8e53a74ca55ca0463bc6b2c9d56034d60 Mon Sep 17 00:00:00 2001 From: yellowbean Date: Sun, 18 Oct 2026 00:40:41 +0800 Subject: [PATCH 35/40] bump version to-> < 0.52.11 > --- Hastructure.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Hastructure.cabal b/Hastructure.cabal index 6936967c..274b0ba3 100644 --- a/Hastructure.cabal +++ b/Hastructure.cabal @@ -5,7 +5,7 @@ cabal-version: 3.0 -- see: https://github.com/sol/hpack name: Hastructure -version: 0.52.10 +version: 0.52.11 synopsis: Cashflow modeling library for structured finance description: Please see the README on GitHub at category: StructuredFinance,Securitisation,Cashflow From ad4a7f12a76101d57ff7d6142c7d05174615302e Mon Sep 17 00:00:00 2001 From: yellowbean Date: Sun, 18 Oct 2026 01:18:03 +0800 Subject: [PATCH 36/40] docs: make Features section collapsible --- README.md | 165 ++++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 118 insertions(+), 47 deletions(-) diff --git a/README.md b/README.md index 47188648..0222e26a 100644 --- a/README.md +++ b/README.md @@ -35,53 +35,124 @@ * [Where is `Hastructure` doc ? ](https://github.com/absbox/Hastructure/wiki/Where-is-documentation-of-Hastructure-%3F) ### Features -* Integration - * Built-in REST API services - * Language independent, integration friendly. - * Swagger -> [here](https://github.com/absbox/Hastructure/blob/master/swagger.json) - * Public server status -> [here](https://absbox.org) - * Docker Support -* Asset class coverage (Mortgage/Student Loan/Auto Loan/Rentals/Corp Loan/Consumer Installment) -* Pool Assumptions - * Mortgage (Prepay, Prepay Penalty, Deliquency, Default,Recovery Lag/Rate) - * Installment (Prepay Default Recovery Lag/Rate) - * Corp Loan (Prepay Default Recovery Lag/Rate) - * Receivable (Default Recovery Lag/Rate) - * Rentals (Gaps between leases,Rental Curve Assumption) - * Fixed Asset ( Uitility Rate) -* Multiple Waterfalls - * Clean up waterfall/ Pre,Post Enforcement waterfall - * Pool collection waterfall -* Accounts - * Reserve Account/Bank Account (with interest)/Cash Account/ Ledger(PDL) -* Bonds/Tranches - * Float Index rate / Step Up coupon type / Fix Rate - * Sequential / Prepay Lockout /PAC Bond Support /Z Bond Support - * Bond Pricing (IRR /WAL /Duration /Accrual Int) -* Call - * call by Pool/Bond Balance amount;Bond/Pool Factor;On Date/or after -* Fees - * Pool / Bond balanced based fees - * Fix Amount Fees / Custom Fee Flow / Number Type Fee of a deal / Formula based fee rate -* Liquidity Provider - * line of credit/ Unlimit support - * interest charge or fee charge on the credit used & unused -* Trigger - * Base on Date - * Base on Free Formula, Bond /Pool metrics - * Base on Pool performance, like Cumulative Default Rate, last 3 periods delinquency rates. - * Base on any combination above -* Interest Swap - * Float to Float/ Fix to Float - * formula based notional balance -* Scenario Analysis - * Running multiple scenarios on single deal - * Pricing on single asset - * Revoving Buy Analysis -* Free Formula Support - * User is able to using statistics of deal ( Pool Balance,Account balance ,total Bond Balance of , A factor of .. ) to construct formula which used to specify the amount of cash to transfer , pay out to fee or liabilities etc. -* Misc - * Support user define pay dates & pool collection dates + +
+Integration + +* Built-in REST API services + * Language independent, integration friendly. + * Swagger -> [here](https://github.com/absbox/Hastructure/blob/master/swagger.json) + * Public server status -> [here](https://absbox.org) +* Docker Support + +
+ +
+Asset class coverage + +* Mortgage/Student Loan/Auto Loan/Rentals/Corp Loan/Consumer Installment + +
+ +
+Pool Assumptions + +* Mortgage (Prepay, Prepay Penalty, Deliquency, Default,Recovery Lag/Rate) +* Installment (Prepay Default Recovery Lag/Rate) +* Corp Loan (Prepay Default Recovery Lag/Rate) +* Receivable (Default Recovery Lag/Rate) +* Rentals (Gaps between leases,Rental Curve Assumption) +* Fixed Asset ( Uitility Rate) + +
+ +
+Multiple Waterfalls + +* Clean up waterfall/ Pre,Post Enforcement waterfall +* Pool collection waterfall + +
+ +
+Accounts + +* Reserve Account/Bank Account (with interest)/Cash Account/ Ledger(PDL) + +
+ +
+Bonds/Tranches + +* Float Index rate / Step Up coupon type / Fix Rate +* Sequential / Prepay Lockout /PAC Bond Support /Z Bond Support +* Bond Pricing (IRR /WAL /Duration /Accrual Int) + +
+ +
+Call + +* call by Pool/Bond Balance amount;Bond/Pool Factor;On Date/or after + +
+ +
+Fees + +* Pool / Bond balanced based fees +* Fix Amount Fees / Custom Fee Flow / Number Type Fee of a deal / Formula based fee rate + +
+ +
+Liquidity Provider + +* line of credit/ Unlimit support +* interest charge or fee charge on the credit used & unused + +
+ +
+Trigger + +* Base on Date +* Base on Free Formula, Bond /Pool metrics +* Base on Pool performance, like Cumulative Default Rate, last 3 periods delinquency rates. +* Base on any combination above + +
+ +
+Interest Swap + +* Float to Float/ Fix to Float +* formula based notional balance + +
+ +
+Scenario Analysis + +* Running multiple scenarios on single deal +* Pricing on single asset +* Revoving Buy Analysis + +
+ +
+Free Formula Support + +* User is able to using statistics of deal ( Pool Balance,Account balance ,total Bond Balance of , A factor of .. ) to construct formula which used to specify the amount of cash to transfer , pay out to fee or liabilities etc. + +
+ +
+Misc + +* Support user define pay dates & pool collection dates + +
### Online Demo From b1b122315515a3030b4f3918fd8e74e50de426a1 Mon Sep 17 00:00:00 2001 From: yellowbean Date: Sun, 18 Oct 2026 01:19:53 +0800 Subject: [PATCH 37/40] =?UTF-8?q?CI:=20fix=20multi-arch=20merge=20?= =?UTF-8?q?=E2=80=94=20pass=20metadata=20JSON=20tags=20with=20-t=20flags;?= =?UTF-8?q?=20add=20workflow=5Fdispatch=20(PR=20#322=20H2)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .github/workflows/docker-image-dev-by-tag.yml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.github/workflows/docker-image-dev-by-tag.yml b/.github/workflows/docker-image-dev-by-tag.yml index f0d392f3..10611246 100644 --- a/.github/workflows/docker-image-dev-by-tag.yml +++ b/.github/workflows/docker-image-dev-by-tag.yml @@ -4,6 +4,7 @@ on: push: tags: - 'a*' + workflow_dispatch: # Multi-arch strategy: each platform is built natively on a runner of the same # architecture (no QEMU, no cross-compilation), pushed by digest, and the @@ -125,7 +126,7 @@ jobs: working-directory: /tmp/digests run: | docker buildx imagetools create \ - $(jq -r '.tags | join(" ")' <<< "$DOCKER_METADATA_OUTPUT_TAGS") \ + $(jq -r '.tags | map("-t " + .) | join(" ")' <<< "$DOCKER_METADATA_OUTPUT_JSON") \ $(printf '${{ env.IMAGE }}@sha256:%s ' *) - name: Inspect manifest From baacde263dee667ed646b5819ac563852a08e523 Mon Sep 17 00:00:00 2001 From: yellowbean Date: Sun, 18 Oct 2026 01:35:24 +0800 Subject: [PATCH 38/40] docs: fill Installation section; document config.yml fields --- README.md | 65 +++++++++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 56 insertions(+), 9 deletions(-) diff --git a/README.md b/README.md index 0222e26a..93f29402 100644 --- a/README.md +++ b/README.md @@ -29,6 +29,62 @@ * :coffee: Easy integration with ``Java/C#/C++/JavaScript/Python`` with ``RESTful`` interface and Docker image are ready. * C/Java : [here](https://github.com/absbox/Hastructure/issues/106) +### Installation + +#### From Docker + +Pull from [Docker Hub](https://hub.docker.com/r/yellowbean/hastructure) using the image path `yellowbean/hastructure` (full registry path `docker.io/yellowbean/hastructure`; `latest` follows the `v*` release tags, `dev` the `a*` dev tags): + +```bash +docker pull yellowbean/hastructure:latest +docker run -p 8081:8081 yellowbean/hastructure:latest +``` + +Or build the checkout with compose: + +```bash +docker compose up --build +``` + +The image ships `config.yml` and `swagger.json` in `/opt/myapp`; mount your own config over it to change the server settings: + +```bash +docker run -p 9090:9090 -v "$PWD/config.yml:/opt/myapp/config.yml" yellowbean/hastructure:latest +``` + +#### From nixpkgs + +```bash +nix-shell shell.nix # dev shell: GHC, HLS, cabal +nix-build release.nix -A hastructure # build the engine -> result/bin/Hastructure-exe +``` + +#### From release executables + +Prebuilt executables for Linux/macOS/Windows are attached to [GitHub releases](https://github.com/absbox/Hastructure/releases) as `Hastructure---ghc-`. Download one, then: + +```bash +chmod +x Hastructure--Linux-ghc-9.10.2 +./Hastructure--Linux-ghc-9.10.2 +``` + +Run it from a directory containing `config.yml`: the engine reads the file at startup and refuses to start when it is missing, malformed or contains an invalid value. + +#### Configuration (`config.yml`) + +See the sample [`config.yml`](https://github.com/absbox/Hastructure/blob/master/config.yml) in the repository. The engine reads it from the working directory once at startup (restart to apply changes); it holds the following fields: + +* `port` (required) — HTTP listen port; a missing `port` aborts startup. +* `workerNum` (optional) — in-flight evaluation cap applied to every multi-run request. Precedence: `HASTRUCTURE_WORKERS` environment variable (when it parses to a positive integer), then `workerNum`, then the RTS capability count (`+RTS -N`). A present-but-unusable value falls back to the next layer, since this is only a performance knob. +* `maxRunNum` (optional) — per-endpoint total-run caps configured as `maxRunNum.`, default `1000` each; a non-positive value aborts startup: + * `runPoolByScenarios` — number of pool scenarios + * `runDealByScenarios` — number of deal scenarios + * `runMultiDeals` — number of deals + * `runDealByRunScenarios` — number of non-performance assumption scenarios + * `runByCombo` — size of the deals × assumptions × non-performance assumptions cartesian product (sized before materialising, so oversized grids are rejected without allocation) +* Exceeding a cap — rejected with HTTP 400 in the standard JSON error envelope (`{"Left":"..."}`), naming the endpoint, the configured limit and the `maxRunNum.` key to raise. Invalid config values abort startup with an `invalid config.yml: ...` error naming the offending key. + + ### Documentation * see what `Hastructure` is capable of -> [Here](https://absbox-doc.readthedocs.io/en/latest/) @@ -155,14 +211,5 @@ -### Online Demo - -The demo only cover very limit features of this engine and subject to UI performance issue due to rapid prototype design of web component - -**Pls noted that the web demo is far behind latest development/stable version** - -* [Here](https://deal-bench.xyz) - - ### Others * [Why yet another cashflow engine](https://github.com/absbox/Hastructure/wiki/Why-Yet-Anohter-Cashflow-Engine) From 4c7a5aacc9bfd814b4242c28fe5a6ed26179a25a Mon Sep 17 00:00:00 2001 From: yellowbean Date: Sun, 18 Oct 2026 01:46:29 +0800 Subject: [PATCH 39/40] bump version to-> < 0.52.12 > --- Hastructure.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Hastructure.cabal b/Hastructure.cabal index 274b0ba3..1b15c8e9 100644 --- a/Hastructure.cabal +++ b/Hastructure.cabal @@ -5,7 +5,7 @@ cabal-version: 3.0 -- see: https://github.com/sol/hpack name: Hastructure -version: 0.52.11 +version: 0.52.12 synopsis: Cashflow modeling library for structured finance description: Please see the README on GitHub at category: StructuredFinance,Securitisation,Cashflow From a74860cbe93dd2a6bdb66e6bb800d790cf778177 Mon Sep 17 00:00:00 2001 From: yellowbean Date: Sun, 18 Oct 2026 11:51:43 +0800 Subject: [PATCH 40/40] CI: modernize v-tag release workflow - publish binaries to GitHub Releases (non-draft, gh CLI), add linux/arm64 + macos/arm64 legs, refresh archived actions, GHC 9.8.4 --- .github/workflows/docker-image.yml | 232 ++++++++++++++--------------- 1 file changed, 111 insertions(+), 121 deletions(-) diff --git a/.github/workflows/docker-image.yml b/.github/workflows/docker-image.yml index 08977cc1..cc52b195 100644 --- a/.github/workflows/docker-image.yml +++ b/.github/workflows/docker-image.yml @@ -1,134 +1,129 @@ name: Docker Image CI +# Release pipeline, triggered by pushing a tag that starts with `v` +# (e.g. `v0.52.12`), which: +# * builds native binaries for linux/amd64, linux/arm64, macOS/arm64 and +# Windows/amd64 and publishes them automatically to the GitHub "Releases" +# page for that tag (the release is created non-draft, with generated notes) +# * builds and pushes the amd64 image to Docker Hub (:latest + semver tags) +# * performs the Hackage release in dry-run mode +# +# NOTE: tags starting with `a` follow the dev track instead +# (.github/workflows/docker-image-dev-by-tag.yml -> Docker Hub :dev, multi-arch, +# no GitHub Release). GHC is pinned to the version proven green for the current +# code by `haskell.yml`; bump both together if the compiler moves. + on: push: tags: - 'v*' -jobs: - create_release: - permissions: write-all - name: Create Github Release - runs-on: ubuntu-latest - steps: - - name: Check out code - uses: actions/checkout@v2 +permissions: + contents: read - - name: Create Release - id: create_release - uses: actions/create-release@v1.1.1 - env: - GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} - with: - tag_name: ${{ github.ref }} - release_name: Release ${{ github.ref }} - draft: true - prerelease: false - - - name: Output Release URL File - run: echo "${{ steps.create_release.outputs.upload_url }}" > release_url.txt - - name: Save Release URL File for publish - uses: actions/upload-artifact@v4 - with: - name: release_url - path: release_url.txt - +env: + GHC_VERSION: "9.8.4" + +jobs: build_artifact: - needs: [create_release] - name: ${{ matrix.os }}/GHC ${{ matrix.ghc }}/${{ github.ref }} - runs-on: ${{ matrix.os }} + name: build/${{ matrix.name }} strategy: + fail-fast: false matrix: - os: [ubuntu-latest, macOS-latest, windows-latest] - ghc: - - "9.10.2" - cabal: ["3.10.3.0"] - + include: + - os: ubuntu-latest + name: linux-amd64 + - os: ubuntu-24.04-arm + name: linux-arm64 + - os: macos-latest + name: macos-arm64 + - os: windows-latest + name: windows-amd64 + runs-on: ${{ matrix.os }} steps: - - name: Check out code - uses: actions/checkout@v2 - - - name: Set tag name - uses: olegtarasov/get-tag@v2.1.3 - id: tag - with: - tagRegex: "v(.*)" - tagRegexGroup: 1 + - uses: actions/checkout@v4 - name: Setup Haskell - uses: haskell-actions/setup@v2 id: setup-haskell-cabal + uses: haskell-actions/setup@v2 with: - ghc-version: ${{ matrix.ghc }} - cabal-version: ${{ matrix.cabal }} + ghc-version: ${{ env.GHC_VERSION }} + cabal-version: "latest" - - name: Freeze - run: | - cabal freeze - - - name: Cache ~/.cabal/store - uses: actions/cache@v3 + - name: Cache cabal store + uses: actions/cache@v4 with: path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }} - key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} + key: cabal-${{ matrix.name }}-${{ hashFiles('*.cabal') }}-${{ hashFiles('cabal.project*') }} + restore-keys: | + cabal-${{ matrix.name }}- + + - name: Cabal update + run: cabal update - name: Build binary run: | - mkdir dist + mkdir -p dist cabal install Hastructure --install-method=copy --overwrite-policy=always --installdir=dist - - - if: matrix.os == 'windows-latest' - name: Set binary path name on windows - run: echo "BINARY_PATH=dist/Hastructure-exe.exe" >> $env:GITHUB_ENV - - - if: matrix.os != 'windows-latest' - name: Set binary path name on non-windows - run: echo "BINARY_PATH=dist/Hastructure-exe" >> $GITHUB_ENV - - - name: Load Release URL File from release job - uses: actions/download-artifact@v4 - with: - name: release_url - path: release_url - - - if: matrix.os == 'windows-latest' - name: Get Release File Name & Upload URL on Widows - run: | - echo "upload_url=$(cat release_url/release_url.txt)" >> $env:GITHUB_ENV - # See Note [environment variables] - - if: matrix.os != 'windows-latest' - name: Get Release File Name & Upload URL not on Widows + # Distinct per-OS asset names: the matrix legs would otherwise collide + # (every non-Windows leg produces a binary called `Hastructure-exe`). + - name: Stage asset name + shell: bash run: | - echo "upload_url=$(cat release_url/release_url.txt)" >> $GITHUB_ENV + if [ "${{ runner.os }}" = "Windows" ]; then + EXT=".exe" + else + EXT="" + fi + mv "dist/Hastructure-exe${EXT}" "dist/Hastructure-${GITHUB_REF_NAME}-${{ matrix.name }}${EXT}" + + - name: Upload artifact + uses: actions/upload-artifact@v4 + with: + name: release-${{ matrix.name }} + path: dist/* + if-no-files-found: error + + release: + name: Publish to GitHub Releases + needs: build_artifact + permissions: + contents: write + runs-on: ubuntu-latest + steps: + - name: Download all artifacts + uses: actions/download-artifact@v4 + with: + path: dist + pattern: release-* + merge-multiple: true - - name: Upload Release Asset - id: upload-release-asset - uses: actions/upload-release-asset@v1.0.1 + - name: Create release and upload binaries env: - GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} - with: - upload_url: ${{ env.upload_url }} - asset_path: ${{ env.BINARY_PATH }} - asset_name: Hastructure-${{ steps.tag.outputs.tag }}-${{ runner.os }}-ghc-${{ matrix.ghc }}${{ env.EXT }} - asset_content_type: application/octet-stream - - build: + GH_TOKEN: ${{ secrets.GITHUB_TOKEN }} + run: | + set -euo pipefail + TAG="${GITHUB_REF_NAME}" + ls -la dist/ + gh release view "$TAG" >/dev/null 2>&1 || \ + gh release create "$TAG" --generate-notes --title "Hastructure $TAG" + gh release upload "$TAG" --clobber dist/* + + docker: + name: push Docker image + needs: build_artifact + runs-on: ubuntu-latest + steps: + - name: Cleanup build folder (disk space) + run: | + rm -rf /opt/ghc /opt/hostedtoolcache 2>/dev/null || true - needs: [build_artifact] + - uses: actions/checkout@v4 - runs-on: ubuntu-latest + - uses: docker/setup-buildx-action@v3 - steps: - - - name: Set up QEMU - uses: docker/setup-qemu-action@v2 - - - name: Set up Docker Buildx - uses: docker/setup-buildx-action@v3 - - - name: Login to Docker Hub - uses: docker/login-action@v2 + - uses: docker/login-action@v3 with: username: ${{ secrets.DOCKER_HUB_USERNAME }} password: ${{ secrets.DOCKER_HUB_PW }} @@ -137,34 +132,29 @@ jobs: id: meta uses: docker/metadata-action@v5 with: - images: yellowbean/hastructure + images: ${{ secrets.DOCKER_HUB_USERNAME }}/hastructure + tags: | + type=semver,pattern={{version}} + type=semver,pattern=v{{version}} - - name: 'Cleanup build folder' - run: | - ls -la ./ - rm -rf ./* || true - rm -rf ./.??* || true - ls -la . - rm -rf /opt/ghc - rm -rf /opt/hostedtoolcache - - - - name: Build and push - uses: docker/build-push-action@v3 + - name: Build and push + uses: docker/build-push-action@v6 with: platforms: linux/amd64 push: true - tags: ${{ secrets.DOCKER_HUB_USERNAME }}/hastructure:latest, ${{ steps.meta.outputs.tags }} + tags: | + ${{ secrets.DOCKER_HUB_USERNAME }}/hastructure:latest + ${{ steps.meta.outputs.tags }} cache-from: type=registry,ref=${{ secrets.DOCKER_HUB_USERNAME }}/hastructure:buildcache - cache-to: type=registry,ref=${{ secrets.DOCKER_HUB_USERNAME }}/hastructure:buildcache,mode=max - - publish: - - needs: [build] + cache-to: type=registry,ref=${{ secrets.DOCKER_HUB_USERNAME }}/hastructure:buildcache,mode=max + hackage_dry_run: + name: Hackage dry-run + needs: release runs-on: ubuntu-latest - steps: + - uses: actions/checkout@v4 + - uses: haskell-actions/hackage-publish@v1 with: hackageToken: ${{ secrets.HACKAGE_KEY }}