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.Features
|
||||||
, Aenebris.ML.Model
|
, Aenebris.ML.Model
|
||||||
, Aenebris.ML.Loader
|
, Aenebris.ML.Loader
|
||||||
|
, Aenebris.ML.Inference
|
||||||
|
, Aenebris.ML.Calibration
|
||||||
|
, Aenebris.ML.IForest
|
||||||
|
, Aenebris.ML.Engine
|
||||||
|
, Aenebris.ML.Middleware
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
build-depends: base >= 4.7 && < 5
|
build-depends: base >= 4.7 && < 5
|
||||||
, warp >= 3.3
|
, 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
|
, uaSecChConsistency
|
||||||
, userAgentLengthCap
|
, 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
|
import Aenebris.ML.Loader
|
||||||
( ParseError(..)
|
( ParseError(..)
|
||||||
, parseEnsemble
|
, parseEnsemble
|
||||||
|
|
@ -217,6 +260,7 @@ import Aenebris.WAF.Rule
|
||||||
|
|
||||||
import Control.Concurrent.STM
|
import Control.Concurrent.STM
|
||||||
( atomically
|
( atomically
|
||||||
|
, modifyTVar'
|
||||||
, newTVarIO
|
, newTVarIO
|
||||||
, readTVarIO
|
, readTVarIO
|
||||||
)
|
)
|
||||||
|
|
@ -271,7 +315,8 @@ import Network.Wai.Test
|
||||||
, simpleStatus
|
, simpleStatus
|
||||||
)
|
)
|
||||||
import Test.Hspec
|
import Test.Hspec
|
||||||
( Spec
|
( Expectation
|
||||||
|
, Spec
|
||||||
, describe
|
, describe
|
||||||
, expectationFailure
|
, expectationFailure
|
||||||
, hspec
|
, hspec
|
||||||
|
|
@ -333,6 +378,11 @@ main = hspec $ do
|
||||||
mlFeaturesSpec
|
mlFeaturesSpec
|
||||||
mlModelSpec
|
mlModelSpec
|
||||||
mlLoaderSpec
|
mlLoaderSpec
|
||||||
|
mlInferenceSpec
|
||||||
|
mlCalibrationSpec
|
||||||
|
mlIForestSpec
|
||||||
|
mlEngineSpec
|
||||||
|
mlMiddlewareSpec
|
||||||
|
|
||||||
configSpec :: Spec
|
configSpec :: Spec
|
||||||
configSpec = describe "Config" $ do
|
configSpec = describe "Config" $ do
|
||||||
|
|
@ -2042,6 +2092,689 @@ mlLoaderSpec = describe "ML.Loader" $ do
|
||||||
Left err -> peKey err `shouldBe` "version"
|
Left err -> peKey err `shouldBe` "version"
|
||||||
Right _ -> expectationFailure "expected Left"
|
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 :: [(BS.ByteString, BS.ByteString)] -> Request
|
||||||
headersOnlyRequest hs =
|
headersOnlyRequest hs =
|
||||||
Network.Wai.Test.defaultRequest
|
Network.Wai.Test.defaultRequest
|
||||||
|
|
|
||||||
|
|
@ -1,5 +1,5 @@
|
||||||
# ©AngelaMos | 2026
|
# ©AngelaMos | 2026
|
||||||
# credential-enumeration.nimble
|
# credenum.nimble
|
||||||
|
|
||||||
version = "0.1.0"
|
version = "0.1.0"
|
||||||
author = "AngelaMos"
|
author = "AngelaMos"
|
||||||
|
|
@ -83,7 +83,7 @@ header "Building from source"
|
||||||
SCRIPT_DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)"
|
SCRIPT_DIR="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)"
|
||||||
SRC_DIR="$SCRIPT_DIR"
|
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."
|
fail "Run install.sh from the project root directory."
|
||||||
fi
|
fi
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -122,7 +122,7 @@ credential-enumeration/
|
||||||
│ ├── validate.sh # Integration test: runs scanner, checks all 7 categories
|
│ ├── validate.sh # Integration test: runs scanner, checks all 7 categories
|
||||||
│ └── planted/ # Credential fixtures (SSH keys, AWS creds, tokens, etc)
|
│ └── planted/ # Credential fixtures (SSH keys, AWS creds, tokens, etc)
|
||||||
├── config.nims # Nim compiler switches (ORC, musl, zigcc, cross-compile)
|
├── 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
|
├── Justfile # Build, test, release, format commands
|
||||||
└── install.sh # One-step install: compile + PATH setup
|
└── install.sh # One-step install: compile + PATH setup
|
||||||
```
|
```
|
||||||
|
|
|
||||||
|
|
@ -6,7 +6,7 @@ FROM nimlang/nim:2.2.0-alpine AS builder
|
||||||
WORKDIR /build
|
WORKDIR /build
|
||||||
COPY src/ src/
|
COPY src/ src/
|
||||||
COPY config.nims .
|
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 && \
|
RUN nim c -d:release --opt:size --passL:-static -o:/build/credenum src/harvester.nim && \
|
||||||
strip -s /build/credenum
|
strip -s /build/credenum
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue