Merge pull request #198 from CarterPerez-dev/chore/haskell-reverse-proxy-finish
feat: add Aenebris.ML.Inference and Aenebris.ML.Calibration
This commit is contained in:
Carter Perez
GitHub
commit
21601d4759
|
|
@ -0,0 +1,89 @@
|
|||
<!-- ©AngelaMos | 2026 -->
|
||||
<!-- DEMO.md -->
|
||||
|
||||
<div align="center">
|
||||
|
||||
```ruby
|
||||
███████╗███╗ ██╗ ██████╗██████╗ ██╗ ██╗██████╗ ████████╗███████╗██████╗
|
||||
██╔════╝████╗ ██║██╔════╝██╔══██╗╚██╗ ██╔╝██╔══██╗╚══██╔══╝██╔════╝██╔══██╗
|
||||
█████╗ ██╔██╗ ██║██║ ██████╔╝ ╚████╔╝ ██████╔╝ ██║ █████╗ ██║ ██║
|
||||
██╔══╝ ██║╚██╗██║██║ ██╔══██╗ ╚██╔╝ ██╔═══╝ ██║ ██╔══╝ ██║ ██║
|
||||
███████╗██║ ╚████║╚██████╗██║ ██║ ██║ ██║ ██║ ███████╗██████╔╝
|
||||
╚══════╝╚═╝ ╚═══╝ ╚═════╝╚═╝ ╚═╝ ╚═╝ ╚═╝ ╚═╝ ╚══════╝╚═════╝
|
||||
```
|
||||
|
||||
**Demo & Preview**
|
||||
|
||||
<br>
|
||||
|
||||
<a href="https://chat.carterperez-dev.com">
|
||||
<img src="https://img.shields.io/badge/▶_TRY_IT_LIVE-chat.carterperez--dev.com-DC143C?style=for-the-badge&logo=googlechrome&logoColor=white" alt="Live Demo"/>
|
||||
</a>
|
||||
|
||||
<br>
|
||||
|
||||
```ruby
|
||||
docker compose up -d → https://localhost
|
||||
```
|
||||
|
||||
<br>
|
||||
|
||||
[Register](#register) · [Login](#login) · [New Conversation](#new-conversation) · [Empty Conversation](#empty-conversation) · [First Message](#first-message) · [Encrypted Messaging](#encrypted-messaging) · [Mobile View](#mobile-view)
|
||||
|
||||
</div>
|
||||
|
||||
---
|
||||
|
||||
### Register
|
||||
|
||||
Passwordless account creation with WebAuthn passkey enrollment — username and display name are the only fields, no password is ever entered or stored
|
||||
|
||||
|
||||
|
||||
---
|
||||
|
||||
### Login
|
||||
|
||||
Passkey authentication with optional username field — leave blank to use a discoverable credential resolved by the authenticator
|
||||
|
||||
|
||||
|
||||
---
|
||||
|
||||
### New Conversation
|
||||
|
||||
Username search resolves the recipient's identity key from the directory before any message is composed
|
||||
|
||||
|
||||
|
||||
---
|
||||
|
||||
### Empty Conversation
|
||||
|
||||
Fresh thread with E2EE badge and presence indicator — no plaintext history is ever stored on the server, so a new conversation truly starts empty
|
||||
|
||||
|
||||
|
||||
---
|
||||
|
||||
### First Message
|
||||
|
||||
Outbound message encrypted client-side with the recipient's public key and pushed over WebSocket — the server only ever sees ciphertext
|
||||
|
||||
|
||||
|
||||
---
|
||||
|
||||
### Encrypted Messaging
|
||||
|
||||
Live two-way conversation with delivery timestamps and the lock indicator on every bubble confirming end-to-end encryption per message
|
||||
|
||||
|
||||
|
||||
---
|
||||
|
||||
### Mobile View
|
||||
|
||||
Responsive single-pane layout with collapsible sidebar — passkey auth and E2EE work identically on mobile via the platform authenticator
|
||||
|
||||
|
||||
Binary file not shown.
|
After Width: | Height: | Size: 22 KiB |
Binary file not shown.
|
After Width: | Height: | Size: 17 KiB |
Binary file not shown.
|
After Width: | Height: | Size: 17 KiB |
Binary file not shown.
|
After Width: | Height: | Size: 16 KiB |
Binary file not shown.
|
After Width: | Height: | Size: 16 KiB |
Binary file not shown.
|
After Width: | Height: | Size: 23 KiB |
Binary file not shown.
|
After Width: | Height: | Size: 18 KiB |
|
|
@ -41,6 +41,11 @@ library
|
|||
, Aenebris.ML.Features
|
||||
, Aenebris.ML.Model
|
||||
, Aenebris.ML.Loader
|
||||
, Aenebris.ML.Inference
|
||||
, Aenebris.ML.Calibration
|
||||
, Aenebris.ML.IForest
|
||||
, Aenebris.ML.Engine
|
||||
, Aenebris.ML.Middleware
|
||||
default-language: Haskell2010
|
||||
build-depends: base >= 4.7 && < 5
|
||||
, warp >= 3.3
|
||||
|
|
|
|||
|
|
@ -0,0 +1,245 @@
|
|||
{-
|
||||
©AngelaMos | 2026
|
||||
Calibration.hs
|
||||
-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
|
||||
module Aenebris.ML.Calibration
|
||||
( Calibrator(..)
|
||||
, calibrate
|
||||
, fitPlatt
|
||||
, fitIsotonic
|
||||
) where
|
||||
|
||||
import Data.List (sortBy)
|
||||
import Data.Ord (comparing)
|
||||
import qualified Data.Vector.Unboxed as VU
|
||||
import GHC.Generics (Generic)
|
||||
|
||||
maxNewtonIterations :: Int
|
||||
maxNewtonIterations = 100
|
||||
|
||||
newtonConvergenceTol :: Double
|
||||
newtonConvergenceTol = 1.0e-7
|
||||
|
||||
initialPlattA :: Double
|
||||
initialPlattA = 0.0
|
||||
|
||||
initialPlattB :: Double
|
||||
initialPlattB = 0.0
|
||||
|
||||
minLineSearchStep :: Double
|
||||
minLineSearchStep = 1.0e-10
|
||||
|
||||
initialLineSearchStep :: Double
|
||||
initialLineSearchStep = 1.0
|
||||
|
||||
lineSearchShrinkFactor :: Double
|
||||
lineSearchShrinkFactor = 0.5
|
||||
|
||||
degenerateHessianThreshold :: Double
|
||||
degenerateHessianThreshold = 1.0e-12
|
||||
|
||||
degenerateFallbackStep :: Double
|
||||
degenerateFallbackStep = 0.01
|
||||
|
||||
minSamplesForFitting :: Int
|
||||
minSamplesForFitting = 2
|
||||
|
||||
singletonBlockWeight :: Double
|
||||
singletonBlockWeight = 1.0
|
||||
|
||||
labelTrueValue :: Double
|
||||
labelTrueValue = 1.0
|
||||
|
||||
labelFalseValue :: Double
|
||||
labelFalseValue = 0.0
|
||||
|
||||
plattLabelSmoothingNumeratorOffset :: Double
|
||||
plattLabelSmoothingNumeratorOffset = 1.0
|
||||
|
||||
plattLabelSmoothingDenominatorOffset :: Double
|
||||
plattLabelSmoothingDenominatorOffset = 2.0
|
||||
|
||||
data Calibrator
|
||||
= NoCalibrator
|
||||
| PlattCalibrator !Double !Double
|
||||
| IsotonicCalibrator !(VU.Vector (Double, Double))
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
calibrate :: Calibrator -> Double -> Double
|
||||
calibrate NoCalibrator p = p
|
||||
calibrate (PlattCalibrator a b) p = sigmoidPositiveExponent (a * p + b)
|
||||
calibrate (IsotonicCalibrator bp) p = isotonicLookup bp p
|
||||
|
||||
sigmoidPositiveExponent :: Double -> Double
|
||||
sigmoidPositiveExponent z = 1.0 / (1.0 + exp z)
|
||||
|
||||
softplus :: Double -> Double
|
||||
softplus z = max 0.0 z + log (1.0 + exp (negate (abs z)))
|
||||
|
||||
boolToTarget :: Bool -> Double
|
||||
boolToTarget True = labelTrueValue
|
||||
boolToTarget False = labelFalseValue
|
||||
|
||||
fitPlatt :: VU.Vector (Double, Bool) -> Calibrator
|
||||
fitPlatt samples
|
||||
| VU.length samples < minSamplesForFitting = NoCalibrator
|
||||
| otherwise =
|
||||
let !nPos = VU.length (VU.filter snd samples)
|
||||
!nNeg = VU.length samples - nPos
|
||||
!targetPos = (fromIntegral nPos + plattLabelSmoothingNumeratorOffset)
|
||||
/ (fromIntegral nPos + plattLabelSmoothingDenominatorOffset)
|
||||
!targetNeg = plattLabelSmoothingNumeratorOffset
|
||||
/ (fromIntegral nNeg + plattLabelSmoothingDenominatorOffset)
|
||||
smoothed = VU.map
|
||||
(\(p, lbl) -> (p, if lbl then targetPos else targetNeg))
|
||||
samples
|
||||
(!a, !b) = plattNewton smoothed
|
||||
in PlattCalibrator a b
|
||||
|
||||
plattNewton :: VU.Vector (Double, Double) -> (Double, Double)
|
||||
plattNewton !smoothed = go 0 initialPlattA initialPlattB initialLoss
|
||||
where
|
||||
!initialLoss = computeNll smoothed initialPlattA initialPlattB
|
||||
|
||||
go :: Int -> Double -> Double -> Double -> (Double, Double)
|
||||
go !iter !a !b !prevLoss
|
||||
| iter >= maxNewtonIterations = (a, b)
|
||||
| otherwise =
|
||||
let (!gA, !gB, !hAA, !hAB, !hBB) = gradHessian smoothed a b
|
||||
!det = hAA * hBB - hAB * hAB
|
||||
(!stepA, !stepB)
|
||||
| abs det < degenerateHessianThreshold =
|
||||
( negate gA * degenerateFallbackStep
|
||||
, negate gB * degenerateFallbackStep
|
||||
)
|
||||
| otherwise =
|
||||
( negate (hBB * gA - hAB * gB) / det
|
||||
, negate (negate hAB * gA + hAA * gB) / det
|
||||
)
|
||||
(!newA, !newB, !newLoss) =
|
||||
lineSearch smoothed a b stepA stepB prevLoss initialLineSearchStep
|
||||
in if abs (prevLoss - newLoss) < newtonConvergenceTol
|
||||
then (newA, newB)
|
||||
else go (iter + 1) newA newB newLoss
|
||||
|
||||
lineSearch
|
||||
:: VU.Vector (Double, Double)
|
||||
-> Double -> Double -> Double -> Double -> Double -> Double
|
||||
-> (Double, Double, Double)
|
||||
lineSearch !smoothed !a !b !stepA !stepB !prevLoss !step
|
||||
| step < minLineSearchStep = (a, b, prevLoss)
|
||||
| otherwise =
|
||||
let !trialA = a + step * stepA
|
||||
!trialB = b + step * stepB
|
||||
!trialLoss = computeNll smoothed trialA trialB
|
||||
in if trialLoss < prevLoss
|
||||
then (trialA, trialB, trialLoss)
|
||||
else lineSearch smoothed a b stepA stepB prevLoss
|
||||
(step * lineSearchShrinkFactor)
|
||||
|
||||
computeNll :: VU.Vector (Double, Double) -> Double -> Double -> Double
|
||||
computeNll !smoothed !a !b = VU.foldl' addSample 0.0 smoothed
|
||||
where
|
||||
addSample !acc (!p, !t) =
|
||||
let !z = a * p + b
|
||||
in acc + softplus z - (1.0 - t) * z
|
||||
|
||||
gradHessian
|
||||
:: VU.Vector (Double, Double)
|
||||
-> Double
|
||||
-> Double
|
||||
-> (Double, Double, Double, Double, Double)
|
||||
gradHessian !smoothed !a !b =
|
||||
VU.foldl' step (0.0, 0.0, 0.0, 0.0, 0.0) smoothed
|
||||
where
|
||||
step (!gA, !gB, !hAA, !hAB, !hBB) (!p, !t) =
|
||||
let !z = a * p + b
|
||||
!q = sigmoidPositiveExponent z
|
||||
!d = t - q
|
||||
!dh = q * (1.0 - q)
|
||||
in ( gA + d * p
|
||||
, gB + d
|
||||
, hAA + dh * p * p
|
||||
, hAB + dh * p
|
||||
, hBB + dh
|
||||
)
|
||||
|
||||
fitIsotonic :: VU.Vector (Double, Bool) -> Calibrator
|
||||
fitIsotonic samples
|
||||
| VU.length samples < minSamplesForFitting = NoCalibrator
|
||||
| otherwise =
|
||||
let sorted = sortBy (comparing fst) (VU.toList samples)
|
||||
grouped = groupTies sorted
|
||||
smoothed = pav grouped
|
||||
breakpoints = map blockToBreakpoint smoothed
|
||||
in IsotonicCalibrator (VU.fromList breakpoints)
|
||||
|
||||
groupTies :: [(Double, Bool)] -> [(Double, Double, Double)]
|
||||
groupTies [] = []
|
||||
groupTies ((r0, l0) : rest) = goGroup r0 singletonBlockWeight (boolToTarget l0) rest
|
||||
where
|
||||
goGroup !curR !w !sumL [] = [(curR * w, sumL, w)]
|
||||
goGroup !curR !w !sumL ((r, l) : rs)
|
||||
| r == curR = goGroup curR (w + singletonBlockWeight) (sumL + boolToTarget l) rs
|
||||
| otherwise = (curR * w, sumL, w)
|
||||
: goGroup r singletonBlockWeight (boolToTarget l) rs
|
||||
|
||||
pav :: [(Double, Double, Double)] -> [(Double, Double, Double)]
|
||||
pav xs = reverse (foldl' push [] xs)
|
||||
where
|
||||
push :: [(Double, Double, Double)]
|
||||
-> (Double, Double, Double)
|
||||
-> [(Double, Double, Double)]
|
||||
push [] b = [b]
|
||||
push (top : rest) b
|
||||
| blockMean top > blockMean b = push rest (mergeBlocks top b)
|
||||
| otherwise = b : top : rest
|
||||
|
||||
blockMean :: (Double, Double, Double) -> Double
|
||||
blockMean (_, sumL, w) = sumL / w
|
||||
|
||||
blockRawMean :: (Double, Double, Double) -> Double
|
||||
blockRawMean (sumR, _, w) = sumR / w
|
||||
|
||||
blockToBreakpoint :: (Double, Double, Double) -> (Double, Double)
|
||||
blockToBreakpoint b = (blockRawMean b, blockMean b)
|
||||
|
||||
mergeBlocks
|
||||
:: (Double, Double, Double)
|
||||
-> (Double, Double, Double)
|
||||
-> (Double, Double, Double)
|
||||
mergeBlocks (r1, l1, w1) (r2, l2, w2) = (r1 + r2, l1 + l2, w1 + w2)
|
||||
|
||||
isotonicLookup :: VU.Vector (Double, Double) -> Double -> Double
|
||||
isotonicLookup !bp !p
|
||||
| VU.null bp = p
|
||||
| p <= fst (VU.head bp) = snd (VU.head bp)
|
||||
| p >= fst (VU.last bp) = snd (VU.last bp)
|
||||
| otherwise = interpolateBp bp p
|
||||
|
||||
interpolateBp :: VU.Vector (Double, Double) -> Double -> Double
|
||||
interpolateBp !bp !p =
|
||||
let !i = bisectRight bp p
|
||||
(!loRaw, !loCal) = VU.unsafeIndex bp (i - 1)
|
||||
(!hiRaw, !hiCal) = VU.unsafeIndex bp i
|
||||
!range = hiRaw - loRaw
|
||||
in if range == 0.0
|
||||
then loCal
|
||||
else
|
||||
let !frac = (p - loRaw) / range
|
||||
in loCal + frac * (hiCal - loCal)
|
||||
|
||||
bisectRight :: VU.Vector (Double, Double) -> Double -> Int
|
||||
bisectRight !bp !p = go 0 (VU.length bp)
|
||||
where
|
||||
go !lo !hi
|
||||
| lo >= hi = lo
|
||||
| otherwise =
|
||||
let !mid = lo + (hi - lo) `div` 2
|
||||
(!midRaw, _) = VU.unsafeIndex bp mid
|
||||
in if midRaw > p
|
||||
then go lo mid
|
||||
else go (mid + 1) hi
|
||||
|
|
@ -0,0 +1,119 @@
|
|||
{-
|
||||
©AngelaMos | 2026
|
||||
Engine.hs
|
||||
-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
|
||||
module Aenebris.ML.Engine
|
||||
( Engine(..)
|
||||
, EngineConfig(..)
|
||||
, Decision(..)
|
||||
, DecisionDetails(..)
|
||||
, defaultEngineConfig
|
||||
, makeEngine
|
||||
, runEngine
|
||||
, runEngineDecision
|
||||
) where
|
||||
|
||||
import qualified Data.Vector.Unboxed as VU
|
||||
import GHC.Generics (Generic)
|
||||
|
||||
import Aenebris.ML.Calibration
|
||||
( Calibrator(..)
|
||||
, calibrate
|
||||
)
|
||||
import Aenebris.ML.IForest
|
||||
( IForest
|
||||
, scoreIForest
|
||||
)
|
||||
import Aenebris.ML.Inference
|
||||
( predictProba
|
||||
)
|
||||
import Aenebris.ML.Model
|
||||
( Ensemble
|
||||
)
|
||||
|
||||
defaultHumanThreshold :: Double
|
||||
defaultHumanThreshold = 0.3
|
||||
|
||||
defaultBotThreshold :: Double
|
||||
defaultBotThreshold = 0.7
|
||||
|
||||
defaultIForestEscalation :: Double
|
||||
defaultIForestEscalation = 0.6
|
||||
|
||||
defaultChallengeOnAmbiguous :: Bool
|
||||
defaultChallengeOnAmbiguous = True
|
||||
|
||||
data Decision
|
||||
= DecisionHuman
|
||||
| DecisionBot
|
||||
| DecisionChallenge
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
data EngineConfig = EngineConfig
|
||||
{ ecHumanThreshold :: !Double
|
||||
, ecBotThreshold :: !Double
|
||||
, ecIForestEscalation :: !Double
|
||||
, ecChallengeOnAmbiguous :: !Bool
|
||||
} deriving (Eq, Show, Generic)
|
||||
|
||||
defaultEngineConfig :: EngineConfig
|
||||
defaultEngineConfig = EngineConfig
|
||||
{ ecHumanThreshold = defaultHumanThreshold
|
||||
, ecBotThreshold = defaultBotThreshold
|
||||
, ecIForestEscalation = defaultIForestEscalation
|
||||
, ecChallengeOnAmbiguous = defaultChallengeOnAmbiguous
|
||||
}
|
||||
|
||||
data Engine = Engine
|
||||
{ engineEnsemble :: !Ensemble
|
||||
, engineCalibrator :: !Calibrator
|
||||
, engineIForest :: !(Maybe IForest)
|
||||
, engineConfig :: !EngineConfig
|
||||
}
|
||||
|
||||
data DecisionDetails = DecisionDetails
|
||||
{ ddDecision :: !Decision
|
||||
, ddRawProba :: !Double
|
||||
, ddCalibrated :: !Double
|
||||
, ddIForestScore :: !(Maybe Double)
|
||||
} deriving (Eq, Show, Generic)
|
||||
|
||||
makeEngine
|
||||
:: Ensemble
|
||||
-> Calibrator
|
||||
-> Maybe IForest
|
||||
-> EngineConfig
|
||||
-> Engine
|
||||
makeEngine = Engine
|
||||
|
||||
runEngine :: Engine -> VU.Vector Double -> DecisionDetails
|
||||
runEngine !eng !fv =
|
||||
let !raw = predictProba (engineEnsemble eng) fv
|
||||
!calibrated = calibrate (engineCalibrator eng) raw
|
||||
!mIfScore = fmap (\f -> scoreIForest f fv) (engineIForest eng)
|
||||
!decision = decideOutcome (engineConfig eng) calibrated mIfScore
|
||||
in DecisionDetails
|
||||
{ ddDecision = decision
|
||||
, ddRawProba = raw
|
||||
, ddCalibrated = calibrated
|
||||
, ddIForestScore = mIfScore
|
||||
}
|
||||
|
||||
runEngineDecision :: Engine -> VU.Vector Double -> Decision
|
||||
runEngineDecision eng fv = ddDecision (runEngine eng fv)
|
||||
|
||||
decideOutcome :: EngineConfig -> Double -> Maybe Double -> Decision
|
||||
decideOutcome !cfg !calibrated !mIfScore
|
||||
| calibrated <= ecHumanThreshold cfg = DecisionHuman
|
||||
| calibrated >= ecBotThreshold cfg = DecisionBot
|
||||
| otherwise =
|
||||
case mIfScore of
|
||||
Just ifScore | ifScore >= ecIForestEscalation cfg ->
|
||||
DecisionBot
|
||||
_ ->
|
||||
if ecChallengeOnAmbiguous cfg
|
||||
then DecisionChallenge
|
||||
else DecisionHuman
|
||||
|
|
@ -0,0 +1,105 @@
|
|||
{-
|
||||
©AngelaMos | 2026
|
||||
IForest.hs
|
||||
-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
|
||||
module Aenebris.ML.IForest
|
||||
( ITree(..)
|
||||
, IForest(..)
|
||||
, scoreIForest
|
||||
, pathLength
|
||||
, normalizationConstant
|
||||
, harmonicNumber
|
||||
, eulerMascheroni
|
||||
, minSubsampleForNormalization
|
||||
, defaultIForestNumTrees
|
||||
, defaultIForestSubsampleSize
|
||||
) where
|
||||
|
||||
import Data.Vector (Vector)
|
||||
import qualified Data.Vector as V
|
||||
import qualified Data.Vector.Unboxed as VU
|
||||
import GHC.Generics (Generic)
|
||||
|
||||
eulerMascheroni :: Double
|
||||
eulerMascheroni = 0.5772156649015329
|
||||
|
||||
minSubsampleForNormalization :: Int
|
||||
minSubsampleForNormalization = 2
|
||||
|
||||
initialDepth :: Int
|
||||
initialDepth = 0
|
||||
|
||||
zeroAnomalyScore :: Double
|
||||
zeroAnomalyScore = 0.0
|
||||
|
||||
scoreBase :: Double
|
||||
scoreBase = 2.0
|
||||
|
||||
defaultIForestNumTrees :: Int
|
||||
defaultIForestNumTrees = 100
|
||||
|
||||
defaultIForestSubsampleSize :: Int
|
||||
defaultIForestSubsampleSize = 256
|
||||
|
||||
data ITree
|
||||
= ITreeLeaf !Int
|
||||
| ITreeSplit !Int !Double !ITree !ITree
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
data IForest = IForest
|
||||
{ ifTrees :: !(Vector ITree)
|
||||
, ifSubsampleSize :: !Int
|
||||
} deriving (Eq, Show, Generic)
|
||||
|
||||
scoreIForest :: IForest -> VU.Vector Double -> Double
|
||||
scoreIForest !forest !fv =
|
||||
let !trees = ifTrees forest
|
||||
!numTrees = V.length trees
|
||||
!subsample = ifSubsampleSize forest
|
||||
!cn = normalizationConstant subsample
|
||||
in if numTrees == 0 || cn <= 0.0
|
||||
then zeroAnomalyScore
|
||||
else
|
||||
let !eHx = averagePathLength trees fv
|
||||
in scoreBase ** (negate eHx / cn)
|
||||
|
||||
averagePathLength :: Vector ITree -> VU.Vector Double -> Double
|
||||
averagePathLength !trees !fv =
|
||||
let !numTrees = V.length trees
|
||||
!totalDepth = V.foldl' addPath 0.0 trees
|
||||
in if numTrees == 0
|
||||
then 0.0
|
||||
else totalDepth / fromIntegral numTrees
|
||||
where
|
||||
addPath !acc !tree = acc + pathLength tree fv initialDepth
|
||||
|
||||
pathLength :: ITree -> VU.Vector Double -> Int -> Double
|
||||
pathLength !tree !fv !currentDepth = case tree of
|
||||
ITreeLeaf !size ->
|
||||
fromIntegral currentDepth + normalizationConstant size
|
||||
ITreeSplit !featIdx !thr !left !right ->
|
||||
let !fval = fv VU.! featIdx
|
||||
in if fval <= thr
|
||||
then pathLength left fv (currentDepth + 1)
|
||||
else pathLength right fv (currentDepth + 1)
|
||||
|
||||
normalizationConstant :: Int -> Double
|
||||
normalizationConstant n
|
||||
| n < minSubsampleForNormalization = 0.0
|
||||
| otherwise =
|
||||
let !nDouble = fromIntegral n
|
||||
!nMinusOne = fromIntegral (n - 1)
|
||||
in 2.0 * harmonicNumber (n - 1) - 2.0 * nMinusOne / nDouble
|
||||
|
||||
harmonicNumber :: Int -> Double
|
||||
harmonicNumber n
|
||||
| n <= 0 = 0.0
|
||||
| otherwise = go 1 0.0
|
||||
where
|
||||
go :: Int -> Double -> Double
|
||||
go !i !acc
|
||||
| i > n = acc
|
||||
| otherwise = go (i + 1) (acc + 1.0 / fromIntegral i)
|
||||
|
|
@ -0,0 +1,124 @@
|
|||
{-
|
||||
©AngelaMos | 2026
|
||||
Inference.hs
|
||||
-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
|
||||
module Aenebris.ML.Inference
|
||||
( walkTree
|
||||
, predictRaw
|
||||
, predictScore
|
||||
, predictProba
|
||||
, sigmoidLink
|
||||
, kZeroThreshold
|
||||
) where
|
||||
|
||||
import Data.Bits (shiftR, testBit, (.&.))
|
||||
import qualified Data.Vector as V
|
||||
import qualified Data.Vector.Unboxed as VU
|
||||
|
||||
import Aenebris.ML.Model
|
||||
( Ensemble(..)
|
||||
, MissingType(..)
|
||||
, Objective(..)
|
||||
, SplitKind(..)
|
||||
, Tree(..)
|
||||
, decisionTypeBits
|
||||
, defaultRootIndex
|
||||
, ensembleTreeCount
|
||||
, nodeIsLeaf
|
||||
)
|
||||
|
||||
kZeroThreshold :: Double
|
||||
kZeroThreshold = 1.0e-35
|
||||
|
||||
bitsPerWordShift :: Int
|
||||
bitsPerWordShift = 5
|
||||
|
||||
bitsPerWordMask :: Int
|
||||
bitsPerWordMask = 31
|
||||
|
||||
zeroFeatureValue :: Double
|
||||
zeroFeatureValue = 0.0
|
||||
|
||||
sigmoidNumerator :: Double
|
||||
sigmoidNumerator = 1.0
|
||||
|
||||
sigmoidBias :: Double
|
||||
sigmoidBias = 1.0
|
||||
|
||||
walkTree :: Tree -> VU.Vector Double -> Int
|
||||
walkTree !tree !fv = go defaultRootIndex
|
||||
where
|
||||
go !i
|
||||
| nodeIsLeaf tree i = i
|
||||
| otherwise = go (chooseChild tree i fv)
|
||||
|
||||
chooseChild :: Tree -> Int -> VU.Vector Double -> Int
|
||||
chooseChild !tree !i !fv =
|
||||
let !dt = treeDecisionType tree VU.! i
|
||||
!featIdx = treeFeatureIdx tree VU.! i
|
||||
!rawFval = fv VU.! featIdx
|
||||
(!kind, !defaultLeft, !mtype) = decisionTypeBits dt
|
||||
!goLeft = treeLeftChild tree VU.! i
|
||||
!goRight = treeRightChild tree VU.! i
|
||||
!fval = if isNaN rawFval && mtype /= MissingTypeNaN
|
||||
then zeroFeatureValue
|
||||
else rawFval
|
||||
in if hitsMissingDefault mtype fval
|
||||
then if defaultLeft then goLeft else goRight
|
||||
else case kind of
|
||||
SplitNumerical
|
||||
| fval <= treeThreshold tree VU.! i -> goLeft
|
||||
| otherwise -> goRight
|
||||
SplitCategorical
|
||||
| categoricalGoesLeft tree i fval -> goLeft
|
||||
| otherwise -> goRight
|
||||
|
||||
hitsMissingDefault :: MissingType -> Double -> Bool
|
||||
hitsMissingDefault MissingTypeZero fval = isZeroLgbm fval
|
||||
hitsMissingDefault MissingTypeNaN fval = isNaN fval
|
||||
hitsMissingDefault MissingTypeNone _ = False
|
||||
|
||||
isZeroLgbm :: Double -> Bool
|
||||
isZeroLgbm fval =
|
||||
fval > negate kZeroThreshold && fval < kZeroThreshold
|
||||
|
||||
categoricalGoesLeft :: Tree -> Int -> Double -> Bool
|
||||
categoricalGoesLeft !tree !i !fval
|
||||
| isNaN fval || isInfinite fval || fval < 0 = False
|
||||
| otherwise =
|
||||
let !ifval = floor fval :: Int
|
||||
!catIdx = floor (treeThreshold tree VU.! i) :: Int
|
||||
!bStart = treeCatBoundaries tree VU.! catIdx
|
||||
!bEnd = treeCatBoundaries tree VU.! (catIdx + 1)
|
||||
!nWords = bEnd - bStart
|
||||
!off = ifval `shiftR` bitsPerWordShift
|
||||
in (off < nWords)
|
||||
&& testBit (treeCatThreshold tree VU.! (bStart + off))
|
||||
(ifval .&. bitsPerWordMask)
|
||||
|
||||
predictRaw :: Ensemble -> VU.Vector Double -> Double
|
||||
predictRaw !ens !fv = V.foldl' addLeafValue 0.0 (ensembleTrees ens)
|
||||
where
|
||||
addLeafValue !acc !tree =
|
||||
acc + treeLeafValue tree VU.! walkTree tree fv
|
||||
|
||||
predictScore :: Ensemble -> VU.Vector Double -> Double
|
||||
predictScore !ens !fv =
|
||||
let !raw = predictRaw ens fv
|
||||
!n = ensembleTreeCount ens
|
||||
in if ensembleAverageOutput ens && n > 0
|
||||
then raw / fromIntegral n
|
||||
else raw
|
||||
|
||||
predictProba :: Ensemble -> VU.Vector Double -> Double
|
||||
predictProba !ens !fv =
|
||||
let !s = predictScore ens fv
|
||||
in case ensembleObjective ens of
|
||||
ObjectiveBinaryLogistic -> sigmoidLink (ensembleSigmoidScale ens) s
|
||||
ObjectiveRegression -> s
|
||||
|
||||
sigmoidLink :: Double -> Double -> Double
|
||||
sigmoidLink !scale !x =
|
||||
sigmoidNumerator / (sigmoidBias + exp (negate (scale * x)))
|
||||
|
|
@ -0,0 +1,170 @@
|
|||
{-
|
||||
©AngelaMos | 2026
|
||||
Middleware.hs
|
||||
-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Aenebris.ML.Middleware
|
||||
( MLMiddlewareConfig(..)
|
||||
, defaultMLMiddlewareConfig
|
||||
, defaultBotResponse
|
||||
, defaultChallengeResponse
|
||||
, mlBotDetectionMiddleware
|
||||
, decisionResponseHeader
|
||||
, scoreResponseHeader
|
||||
, decisionToWireText
|
||||
) where
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString.Char8 as BC
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import Network.HTTP.Types (HeaderName, hContentType, status403)
|
||||
import Network.Wai
|
||||
( Application
|
||||
, Middleware
|
||||
, Request
|
||||
, Response
|
||||
, ResponseReceived
|
||||
, mapResponseHeaders
|
||||
, responseLBS
|
||||
)
|
||||
|
||||
import Aenebris.ML.Engine
|
||||
( Decision(..)
|
||||
, DecisionDetails(..)
|
||||
, Engine
|
||||
, runEngine
|
||||
)
|
||||
import Aenebris.ML.Features
|
||||
( FeatureContext
|
||||
, extractFeatures
|
||||
, featureVectorToVector
|
||||
)
|
||||
|
||||
humanWireText :: ByteString
|
||||
humanWireText = "human"
|
||||
|
||||
botWireText :: ByteString
|
||||
botWireText = "bot"
|
||||
|
||||
challengeWireText :: ByteString
|
||||
challengeWireText = "challenge"
|
||||
|
||||
botBlockBody :: LBS.ByteString
|
||||
botBlockBody = "403 Forbidden \x2014 request blocked by Aenebris ML"
|
||||
|
||||
challengePageBody :: LBS.ByteString
|
||||
challengePageBody =
|
||||
"<!DOCTYPE html>\n\
|
||||
\<html lang=\"en\">\n\
|
||||
\<head><meta charset=\"utf-8\"><title>Verification Required</title></head>\n\
|
||||
\<body>\n\
|
||||
\<h1>Verification Required</h1>\n\
|
||||
\<p>Aenebris ML flagged this request as ambiguous. Please complete a \
|
||||
\verification challenge to continue.</p>\n\
|
||||
\</body>\n\
|
||||
\</html>\n"
|
||||
|
||||
contentTypePlain :: ByteString
|
||||
contentTypePlain = "text/plain; charset=utf-8"
|
||||
|
||||
contentTypeHtml :: ByteString
|
||||
contentTypeHtml = "text/html; charset=utf-8"
|
||||
|
||||
decisionResponseHeader :: HeaderName
|
||||
decisionResponseHeader = CI.mk "X-Aenebris-ML-Decision"
|
||||
|
||||
scoreResponseHeader :: HeaderName
|
||||
scoreResponseHeader = CI.mk "X-Aenebris-ML-Score"
|
||||
|
||||
decisionToWireText :: Decision -> ByteString
|
||||
decisionToWireText DecisionHuman = humanWireText
|
||||
decisionToWireText DecisionBot = botWireText
|
||||
decisionToWireText DecisionChallenge = challengeWireText
|
||||
|
||||
calibratedToHeaderValue :: Double -> ByteString
|
||||
calibratedToHeaderValue = BC.pack . show
|
||||
|
||||
data MLMiddlewareConfig = MLMiddlewareConfig
|
||||
{ mmcEngine :: !Engine
|
||||
, mmcFeatureContext :: !FeatureContext
|
||||
, mmcBotResponse :: !(Request -> DecisionDetails -> Response)
|
||||
, mmcChallengeResponse :: !(Request -> DecisionDetails -> Response)
|
||||
, mmcLogDetails :: !(Maybe (Request -> DecisionDetails -> IO ()))
|
||||
, mmcAttachHeaders :: !Bool
|
||||
}
|
||||
|
||||
defaultMLMiddlewareConfig
|
||||
:: Engine
|
||||
-> FeatureContext
|
||||
-> MLMiddlewareConfig
|
||||
defaultMLMiddlewareConfig eng ctx = MLMiddlewareConfig
|
||||
{ mmcEngine = eng
|
||||
, mmcFeatureContext = ctx
|
||||
, mmcBotResponse = defaultBotResponse
|
||||
, mmcChallengeResponse = defaultChallengeResponse
|
||||
, mmcLogDetails = Nothing
|
||||
, mmcAttachHeaders = True
|
||||
}
|
||||
|
||||
defaultBotResponse :: Request -> DecisionDetails -> Response
|
||||
defaultBotResponse _req details =
|
||||
responseLBS
|
||||
status403
|
||||
(mlSignalHeaders DecisionBot details
|
||||
<> [(hContentType, contentTypePlain)])
|
||||
botBlockBody
|
||||
|
||||
defaultChallengeResponse :: Request -> DecisionDetails -> Response
|
||||
defaultChallengeResponse _req details =
|
||||
responseLBS
|
||||
status403
|
||||
(mlSignalHeaders DecisionChallenge details
|
||||
<> [(hContentType, contentTypeHtml)])
|
||||
challengePageBody
|
||||
|
||||
mlSignalHeaders :: Decision -> DecisionDetails -> [(CI ByteString, ByteString)]
|
||||
mlSignalHeaders decision details =
|
||||
[ (decisionResponseHeader, decisionToWireText decision)
|
||||
, (scoreResponseHeader, calibratedToHeaderValue (ddCalibrated details))
|
||||
]
|
||||
|
||||
mlBotDetectionMiddleware :: MLMiddlewareConfig -> Middleware
|
||||
mlBotDetectionMiddleware cfg app req respond = do
|
||||
let !fv = extractFeatures (mmcFeatureContext cfg) req
|
||||
!fvVec = featureVectorToVector fv
|
||||
!details = runEngine (mmcEngine cfg) fvVec
|
||||
emitLog cfg req details
|
||||
routeDecision cfg app req respond details
|
||||
|
||||
emitLog
|
||||
:: MLMiddlewareConfig -> Request -> DecisionDetails -> IO ()
|
||||
emitLog cfg req details = case mmcLogDetails cfg of
|
||||
Just logger -> logger req details
|
||||
Nothing -> pure ()
|
||||
|
||||
routeDecision
|
||||
:: MLMiddlewareConfig
|
||||
-> Application
|
||||
-> Request
|
||||
-> (Response -> IO ResponseReceived)
|
||||
-> DecisionDetails
|
||||
-> IO ResponseReceived
|
||||
routeDecision cfg app req respond details = case ddDecision details of
|
||||
DecisionHuman ->
|
||||
let respondWithHeaders =
|
||||
if mmcAttachHeaders cfg
|
||||
then respond . attachHumanSignalHeaders details
|
||||
else respond
|
||||
in app req respondWithHeaders
|
||||
DecisionBot ->
|
||||
respond (mmcBotResponse cfg req details)
|
||||
DecisionChallenge ->
|
||||
respond (mmcChallengeResponse cfg req details)
|
||||
|
||||
attachHumanSignalHeaders :: DecisionDetails -> Response -> Response
|
||||
attachHumanSignalHeaders details =
|
||||
mapResponseHeaders (mlSignalHeaders DecisionHuman details ++)
|
||||
|
|
@ -180,6 +180,49 @@ import Aenebris.ML.Features
|
|||
, uaSecChConsistency
|
||||
, userAgentLengthCap
|
||||
)
|
||||
import Aenebris.ML.Calibration
|
||||
( Calibrator(..)
|
||||
, calibrate
|
||||
, fitIsotonic
|
||||
, fitPlatt
|
||||
)
|
||||
import Aenebris.ML.Engine
|
||||
( Decision(..)
|
||||
, DecisionDetails(..)
|
||||
, Engine(..)
|
||||
, EngineConfig(..)
|
||||
, defaultEngineConfig
|
||||
, makeEngine
|
||||
, runEngine
|
||||
, runEngineDecision
|
||||
)
|
||||
import Aenebris.ML.Middleware
|
||||
( MLMiddlewareConfig(..)
|
||||
, decisionResponseHeader
|
||||
, decisionToWireText
|
||||
, defaultMLMiddlewareConfig
|
||||
, mlBotDetectionMiddleware
|
||||
, scoreResponseHeader
|
||||
)
|
||||
import Aenebris.ML.IForest
|
||||
( IForest(..)
|
||||
, ITree(..)
|
||||
, defaultIForestNumTrees
|
||||
, defaultIForestSubsampleSize
|
||||
, eulerMascheroni
|
||||
, harmonicNumber
|
||||
, normalizationConstant
|
||||
, pathLength
|
||||
, scoreIForest
|
||||
)
|
||||
import Aenebris.ML.Inference
|
||||
( kZeroThreshold
|
||||
, predictProba
|
||||
, predictRaw
|
||||
, predictScore
|
||||
, sigmoidLink
|
||||
, walkTree
|
||||
)
|
||||
import Aenebris.ML.Loader
|
||||
( ParseError(..)
|
||||
, parseEnsemble
|
||||
|
|
@ -217,6 +260,7 @@ import Aenebris.WAF.Rule
|
|||
|
||||
import Control.Concurrent.STM
|
||||
( atomically
|
||||
, modifyTVar'
|
||||
, newTVarIO
|
||||
, readTVarIO
|
||||
)
|
||||
|
|
@ -271,7 +315,8 @@ import Network.Wai.Test
|
|||
, simpleStatus
|
||||
)
|
||||
import Test.Hspec
|
||||
( Spec
|
||||
( Expectation
|
||||
, Spec
|
||||
, describe
|
||||
, expectationFailure
|
||||
, hspec
|
||||
|
|
@ -333,6 +378,11 @@ main = hspec $ do
|
|||
mlFeaturesSpec
|
||||
mlModelSpec
|
||||
mlLoaderSpec
|
||||
mlInferenceSpec
|
||||
mlCalibrationSpec
|
||||
mlIForestSpec
|
||||
mlEngineSpec
|
||||
mlMiddlewareSpec
|
||||
|
||||
configSpec :: Spec
|
||||
configSpec = describe "Config" $ do
|
||||
|
|
@ -2042,6 +2092,689 @@ mlLoaderSpec = describe "ML.Loader" $ do
|
|||
Left err -> peKey err `shouldBe` "version"
|
||||
Right _ -> expectationFailure "expected Left"
|
||||
|
||||
mkCatStump :: Bool -> MissingType -> [Word32] -> Double -> Double -> Tree
|
||||
mkCatStump defaultLeft mtype bitmap leftV rightV =
|
||||
let bitmapVec = VU.fromList bitmap
|
||||
boundaries = VU.fromList [0, VU.length bitmapVec]
|
||||
dt = makeDecisionType SplitCategorical defaultLeft mtype
|
||||
in Tree
|
||||
{ treeFeatureIdx = VU.fromList [0, leafSentinel, leafSentinel]
|
||||
, treeThreshold = VU.fromList [0.0, 0.0, 0.0]
|
||||
, treeLeftChild = VU.fromList [1, noChildIndex, noChildIndex]
|
||||
, treeRightChild = VU.fromList [2, noChildIndex, noChildIndex]
|
||||
, treeLeafValue = VU.fromList [0.0, leftV, rightV]
|
||||
, treeDecisionType = VU.fromList [dt, 0, 0]
|
||||
, treeCatBoundaries = boundaries
|
||||
, treeCatThreshold = bitmapVec
|
||||
}
|
||||
|
||||
mkSingleFeatureEnsemble :: Objective -> Double -> Bool -> [Tree] -> Ensemble
|
||||
mkSingleFeatureEnsemble obj sig avg trees = Ensemble
|
||||
{ ensembleVersion = currentEnsembleVersion
|
||||
, ensembleFeatureCount = 1
|
||||
, ensembleObjective = obj
|
||||
, ensembleBaseScore = 0.0
|
||||
, ensembleSigmoidScale = sig
|
||||
, ensembleAverageOutput = avg
|
||||
, ensembleTrees = V.fromList trees
|
||||
}
|
||||
|
||||
binaryEnsemble :: [Tree] -> Ensemble
|
||||
binaryEnsemble = mkSingleFeatureEnsemble ObjectiveBinaryLogistic defaultSigmoidScale False
|
||||
|
||||
singletonFv :: Double -> VU.Vector Double
|
||||
singletonFv = VU.singleton
|
||||
|
||||
mlInferenceSpec :: Spec
|
||||
mlInferenceSpec = describe "ML.Inference" $ do
|
||||
tinyBytes <- runIO (BS.readFile "test/fixtures/ml/tiny_lgbm_v4.txt")
|
||||
|
||||
describe "walkTree on a leaf-only tree" $ do
|
||||
it "returns the root index for a stump tree" $
|
||||
walkTree (makeLeafTree 0.42) (singletonFv 0.0) `shouldBe` 0
|
||||
|
||||
it "predictRaw returns the leaf value for a single-leaf single-tree ensemble" $
|
||||
predictRaw (binaryEnsemble [makeLeafTree 0.42]) (singletonFv 0.0)
|
||||
`shouldBe` 0.42
|
||||
|
||||
describe "walkTree on a numerical stump (defaultLeft=True, MissingTypeNone)" $ do
|
||||
let tree = makeStumpTreeWithMissing 0 0.5 (-1.0) 1.0 True MissingTypeNone
|
||||
ens = binaryEnsemble [tree]
|
||||
|
||||
it "fval below threshold goes left (leaf value -1.0)" $
|
||||
predictRaw ens (singletonFv 0.0) `shouldBe` (-1.0)
|
||||
|
||||
it "fval above threshold goes right (leaf value 1.0)" $
|
||||
predictRaw ens (singletonFv 0.9) `shouldBe` 1.0
|
||||
|
||||
it "fval exactly at threshold goes left (predicate is <=, not <)" $
|
||||
predictRaw ens (singletonFv 0.5) `shouldBe` (-1.0)
|
||||
|
||||
it "NaN with MissingTypeNone is remapped to 0 then compared (0 <= 0.5 -> left)" $
|
||||
predictRaw ens (singletonFv (0.0 / 0.0)) `shouldBe` (-1.0)
|
||||
|
||||
describe "MissingType=Zero routes via default-left flag" $ do
|
||||
let leftTree = makeStumpTreeWithMissing 0 (-10.0) 7.0 (-7.0) True MissingTypeZero
|
||||
rightTree = makeStumpTreeWithMissing 0 (-10.0) 7.0 (-7.0) False MissingTypeZero
|
||||
|
||||
it "0.0 with defaultLeft=True hits left branch (ignoring threshold)" $
|
||||
predictRaw (binaryEnsemble [leftTree]) (singletonFv 0.0) `shouldBe` 7.0
|
||||
|
||||
it "0.0 with defaultLeft=False hits right branch (ignoring threshold)" $
|
||||
predictRaw (binaryEnsemble [rightTree]) (singletonFv 0.0) `shouldBe` (-7.0)
|
||||
|
||||
it "tiny non-zero (2e-36) is treated as zero by IsZero(kZeroThreshold=1e-35)" $
|
||||
predictRaw (binaryEnsemble [leftTree]) (singletonFv 2.0e-36)
|
||||
`shouldBe` 7.0
|
||||
|
||||
it "value just above kZeroThreshold is NOT treated as zero" $
|
||||
predictRaw (binaryEnsemble [leftTree]) (singletonFv 1.0e-30)
|
||||
`shouldBe` (-7.0)
|
||||
|
||||
describe "MissingType=NaN routes only when feature is NaN" $ do
|
||||
let nanTree = makeStumpTreeWithMissing 0 0.5 (-1.0) 1.0 True MissingTypeNaN
|
||||
|
||||
it "NaN feature uses default-left (left leaf -1.0)" $
|
||||
predictRaw (binaryEnsemble [nanTree]) (singletonFv (0.0 / 0.0))
|
||||
`shouldBe` (-1.0)
|
||||
|
||||
it "non-NaN feature still uses normal threshold comparison" $
|
||||
predictRaw (binaryEnsemble [nanTree]) (singletonFv 0.9)
|
||||
`shouldBe` 1.0
|
||||
|
||||
describe "categorical bitmap routing" $ do
|
||||
let bitmap5 = [5 :: Word32]
|
||||
|
||||
it "category 0 in bitmap 0b101 routes left" $
|
||||
predictRaw (binaryEnsemble [mkCatStump False MissingTypeNone bitmap5 (-2.0) 2.0])
|
||||
(singletonFv 0.0)
|
||||
`shouldBe` (-2.0)
|
||||
|
||||
it "category 1 NOT in bitmap 0b101 routes right" $
|
||||
predictRaw (binaryEnsemble [mkCatStump False MissingTypeNone bitmap5 (-2.0) 2.0])
|
||||
(singletonFv 1.0)
|
||||
`shouldBe` 2.0
|
||||
|
||||
it "category 2 in bitmap 0b101 routes left" $
|
||||
predictRaw (binaryEnsemble [mkCatStump False MissingTypeNone bitmap5 (-2.0) 2.0])
|
||||
(singletonFv 2.0)
|
||||
`shouldBe` (-2.0)
|
||||
|
||||
it "category beyond bitmap range routes right" $
|
||||
predictRaw (binaryEnsemble [mkCatStump False MissingTypeNone bitmap5 (-2.0) 2.0])
|
||||
(singletonFv 99.0)
|
||||
`shouldBe` 2.0
|
||||
|
||||
it "negative categorical feature routes right" $
|
||||
predictRaw (binaryEnsemble [mkCatStump False MissingTypeNone bitmap5 (-2.0) 2.0])
|
||||
(singletonFv (-1.0))
|
||||
`shouldBe` 2.0
|
||||
|
||||
it "categorical NaN with MissingTypeZero routes via default-left" $
|
||||
predictRaw (binaryEnsemble [mkCatStump True MissingTypeZero bitmap5 (-2.0) 2.0])
|
||||
(singletonFv (0.0 / 0.0))
|
||||
`shouldBe` (-2.0)
|
||||
|
||||
describe "multi-tree ensemble sums leaf contributions" $ do
|
||||
let t1 = makeStumpTreeWithMissing 0 0.0 (-0.3) 0.3 False MissingTypeNone
|
||||
t2 = makeStumpTreeWithMissing 0 0.5 (-0.2) 0.2 False MissingTypeNone
|
||||
|
||||
it "sums each tree's chosen leaf value" $
|
||||
predictRaw (binaryEnsemble [t1, t2]) (singletonFv 0.7)
|
||||
`shouldBe` 0.5
|
||||
|
||||
it "different feature value picks different leaves and changes the sum" $
|
||||
predictRaw (binaryEnsemble [t1, t2]) (singletonFv (-0.1))
|
||||
`shouldBe` (-0.5)
|
||||
|
||||
describe "predictScore: average_output divisor" $ do
|
||||
let t1 = makeLeafTree 1.0
|
||||
t2 = makeLeafTree 3.0
|
||||
|
||||
it "no average_output: predictScore equals predictRaw" $ do
|
||||
let ens = mkSingleFeatureEnsemble ObjectiveBinaryLogistic defaultSigmoidScale False [t1, t2]
|
||||
predictScore ens (singletonFv 0.0) `shouldBe` 4.0
|
||||
|
||||
it "average_output=True divides raw by num_trees" $ do
|
||||
let ens = mkSingleFeatureEnsemble ObjectiveBinaryLogistic defaultSigmoidScale True [t1, t2]
|
||||
predictScore ens (singletonFv 0.0) `shouldBe` 2.0
|
||||
|
||||
it "average_output=True with empty tree vector falls back to raw (n=0 guard)" $ do
|
||||
let ens = mkSingleFeatureEnsemble ObjectiveBinaryLogistic defaultSigmoidScale True []
|
||||
predictScore ens (singletonFv 0.0) `shouldBe` 0.0
|
||||
|
||||
describe "sigmoidLink" $ do
|
||||
it "scale*x = 0 yields 0.5" $
|
||||
sigmoidLink 1.0 0.0 `shouldBe` 0.5
|
||||
|
||||
it "very large positive x saturates near 1.0" $
|
||||
sigmoidLink 1.0 1000.0 `shouldBe` 1.0
|
||||
|
||||
it "very large negative x saturates near 0.0" $
|
||||
sigmoidLink 1.0 (-1000.0) `shouldBe` 0.0
|
||||
|
||||
it "scale=0.5 halves the steepness" $
|
||||
sigmoidLink 0.5 2.0 `shouldBe` (1.0 / (1.0 + exp (-1.0)))
|
||||
|
||||
describe "predictProba: objective-specific link function" $ do
|
||||
it "binary logistic applies sigmoid with the ensemble's scale" $ do
|
||||
let ens = mkSingleFeatureEnsemble ObjectiveBinaryLogistic 1.0 False [makeLeafTree 0.0]
|
||||
predictProba ens (singletonFv 0.0) `shouldBe` 0.5
|
||||
|
||||
it "binary logistic with sigmoidScale=0.5 applies the scale" $ do
|
||||
let ens = mkSingleFeatureEnsemble ObjectiveBinaryLogistic 0.5 False [makeLeafTree 2.0]
|
||||
predictProba ens (singletonFv 0.0) `shouldBe` (1.0 / (1.0 + exp (-1.0)))
|
||||
|
||||
it "regression returns the score directly (no sigmoid)" $ do
|
||||
let ens = mkSingleFeatureEnsemble ObjectiveRegression 1.0 False [makeLeafTree 7.5]
|
||||
predictProba ens (singletonFv 0.0) `shouldBe` 7.5
|
||||
|
||||
describe "kZeroThreshold matches LightGBM" $
|
||||
it "is exactly 1e-35" $
|
||||
kZeroThreshold `shouldBe` 1.0e-35
|
||||
|
||||
describe "end-to-end against the tiny LightGBM v4 fixture" $ do
|
||||
case parseEnsemble tinyBytes of
|
||||
Left err -> it "parses tinyBytes" $ expectationFailure (show err)
|
||||
Right ens -> do
|
||||
it "feature vector [0, 0] (cat_feat=0 -> left, num_feat=0 -> left) hits leaf 0 (0.3)" $
|
||||
predictRaw ens (VU.fromList [0.0, 0.0]) `shouldBe` 0.3
|
||||
|
||||
it "feature vector [10, 1] (cat_feat=1 -> left, num_feat=10 -> right) hits leaf 1 (-0.2)" $
|
||||
predictRaw ens (VU.fromList [10.0, 1.0]) `shouldBe` (-0.2)
|
||||
|
||||
it "feature vector [0, 2] (cat_feat=2 -> right) hits leaf 2 (-0.4)" $
|
||||
predictRaw ens (VU.fromList [0.0, 2.0]) `shouldBe` (-0.4)
|
||||
|
||||
it "predictProba on tinyBytes feeds the sum through binary sigmoid scale=1" $
|
||||
predictProba ens (VU.fromList [0.0, 0.0])
|
||||
`shouldBe` (1.0 / (1.0 + exp (-0.3)))
|
||||
|
||||
isPlatt :: Calibrator -> Bool
|
||||
isPlatt (PlattCalibrator _ _) = True
|
||||
isPlatt _ = False
|
||||
|
||||
isIsotonic :: Calibrator -> Bool
|
||||
isIsotonic (IsotonicCalibrator _) = True
|
||||
isIsotonic _ = False
|
||||
|
||||
mlCalibrationSpec :: Spec
|
||||
mlCalibrationSpec = describe "ML.Calibration" $ do
|
||||
describe "NoCalibrator" $
|
||||
it "is identity for any input" $ do
|
||||
calibrate NoCalibrator 0.0 `shouldBe` 0.0
|
||||
calibrate NoCalibrator 0.5 `shouldBe` 0.5
|
||||
calibrate NoCalibrator 1.0 `shouldBe` 1.0
|
||||
calibrate NoCalibrator (-3.7) `shouldBe` (-3.7)
|
||||
|
||||
describe "PlattCalibrator basic shape" $ do
|
||||
it "(a=0, b=0) yields constant 0.5 regardless of p" $ do
|
||||
calibrate (PlattCalibrator 0.0 0.0) 0.3 `shouldBe` 0.5
|
||||
calibrate (PlattCalibrator 0.0 0.0) 1000.0 `shouldBe` 0.5
|
||||
|
||||
it "negative a produces output increasing in p" $ do
|
||||
let cal = PlattCalibrator (-2.0) 1.0
|
||||
calibrate cal 0.0 `shouldSatisfy` (< calibrate cal 1.0)
|
||||
|
||||
it "positive (a*p + b) saturates near 0 for large p" $
|
||||
calibrate (PlattCalibrator 1.0 0.0) 1000.0 `shouldBe` 0.0
|
||||
|
||||
it "negative (a*p + b) saturates near 1 for large p" $
|
||||
calibrate (PlattCalibrator (-1.0) 0.0) 1000.0 `shouldBe` 1.0
|
||||
|
||||
describe "fitPlatt edge cases" $ do
|
||||
it "returns NoCalibrator for empty input" $
|
||||
fitPlatt VU.empty `shouldBe` NoCalibrator
|
||||
|
||||
it "returns NoCalibrator for single sample" $
|
||||
fitPlatt (VU.singleton (0.5, True)) `shouldBe` NoCalibrator
|
||||
|
||||
it "returns PlattCalibrator for >=2 samples" $
|
||||
fitPlatt (VU.fromList [(0.1, False), (0.9, True)])
|
||||
`shouldSatisfy` isPlatt
|
||||
|
||||
describe "fitPlatt convergence on logistic-like data" $ do
|
||||
let negativeExamples = [(fromIntegral i / 100.0, False) | i <- [0 :: Int .. 49]]
|
||||
positiveExamples = [(fromIntegral i / 100.0, True) | i <- [50 :: Int .. 99]]
|
||||
samples = VU.fromList (negativeExamples ++ positiveExamples)
|
||||
cal = fitPlatt samples
|
||||
|
||||
it "fit recovers a < 0 (output increases with p)" $
|
||||
case cal of
|
||||
PlattCalibrator a _ -> a `shouldSatisfy` (< 0.0)
|
||||
_ -> expectationFailure "expected PlattCalibrator"
|
||||
|
||||
it "calibrated output at low p is less than at high p" $
|
||||
calibrate cal 0.1 `shouldSatisfy` (< calibrate cal 0.9)
|
||||
|
||||
it "calibrated output stays in (0, 1)" $ do
|
||||
let mid = calibrate cal 0.5
|
||||
mid `shouldSatisfy` (> 0.0)
|
||||
mid `shouldSatisfy` (< 1.0)
|
||||
|
||||
describe "fitIsotonic edge cases" $ do
|
||||
it "returns NoCalibrator for empty input" $
|
||||
fitIsotonic VU.empty `shouldBe` NoCalibrator
|
||||
|
||||
it "returns NoCalibrator for single sample" $
|
||||
fitIsotonic (VU.singleton (0.5, True)) `shouldBe` NoCalibrator
|
||||
|
||||
it "returns IsotonicCalibrator for >=2 samples" $
|
||||
fitIsotonic (VU.fromList [(0.1, False), (0.9, True)])
|
||||
`shouldSatisfy` isIsotonic
|
||||
|
||||
describe "fitIsotonic on already-monotone data" $ do
|
||||
let samples = VU.fromList
|
||||
[(0.1, False), (0.3, False), (0.6, True), (0.9, True)]
|
||||
cal = fitIsotonic samples
|
||||
|
||||
it "low raw clamps to 0.0" $
|
||||
calibrate cal 0.0 `shouldBe` 0.0
|
||||
|
||||
it "high raw clamps to 1.0" $
|
||||
calibrate cal 1.0 `shouldBe` 1.0
|
||||
|
||||
it "calibrated values are monotone non-decreasing" $
|
||||
case cal of
|
||||
IsotonicCalibrator bp ->
|
||||
let cals = VU.toList (VU.map snd bp)
|
||||
in all (uncurry (<=)) (zip cals (drop 1 cals)) `shouldBe` True
|
||||
_ -> expectationFailure "expected IsotonicCalibrator"
|
||||
|
||||
describe "fitIsotonic corrects non-monotone data" $ do
|
||||
let samples = VU.fromList
|
||||
[(0.1, False), (0.4, True), (0.5, False), (0.9, True)]
|
||||
cal = fitIsotonic samples
|
||||
|
||||
it "produces 3 breakpoints (one PAV merge)" $
|
||||
case cal of
|
||||
IsotonicCalibrator bp -> VU.length bp `shouldBe` 3
|
||||
_ -> expectationFailure "expected IsotonicCalibrator"
|
||||
|
||||
it "calibrated values are monotone non-decreasing" $
|
||||
case cal of
|
||||
IsotonicCalibrator bp ->
|
||||
let cals = VU.toList (VU.map snd bp)
|
||||
in all (uncurry (<=)) (zip cals (drop 1 cals)) `shouldBe` True
|
||||
_ -> expectationFailure "expected IsotonicCalibrator"
|
||||
|
||||
describe "fitIsotonic ties" $ do
|
||||
let samples = VU.fromList [(0.5, True), (0.5, False)]
|
||||
cal = fitIsotonic samples
|
||||
|
||||
it "merges identical raw values into one breakpoint" $
|
||||
case cal of
|
||||
IsotonicCalibrator bp -> VU.length bp `shouldBe` 1
|
||||
_ -> expectationFailure "expected IsotonicCalibrator"
|
||||
|
||||
it "merged breakpoint has averaged label" $
|
||||
calibrate cal 0.5 `shouldBe` 0.5
|
||||
|
||||
describe "fitIsotonic with all-same labels" $ do
|
||||
it "all True calibrates to 1.0 across the range" $ do
|
||||
let cal = fitIsotonic (VU.fromList [(0.1, True), (0.5, True), (0.9, True)])
|
||||
calibrate cal 0.5 `shouldBe` 1.0
|
||||
|
||||
it "all False calibrates to 0.0 across the range" $ do
|
||||
let cal = fitIsotonic (VU.fromList [(0.1, False), (0.5, False), (0.9, False)])
|
||||
calibrate cal 0.5 `shouldBe` 0.0
|
||||
|
||||
describe "isotonic lookup behavior" $ do
|
||||
let cal = IsotonicCalibrator
|
||||
(VU.fromList [(0.25, 0.0), (0.5, 0.5), (0.75, 1.0)])
|
||||
|
||||
it "clamps below first breakpoint" $
|
||||
calibrate cal 0.0 `shouldBe` 0.0
|
||||
|
||||
it "clamps above last breakpoint" $
|
||||
calibrate cal 1.5 `shouldBe` 1.0
|
||||
|
||||
it "returns exact value at a breakpoint" $
|
||||
calibrate cal 0.5 `shouldBe` 0.5
|
||||
|
||||
it "linearly interpolates between breakpoints" $ do
|
||||
let bp = VU.fromList [(0.0, 0.25), (1.0, 0.75)]
|
||||
calibrate (IsotonicCalibrator bp) 0.5 `shouldBe` 0.5
|
||||
|
||||
it "empty breakpoints pass through" $
|
||||
calibrate (IsotonicCalibrator VU.empty) 0.42 `shouldBe` 0.42
|
||||
|
||||
shouldBeApprox :: Double -> Double -> Expectation
|
||||
shouldBeApprox actual expected =
|
||||
abs (actual - expected) `shouldSatisfy` (< 1.0e-9)
|
||||
|
||||
singleSplitTree :: Int -> Double -> Int -> Int -> ITree
|
||||
singleSplitTree featIdx thr leftSize rightSize =
|
||||
ITreeSplit featIdx thr (ITreeLeaf leftSize) (ITreeLeaf rightSize)
|
||||
|
||||
mlIForestSpec :: Spec
|
||||
mlIForestSpec = describe "ML.IForest" $ do
|
||||
describe "harmonicNumber" $ do
|
||||
it "H(0) is 0" $
|
||||
harmonicNumber 0 `shouldBe` 0.0
|
||||
|
||||
it "H(1) is exactly 1.0" $
|
||||
harmonicNumber 1 `shouldBe` 1.0
|
||||
|
||||
it "H(2) is exactly 1.5" $
|
||||
harmonicNumber 2 `shouldBe` 1.5
|
||||
|
||||
it "H(3) is 1 + 1/2 + 1/3" $
|
||||
harmonicNumber 3 `shouldBeApprox` (1.0 + 0.5 + 1.0 / 3.0)
|
||||
|
||||
it "H(1000) matches the asymptotic ln(n)+gamma+1/(2n) within 1e-6" $ do
|
||||
let expected = log 1000.0 + eulerMascheroni + 1.0 / (2.0 * 1000.0)
|
||||
abs (harmonicNumber 1000 - expected) `shouldSatisfy` (< 1.0e-6)
|
||||
|
||||
it "rejects negative input by returning 0" $
|
||||
harmonicNumber (-5) `shouldBe` 0.0
|
||||
|
||||
describe "normalizationConstant c(n)" $ do
|
||||
it "c(0) is 0 (degenerate)" $
|
||||
normalizationConstant 0 `shouldBe` 0.0
|
||||
|
||||
it "c(1) is 0 (degenerate)" $
|
||||
normalizationConstant 1 `shouldBe` 0.0
|
||||
|
||||
it "c(2) is 2*H(1) - 2*1/2 = 1.0" $
|
||||
normalizationConstant 2 `shouldBe` 1.0
|
||||
|
||||
it "c(256) matches Liu et al. 2008 reference value" $
|
||||
normalizationConstant 256
|
||||
`shouldBeApprox`
|
||||
(2.0 * harmonicNumber 255 - 2.0 * 255.0 / 256.0)
|
||||
|
||||
describe "pathLength on a single split" $ do
|
||||
let tree = singleSplitTree 0 0.5 1 1
|
||||
fvLeft = VU.singleton 0.3
|
||||
fvRight = VU.singleton 0.7
|
||||
|
||||
it "feature value <= threshold goes left, depth increments to 1" $
|
||||
pathLength tree fvLeft 0
|
||||
`shouldBe` (1.0 + normalizationConstant 1)
|
||||
|
||||
it "feature value > threshold goes right, depth increments to 1" $
|
||||
pathLength tree fvRight 0
|
||||
`shouldBe` (1.0 + normalizationConstant 1)
|
||||
|
||||
it "leaf adds c(leafSize) to currentDepth" $ do
|
||||
let leaf10 = ITreeLeaf 10
|
||||
pathLength leaf10 (VU.singleton 0.0) 5
|
||||
`shouldBe` (5.0 + normalizationConstant 10)
|
||||
|
||||
describe "pathLength on a deeper tree" $ do
|
||||
let tree = ITreeSplit 0 0.5
|
||||
(ITreeSplit 1 0.5
|
||||
(ITreeLeaf 1) (ITreeLeaf 1))
|
||||
(ITreeLeaf 2)
|
||||
fv00 = VU.fromList [0.3, 0.3]
|
||||
fv01 = VU.fromList [0.3, 0.7]
|
||||
fv1 = VU.fromList [0.7, 0.0]
|
||||
|
||||
it "fv00 traverses two splits and lands on left-left leaf" $
|
||||
pathLength tree fv00 0
|
||||
`shouldBe` (2.0 + normalizationConstant 1)
|
||||
|
||||
it "fv01 traverses two splits and lands on left-right leaf" $
|
||||
pathLength tree fv01 0
|
||||
`shouldBe` (2.0 + normalizationConstant 1)
|
||||
|
||||
it "fv1 traverses one split and lands on right leaf with size 2" $
|
||||
pathLength tree fv1 0
|
||||
`shouldBe` (1.0 + normalizationConstant 2)
|
||||
|
||||
describe "scoreIForest edge cases" $ do
|
||||
it "empty forest returns 0.0" $
|
||||
scoreIForest (IForest V.empty 256) (VU.singleton 0.0) `shouldBe` 0.0
|
||||
|
||||
it "subsample size 0 returns 0.0" $
|
||||
scoreIForest (IForest (V.singleton (ITreeLeaf 1)) 0) (VU.singleton 0.0)
|
||||
`shouldBe` 0.0
|
||||
|
||||
it "subsample size 1 returns 0.0 (c(1) is 0)" $
|
||||
scoreIForest (IForest (V.singleton (ITreeLeaf 1)) 1) (VU.singleton 0.0)
|
||||
`shouldBe` 0.0
|
||||
|
||||
describe "scoreIForest produces values in (0, 1]" $ do
|
||||
let forest = IForest
|
||||
(V.fromList
|
||||
[ singleSplitTree 0 0.5 1 1
|
||||
, singleSplitTree 0 0.7 1 1
|
||||
, singleSplitTree 0 0.3 1 1
|
||||
])
|
||||
4
|
||||
|
||||
it "anomalous input produces a score" $ do
|
||||
let s = scoreIForest forest (VU.singleton 0.0)
|
||||
s `shouldSatisfy` (> 0.0)
|
||||
s `shouldSatisfy` (<= 1.0)
|
||||
|
||||
describe "scoreIForest: shorter average path = higher anomaly score" $ do
|
||||
let shallow = IForest
|
||||
(V.singleton (ITreeSplit 0 0.5 (ITreeLeaf 1) (ITreeLeaf 1)))
|
||||
16
|
||||
deep = IForest
|
||||
(V.singleton
|
||||
(ITreeSplit 0 0.5
|
||||
(ITreeSplit 1 0.5
|
||||
(ITreeSplit 2 0.5 (ITreeLeaf 1) (ITreeLeaf 1))
|
||||
(ITreeLeaf 1))
|
||||
(ITreeLeaf 1)))
|
||||
16
|
||||
fv = VU.fromList [0.3, 0.3, 0.3]
|
||||
|
||||
it "shallow tree (depth 1) yields higher score than deep tree (depth 3)" $
|
||||
scoreIForest shallow fv `shouldSatisfy` (> scoreIForest deep fv)
|
||||
|
||||
describe "default constants from Liu et al. 2008" $ do
|
||||
it "default tree count is 100" $
|
||||
defaultIForestNumTrees `shouldBe` 100
|
||||
|
||||
it "default subsample size is 256" $
|
||||
defaultIForestSubsampleSize `shouldBe` 256
|
||||
|
||||
it "Euler-Mascheroni constant matches the standard 16-digit value" $
|
||||
eulerMascheroni `shouldBe` 0.5772156649015329
|
||||
|
||||
mlEngineSpec :: Spec
|
||||
mlEngineSpec = describe "ML.Engine" $ do
|
||||
let humanLeafEnsemble = binaryEnsemble [makeLeafTree (-5.0)]
|
||||
botLeafEnsemble = binaryEnsemble [makeLeafTree 5.0]
|
||||
midLeafEnsemble = binaryEnsemble [makeLeafTree 0.0]
|
||||
|
||||
cfg = defaultEngineConfig
|
||||
eng e cal mIf = makeEngine e cal mIf cfg
|
||||
|
||||
lowAnomalyForest = IForest (V.singleton (ITreeLeaf 256)) 256
|
||||
highAnomalyForest = IForest (V.singleton (ITreeLeaf 1)) 256
|
||||
|
||||
describe "defaultEngineConfig" $ do
|
||||
it "uses sensible defaults" $ do
|
||||
ecHumanThreshold cfg `shouldBe` 0.3
|
||||
ecBotThreshold cfg `shouldBe` 0.7
|
||||
ecIForestEscalation cfg `shouldBe` 0.6
|
||||
ecChallengeOnAmbiguous cfg `shouldBe` True
|
||||
|
||||
describe "decision boundaries with NoCalibrator and no IForest" $ do
|
||||
it "very negative leaf (proba ~ 0.0067) routes to DecisionHuman" $
|
||||
runEngineDecision (eng humanLeafEnsemble NoCalibrator Nothing) (singletonFv 0.0)
|
||||
`shouldBe` DecisionHuman
|
||||
|
||||
it "very positive leaf (proba ~ 0.993) routes to DecisionBot" $
|
||||
runEngineDecision (eng botLeafEnsemble NoCalibrator Nothing) (singletonFv 0.0)
|
||||
`shouldBe` DecisionBot
|
||||
|
||||
it "midpoint leaf (proba = 0.5) lands in ambiguous band -> DecisionChallenge" $
|
||||
runEngineDecision (eng midLeafEnsemble NoCalibrator Nothing) (singletonFv 0.0)
|
||||
`shouldBe` DecisionChallenge
|
||||
|
||||
describe "ambiguous band escalation via IForest" $ do
|
||||
it "low-anomaly IForest (score 0.5 < 0.6 escalation) keeps DecisionChallenge" $
|
||||
runEngineDecision
|
||||
(eng midLeafEnsemble NoCalibrator (Just lowAnomalyForest))
|
||||
(singletonFv 0.0)
|
||||
`shouldBe` DecisionChallenge
|
||||
|
||||
it "high-anomaly IForest (score 1.0 >= 0.6 escalation) escalates to DecisionBot" $
|
||||
runEngineDecision
|
||||
(eng midLeafEnsemble NoCalibrator (Just highAnomalyForest))
|
||||
(singletonFv 0.0)
|
||||
`shouldBe` DecisionBot
|
||||
|
||||
it "DecisionDetails records the IF score when present" $
|
||||
ddIForestScore
|
||||
(runEngine (eng midLeafEnsemble NoCalibrator (Just highAnomalyForest))
|
||||
(singletonFv 0.0))
|
||||
`shouldBe` Just 1.0
|
||||
|
||||
it "DecisionDetails records Nothing for IF score when absent" $
|
||||
ddIForestScore
|
||||
(runEngine (eng midLeafEnsemble NoCalibrator Nothing) (singletonFv 0.0))
|
||||
`shouldBe` Nothing
|
||||
|
||||
describe "ambiguous band with challenges disabled" $ do
|
||||
let noChallengeCfg = cfg { ecChallengeOnAmbiguous = False }
|
||||
engNoChal e cal mIf = makeEngine e cal mIf noChallengeCfg
|
||||
|
||||
it "ambiguous calibrated + no IForest falls through to DecisionHuman" $
|
||||
runEngineDecision
|
||||
(engNoChal midLeafEnsemble NoCalibrator Nothing)
|
||||
(singletonFv 0.0)
|
||||
`shouldBe` DecisionHuman
|
||||
|
||||
it "ambiguous calibrated + low-anomaly IForest still falls through to DecisionHuman" $
|
||||
runEngineDecision
|
||||
(engNoChal midLeafEnsemble NoCalibrator (Just lowAnomalyForest))
|
||||
(singletonFv 0.0)
|
||||
`shouldBe` DecisionHuman
|
||||
|
||||
it "ambiguous calibrated + high-anomaly IForest escalates to DecisionBot" $
|
||||
runEngineDecision
|
||||
(engNoChal midLeafEnsemble NoCalibrator (Just highAnomalyForest))
|
||||
(singletonFv 0.0)
|
||||
`shouldBe` DecisionBot
|
||||
|
||||
describe "calibrator changes the decision threshold" $ do
|
||||
let almostBotEnsemble = binaryEnsemble [makeLeafTree 1.5]
|
||||
rawProba = 1.0 / (1.0 + exp (-1.5))
|
||||
|
||||
it "without calibration, raw proba in (0.7, 0.99) -> DecisionBot" $ do
|
||||
let result = runEngine (eng almostBotEnsemble NoCalibrator Nothing) (singletonFv 0.0)
|
||||
ddRawProba result `shouldBe` rawProba
|
||||
ddCalibrated result `shouldBe` rawProba
|
||||
ddDecision result `shouldBe` DecisionBot
|
||||
|
||||
it "Platt with strongly negative a*p+b pulls calibrated below human threshold" $ do
|
||||
let cal = PlattCalibrator (-100.0) 100.0
|
||||
result = runEngine (eng almostBotEnsemble cal Nothing) (singletonFv 0.0)
|
||||
ddCalibrated result `shouldSatisfy` (< 0.3)
|
||||
ddDecision result `shouldBe` DecisionHuman
|
||||
|
||||
describe "DecisionDetails mirrors all four fields" $ do
|
||||
let result = runEngine (eng midLeafEnsemble NoCalibrator Nothing) (singletonFv 0.0)
|
||||
it "ddDecision reflects the routing" $
|
||||
ddDecision result `shouldBe` DecisionChallenge
|
||||
it "ddRawProba is predictProba output (0.5 for leaf=0)" $
|
||||
ddRawProba result `shouldBe` 0.5
|
||||
it "ddCalibrated equals ddRawProba under NoCalibrator" $
|
||||
ddCalibrated result `shouldBe` 0.5
|
||||
it "ddIForestScore is Nothing when no IForest configured" $
|
||||
ddIForestScore result `shouldBe` Nothing
|
||||
|
||||
mlEngineWithLeaf :: Double -> Engine
|
||||
mlEngineWithLeaf leafValue =
|
||||
let ens = Ensemble
|
||||
{ ensembleVersion = currentEnsembleVersion
|
||||
, ensembleFeatureCount = featureVectorLength
|
||||
, ensembleObjective = ObjectiveBinaryLogistic
|
||||
, ensembleBaseScore = 0.0
|
||||
, ensembleSigmoidScale = defaultSigmoidScale
|
||||
, ensembleAverageOutput = False
|
||||
, ensembleTrees = V.singleton (makeLeafTree leafValue)
|
||||
}
|
||||
in makeEngine ens NoCalibrator Nothing defaultEngineConfig
|
||||
|
||||
mlMiddlewareSpec :: Spec
|
||||
mlMiddlewareSpec = describe "ML.Middleware" $ do
|
||||
let humanEng = mlEngineWithLeaf (-5.0)
|
||||
botEng = mlEngineWithLeaf 5.0
|
||||
challengeEng = mlEngineWithLeaf 0.0
|
||||
ctx = emptyFeatureContext
|
||||
humanCfg = defaultMLMiddlewareConfig humanEng ctx
|
||||
botCfg = defaultMLMiddlewareConfig botEng ctx
|
||||
challengeCfg = defaultMLMiddlewareConfig challengeEng ctx
|
||||
buildApp cfg = mlBotDetectionMiddleware cfg okApp
|
||||
|
||||
describe "DecisionHuman → pass through with ML signal headers" $ do
|
||||
it "returns 200 from inner application" $ do
|
||||
resp <- runSession (request Network.Wai.Test.defaultRequest) (buildApp humanCfg)
|
||||
simpleStatus resp `shouldBe` status200
|
||||
|
||||
it "attaches X-Aenebris-ML-Decision: human" $ do
|
||||
resp <- runSession (request Network.Wai.Test.defaultRequest) (buildApp humanCfg)
|
||||
lookup decisionResponseHeader (simpleHeaders resp)
|
||||
`shouldBe` Just (decisionToWireText DecisionHuman)
|
||||
|
||||
it "attaches X-Aenebris-ML-Score header" $ do
|
||||
resp <- runSession (request Network.Wai.Test.defaultRequest) (buildApp humanCfg)
|
||||
lookup scoreResponseHeader (simpleHeaders resp) `shouldSatisfy` isJust
|
||||
|
||||
it "omits ML signal headers when mmcAttachHeaders=False" $ do
|
||||
let cfg = humanCfg { mmcAttachHeaders = False }
|
||||
app = buildApp cfg
|
||||
resp <- runSession (request Network.Wai.Test.defaultRequest) app
|
||||
lookup decisionResponseHeader (simpleHeaders resp) `shouldBe` Nothing
|
||||
lookup scoreResponseHeader (simpleHeaders resp) `shouldBe` Nothing
|
||||
|
||||
describe "DecisionBot → 403 block" $ do
|
||||
it "returns 403" $ do
|
||||
resp <- runSession (request Network.Wai.Test.defaultRequest) (buildApp botCfg)
|
||||
simpleStatus resp `shouldBe` status403
|
||||
|
||||
it "attaches X-Aenebris-ML-Decision: bot" $ do
|
||||
resp <- runSession (request Network.Wai.Test.defaultRequest) (buildApp botCfg)
|
||||
lookup decisionResponseHeader (simpleHeaders resp)
|
||||
`shouldBe` Just (decisionToWireText DecisionBot)
|
||||
|
||||
it "responds with text/plain content type" $ do
|
||||
resp <- runSession (request Network.Wai.Test.defaultRequest) (buildApp botCfg)
|
||||
lookup "Content-Type" (simpleHeaders resp)
|
||||
`shouldSatisfy` maybe False (BS.isPrefixOf "text/plain")
|
||||
|
||||
describe "DecisionChallenge → 403 challenge page" $ do
|
||||
it "returns 403" $ do
|
||||
resp <- runSession (request Network.Wai.Test.defaultRequest) (buildApp challengeCfg)
|
||||
simpleStatus resp `shouldBe` status403
|
||||
|
||||
it "attaches X-Aenebris-ML-Decision: challenge" $ do
|
||||
resp <- runSession (request Network.Wai.Test.defaultRequest) (buildApp challengeCfg)
|
||||
lookup decisionResponseHeader (simpleHeaders resp)
|
||||
`shouldBe` Just (decisionToWireText DecisionChallenge)
|
||||
|
||||
it "responds with text/html content type" $ do
|
||||
resp <- runSession (request Network.Wai.Test.defaultRequest) (buildApp challengeCfg)
|
||||
lookup "Content-Type" (simpleHeaders resp)
|
||||
`shouldSatisfy` maybe False (BS.isPrefixOf "text/html")
|
||||
|
||||
describe "custom response builders override defaults" $
|
||||
it "custom mmcBotResponse is used instead of the default 403" $ do
|
||||
let customBotResp _req _details =
|
||||
responseLBS status429
|
||||
[("Content-Type", "text/plain")]
|
||||
"custom bot response"
|
||||
cfg = botCfg { mmcBotResponse = customBotResp }
|
||||
resp <- runSession (request Network.Wai.Test.defaultRequest) (buildApp cfg)
|
||||
simpleStatus resp `shouldBe` status429
|
||||
|
||||
describe "logging callback fires" $
|
||||
it "mmcLogDetails callback is invoked once per request" $ do
|
||||
counter <- newTVarIO (0 :: Int)
|
||||
let logCallback _req _details =
|
||||
atomically (modifyTVar' counter (+ 1))
|
||||
cfg = humanCfg { mmcLogDetails = Just logCallback }
|
||||
_ <- runSession (request Network.Wai.Test.defaultRequest) (buildApp cfg)
|
||||
readTVarIO counter `shouldReturn` 1
|
||||
|
||||
headersOnlyRequest :: [(BS.ByteString, BS.ByteString)] -> Request
|
||||
headersOnlyRequest hs =
|
||||
Network.Wai.Test.defaultRequest
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
# ©AngelaMos | 2026
|
||||
# credential-enumeration.nimble
|
||||
# credenum.nimble
|
||||
|
||||
version = "0.1.0"
|
||||
author = "AngelaMos"
|
||||
|
|
@ -83,7 +83,7 @@ header "Building from source"
|
|||
SCRIPT_DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)"
|
||||
SRC_DIR="$SCRIPT_DIR"
|
||||
|
||||
if [[ ! -f "$SRC_DIR/credential-enumeration.nimble" ]]; then
|
||||
if [[ ! -f "$SRC_DIR/credenum.nimble" ]]; then
|
||||
fail "Run install.sh from the project root directory."
|
||||
fi
|
||||
|
||||
|
|
|
|||
|
|
@ -122,7 +122,7 @@ credential-enumeration/
|
|||
│ ├── validate.sh # Integration test: runs scanner, checks all 7 categories
|
||||
│ └── planted/ # Credential fixtures (SSH keys, AWS creds, tokens, etc)
|
||||
├── config.nims # Nim compiler switches (ORC, musl, zigcc, cross-compile)
|
||||
├── credential-enumeration.nimble # Package manifest
|
||||
├── credenum.nimble # Package manifest
|
||||
├── Justfile # Build, test, release, format commands
|
||||
└── install.sh # One-step install: compile + PATH setup
|
||||
```
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ FROM nimlang/nim:2.2.0-alpine AS builder
|
|||
WORKDIR /build
|
||||
COPY src/ src/
|
||||
COPY config.nims .
|
||||
COPY credential-enumeration.nimble .
|
||||
COPY credenum.nimble .
|
||||
|
||||
RUN nim c -d:release --opt:size --passL:-static -o:/build/credenum src/harvester.nim && \
|
||||
strip -s /build/credenum
|
||||
|
|
|
|||
Loading…
Reference in New Issue