diff --git a/conformance/TestBinary.hs b/conformance/TestBinary.hs new file mode 100644 --- /dev/null +++ b/conformance/TestBinary.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Conformance binary: generates binary byte strings and writes metrics. +module Main (main) where + +import qualified Data.Aeson as Aeson +import Data.Aeson (Value (..)) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.Maybe (fromMaybe, listToMaybe) +import qualified Data.Map.Strict as Map +import Hegel +import System.Environment (getArgs) + +parseParams :: IO (Map.Map String Value) +parseParams = do + args <- getArgs + pure $ + fromMaybe Map.empty $ + Aeson.decode . LBS.pack =<< listToMaybe args + +getIntParam :: Map.Map String Value -> String -> Maybe Int +getIntParam m k = round <$> (getNumber =<< Map.lookup k m) + where + getNumber (Number n) = Just n + getNumber _ = Nothing + +main :: IO () +main = do + params <- parseParams + let minSize = getIntParam params "min_size" + let maxSize = getIntParam params "max_size" + testCases <- getTestCases + runHegelTest (\settings -> settings { settingsTestCases = testCases }) $ \tc -> do + b <- draw tc (binary def { rangeMin = minSize, rangeMax = maxSize }) + writeMetrics [("length", show (BS.length b))] diff --git a/conformance/TestBooleans.hs b/conformance/TestBooleans.hs new file mode 100644 --- /dev/null +++ b/conformance/TestBooleans.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Conformance binary: generates boolean values and writes metrics. +module Main (main) where + +import Hegel + +main :: IO () +main = do + testCases <- getTestCases + runHegelTest (\settings -> settings { settingsTestCases = testCases }) $ \tc -> do + b <- draw tc booleans + writeMetrics [("value", if b then "true" else "false")] diff --git a/conformance/TestFloats.hs b/conformance/TestFloats.hs new file mode 100644 --- /dev/null +++ b/conformance/TestFloats.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Conformance binary: generates float values and writes metrics. +module Main (main) where + +import qualified Data.Aeson as Aeson +import Data.Aeson (Value (..)) +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.Maybe (fromMaybe, listToMaybe) +import qualified Data.Map.Strict as Map +import Hegel +import System.Environment (getArgs) + +parseParams :: IO (Map.Map String Value) +parseParams = do + args <- getArgs + pure $ + fromMaybe Map.empty $ + Aeson.decode . LBS.pack =<< listToMaybe args + +getDoubleParam :: Map.Map String Value -> String -> Maybe Double +getDoubleParam m k = realToFrac <$> (getNumber =<< Map.lookup k m) + where + getNumber (Number n) = Just n + getNumber _ = Nothing + +getBoolParam :: Map.Map String Value -> String -> Maybe Bool +getBoolParam m k = getBool =<< Map.lookup k m + where + getBool (Bool b) = Just b + getBool _ = Nothing + +getBoolParamDefault :: Map.Map String Value -> String -> Bool -> Bool +getBoolParamDefault m k defaultValue = fromMaybe defaultValue (getBoolParam m k) + +-- | Format a float for JSON output. NaN becomes "null", +Inf becomes "1e308", +-- -Inf becomes "-1e308", otherwise show the number. +formatFloat :: Double -> String +formatFloat v + | isNaN v = "null" + | isInfinite v = if v > 0 then "1e308" else "-1e308" + | otherwise = show v + +boolStr :: Bool -> String +boolStr True = "true" +boolStr False = "false" + +main :: IO () +main = do + params <- parseParams + let minVal = getDoubleParam params "min_value" + let maxVal = getDoubleParam params "max_value" + let excludeMin = getBoolParamDefault params "exclude_min" False + let excludeMax = getBoolParamDefault params "exclude_max" False + let allowNan = getBoolParam params "allow_nan" + let allowInf = getBoolParam params "allow_infinity" + let opts = + def + { floatBounds = + RangeOpts + { rangeMin = minVal, + rangeMax = maxVal + }, + floatExcludeMin = excludeMin, + floatExcludeMax = excludeMax, + floatAllowNan = allowNan, + floatAllowInfinity = allowInf + } + testCases <- getTestCases + runHegelTest (\settings -> settings { settingsTestCases = testCases }) $ \tc -> do + v <- draw tc (floats opts) + writeMetrics + [ ("value", formatFloat v), + ("is_nan", boolStr (isNaN v)), + ("is_infinite", boolStr (isInfinite v)) + ] diff --git a/conformance/TestHashmaps.hs b/conformance/TestHashmaps.hs new file mode 100644 --- /dev/null +++ b/conformance/TestHashmaps.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Conformance binary: generates hash maps (dicts) and writes metrics. +module Main (main) where + +import qualified Data.Aeson as Aeson +import Data.Aeson (Value (..)) +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.Maybe (fromMaybe, listToMaybe) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import Hegel +import System.Environment (getArgs) + +parseParams :: IO (Map.Map String Value) +parseParams = do + args <- getArgs + pure $ + fromMaybe Map.empty $ + Aeson.decode . LBS.pack =<< listToMaybe args + +getIntParam :: Map.Map String Value -> String -> Maybe Int +getIntParam m k = round <$> (getNumber =<< Map.lookup k m) + where + getNumber (Number n) = Just n + getNumber _ = Nothing + +getIntParamDefault :: Map.Map String Value -> String -> Int -> Int +getIntParamDefault m k defaultValue = fromMaybe defaultValue (getIntParam m k) + +getTextParam :: Map.Map String Value -> String -> Maybe Text +getTextParam m k = getText =<< Map.lookup k m + where + getText (Aeson.String t) = Just t + getText _ = Nothing + +intOrNull :: Maybe Int -> String +intOrNull = maybe "null" show + +main :: IO () +main = do + params <- parseParams + let minSize = getIntParamDefault params "min_size" 0 + let maxSize = getIntParamDefault params "max_size" 10 + let keyType = fromMaybe "integer" (getTextParam params "key_type") + let minKey = getIntParamDefault params "min_key" (-1000) + let maxKey = getIntParamDefault params "max_key" 1000 + let minValBound = getIntParamDefault params "min_value" (-1000) + let maxValBound = getIntParamDefault params "max_value" 1000 + testCases <- getTestCases + if keyType == "string" + then runHegelTest (\settings -> settings { settingsTestCases = testCases }) $ \tc -> do + let keyGen = text def { rangeMin = Just 1, rangeMax = Just 10 } + let valGen = integers def { rangeMin = Just minValBound, rangeMax = Just maxValBound } + let mapGen = hashmaps keyGen valGen def { rangeMin = Just minSize, rangeMax = Just maxSize } + pairs <- draw tc mapGen + let len = length pairs + let vals = map snd pairs + let minVal = if null vals then Nothing else Just (minimum vals) + let maxVal = if null vals then Nothing else Just (maximum vals) + writeMetrics + [ ("size", show len), + ("min_key", "null"), + ("max_key", "null"), + ("min_value", intOrNull minVal), + ("max_value", intOrNull maxVal) + ] + else runHegelTest (\settings -> settings { settingsTestCases = testCases }) $ \tc -> do + let keyGen = integers def { rangeMin = Just minKey, rangeMax = Just maxKey } + let valGen = integers def { rangeMin = Just minValBound, rangeMax = Just maxValBound } + let mapGen = hashmaps keyGen valGen def { rangeMin = Just minSize, rangeMax = Just maxSize } + pairs <- draw tc mapGen + let len = length pairs + let keys = map fst pairs + let vals = map snd pairs + let minKeyResult = if null keys then Nothing else Just (minimum keys) + let maxKeyResult = if null keys then Nothing else Just (maximum keys) + let minValResult = if null vals then Nothing else Just (minimum vals) + let maxValResult = if null vals then Nothing else Just (maximum vals) + writeMetrics + [ ("size", show len), + ("min_key", intOrNull minKeyResult), + ("max_key", intOrNull maxKeyResult), + ("min_value", intOrNull minValResult), + ("max_value", intOrNull maxValResult) + ] diff --git a/conformance/TestIntegers.hs b/conformance/TestIntegers.hs new file mode 100644 --- /dev/null +++ b/conformance/TestIntegers.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Conformance binary: generates integer values and writes metrics. +module Main (main) where + +import qualified Data.Aeson as Aeson +import Data.Aeson (Value (..)) +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.Maybe (fromMaybe, listToMaybe) +import qualified Data.Map.Strict as Map +import Hegel +import System.Environment (getArgs) + +parseParams :: IO (Map.Map String Value) +parseParams = do + args <- getArgs + pure $ + fromMaybe Map.empty $ + Aeson.decode . LBS.pack =<< listToMaybe args + +getIntParam :: Map.Map String Value -> String -> Maybe Int +getIntParam m k = round <$> (getNumber =<< Map.lookup k m) + where + getNumber (Number n) = Just n + getNumber _ = Nothing + +main :: IO () +main = do + params <- parseParams + let minVal = getIntParam params "min_value" + let maxVal = getIntParam params "max_value" + testCases <- getTestCases + runHegelTest (\settings -> settings { settingsTestCases = testCases }) $ \tc -> do + n <- draw tc (integers def { rangeMin = minVal, rangeMax = maxVal }) + writeMetrics [("value", show n)] diff --git a/conformance/TestLists.hs b/conformance/TestLists.hs new file mode 100644 --- /dev/null +++ b/conformance/TestLists.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Conformance binary: generates lists of integers and writes metrics. +-- +-- Uses filtered elements (CompositeList path) so that new_collection and +-- collection_more commands are sent -- required for error-mode conformance +-- tests (stop_test_on_collection_more, stop_test_on_new_collection). +module Main (main) where + +import qualified Data.Aeson as Aeson +import Data.Aeson (Value (..)) +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.Maybe (fromMaybe, listToMaybe) +import qualified Data.Map.Strict as Map +import Hegel +import System.Environment (getArgs) + +parseParams :: IO (Map.Map String Value) +parseParams = do + args <- getArgs + pure $ + fromMaybe Map.empty $ + Aeson.decode . LBS.pack =<< listToMaybe args + +getIntParam :: Map.Map String Value -> String -> Maybe Int +getIntParam m k = round <$> (getNumber =<< Map.lookup k m) + where + getNumber (Number n) = Just n + getNumber _ = Nothing + +intOrNull :: Maybe Int -> String +intOrNull = maybe "null" show + +main :: IO () +main = do + params <- parseParams + let minSize = getIntParam params "min_size" + let maxSize = getIntParam params "max_size" + let minVal = getIntParam params "min_value" + let maxVal = getIntParam params "max_value" + testCases <- getTestCases + runHegelTest (\settings -> settings { settingsTestCases = testCases }) $ \tc -> do + -- Use gfilter (const True) to force the CompositeList path, which sends + -- new_collection and collection_more commands. This is required so that + -- the error-mode conformance tests (stop_test_on_collection_more, + -- stop_test_on_new_collection) work correctly. + let elemGen = gfilter (const True) (integers def { rangeMin = minVal, rangeMax = maxVal }) + let listGen = lists elemGen def { rangeMin = minSize, rangeMax = maxSize } + items <- draw tc listGen + let len = length items + let minElem = if null items then Nothing else Just (minimum items) + let maxElem = if null items then Nothing else Just (maximum items) + writeMetrics + [ ("size", show len), + ("min_element", intOrNull minElem), + ("max_element", intOrNull maxElem) + ] diff --git a/conformance/TestSampledFrom.hs b/conformance/TestSampledFrom.hs new file mode 100644 --- /dev/null +++ b/conformance/TestSampledFrom.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Conformance binary: generates sampled_from values and writes metrics. +module Main (main) where + +import qualified Data.Aeson as Aeson +import Data.Aeson (Value (..)) +import qualified Data.Aeson.Types as Aeson +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.Maybe (fromMaybe, listToMaybe) +import qualified Data.Map.Strict as Map +import Hegel +import System.Environment (getArgs) + +parseParams :: IO (Map.Map String Value) +parseParams = do + args <- getArgs + pure $ + fromMaybe Map.empty $ + Aeson.decode . LBS.pack =<< listToMaybe args + +getIntArray :: Map.Map String Value -> String -> [Int] +getIntArray m k = fromMaybe [] $ Map.lookup k m >>= Aeson.parseMaybe Aeson.parseJSON + +main :: IO () +main = do + params <- parseParams + let options = getIntArray params "options" + testCases <- getTestCases + runHegelTest (\settings -> settings { settingsTestCases = testCases }) $ \tc -> do + v <- draw tc (sampledFrom options) + writeMetrics [("value", show v)] diff --git a/conformance/TestText.hs b/conformance/TestText.hs new file mode 100644 --- /dev/null +++ b/conformance/TestText.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Conformance binary: generates text values and writes metrics. +module Main (main) where + +import qualified Data.Aeson as Aeson +import Data.Aeson (Value (..)) +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.Maybe (fromMaybe, listToMaybe) +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import Hegel +import System.Environment (getArgs) + +parseParams :: IO (Map.Map String Value) +parseParams = do + args <- getArgs + pure $ + fromMaybe Map.empty $ + Aeson.decode . LBS.pack =<< listToMaybe args + +getIntParam :: Map.Map String Value -> String -> Maybe Int +getIntParam m k = round <$> (getNumber =<< Map.lookup k m) + where + getNumber (Number n) = Just n + getNumber _ = Nothing + +main :: IO () +main = do + params <- parseParams + let minSize = getIntParam params "min_size" + let maxSize = getIntParam params "max_size" + testCases <- getTestCases + runHegelTest (\settings -> settings { settingsTestCases = testCases }) $ \tc -> do + t <- draw tc (text def { rangeMin = minSize, rangeMax = maxSize }) + -- T.length counts Unicode codepoints + writeMetrics [("length", show (T.length t))] diff --git a/hegel.cabal b/hegel.cabal new file mode 100644 --- /dev/null +++ b/hegel.cabal @@ -0,0 +1,168 @@ +cabal-version: 3.0 +name: hegel +version: 0.1.0 +synopsis: Property-based testing powered by Hypothesis +description: + Hegel is a Haskell property-based testing library backed by Hypothesis. + It provides a generator API, an integration test runner, and a wire + protocol client for driving Hegel from Haskell code. +maintainer: Mark Wotton +category: Testing +license: MIT +build-type: Simple + +common shared + ghc-options: -Wall -Wcompat -threaded + default-language: GHC2021 + build-depends: data-default >=0.7 && <0.9 + +library + import: shared + hs-source-dirs: src + exposed-modules: + Hegel + Hegel.Client + Hegel.Conformance + Hegel.Connection + Hegel.Generator + Hegel.Generator.Collections + Hegel.Generator.Combinators + Hegel.Generator.Primitives + Hegel.Protocol + Hegel.Session + other-modules: + Hegel.Generator.Range + + build-depends: + , array >=0.5 && <0.6 + , async >=2.2 && <2.3 + , base >=4.18 && <5 + , bytestring >=0.11 && <0.13 + , cborg >=0.2.9 && <0.3 + , containers >=0.6 && <0.8 + , digest >=0.0.2 && <0.1 + , directory >=1.3 && <1.4 + , process >=1.6 && <1.7 + , stm >=2.5 && <2.6 + , text >=2.0 && <2.2 + +test-suite hegel-test + import: shared + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: + Hegel.ProtocolSpec + Hegel.ClientSpec + Hegel.IntegrationSpec + + build-depends: + , base + , bytestring + , cborg + , hegel + , hspec + , process + , stm + , text + + build-tool-depends: + hspec-discover:hspec-discover + +executable test-booleans + import: shared + hs-source-dirs: conformance + main-is: TestBooleans.hs + build-depends: + , aeson >=2.2 && <2.3 + , base + , hegel + , text + +executable test-integers + import: shared + hs-source-dirs: conformance + main-is: TestIntegers.hs + build-depends: + , aeson >=2.2 && <2.3 + , base + , bytestring + , containers + , hegel + , text + +executable test-floats + import: shared + hs-source-dirs: conformance + main-is: TestFloats.hs + build-depends: + , aeson >=2.2 && <2.3 + , base + , bytestring + , containers + , hegel + , text + +executable test-text + import: shared + hs-source-dirs: conformance + main-is: TestText.hs + build-depends: + , aeson >=2.2 && <2.3 + , base + , bytestring + , containers + , hegel + , text + +executable test-binary + import: shared + hs-source-dirs: conformance + main-is: TestBinary.hs + build-depends: + , aeson >=2.2 && <2.3 + , base + , bytestring + , containers + , hegel + , text + +executable test-lists + import: shared + hs-source-dirs: conformance + main-is: TestLists.hs + build-depends: + , aeson >=2.2 && <2.3 + , base + , bytestring + , containers + , hegel + , text + +executable test-sampled-from + import: shared + hs-source-dirs: conformance + main-is: TestSampledFrom.hs + build-depends: + , aeson >=2.2 && <2.3 + , base + , bytestring + , containers + , hegel + , text + +executable test-hashmaps + import: shared + hs-source-dirs: conformance + main-is: TestHashmaps.hs + build-depends: + , aeson >=2.2 && <2.3 + , base + , bytestring + , containers + , hegel + , text + +source-repository head + type: git + location: https://github.com/lambdamechanic/hegel-haskell.git diff --git a/src/Hegel.hs b/src/Hegel.hs new file mode 100644 --- /dev/null +++ b/src/Hegel.hs @@ -0,0 +1,153 @@ +-- | Hegel is a property-based testing library for Haskell. Hegel is based on +-- , using the +-- protocol. +-- +-- = Getting started +-- +-- @ +-- import Data.Default (def) +-- import Hegel +-- +-- main :: IO () +-- main = 'runHegelTest_' $ \\tc -> do +-- n <- 'draw' tc ('integers' def) +-- assert (n == n) "integer not equal to itself" +-- @ +module Hegel + ( -- * Running tests + runHegelTest, + runHegelTest_, + TestCase, + Settings + ( settingsTestCases + , settingsVerbosity + , settingsSeed + , settingsDerandomize + , settingsDatabase + , settingsSuppressHealthCheck + ), + defaultSettings, + def, + HealthCheck (..), + Verbosity (..), + Database (..), + + -- * Drawing values + draw, + assume, + assert, + failure, + note, + target, + + -- * Generators + Generator, + gmap, + flatMap, + gfilter, + + -- ** Primitives + booleans, + integers, + floats, + RangeOpts (..), + defaultRangeOpts, + FloatOpts (..), + defaultFloatOpts, + text, + binary, + just, + + -- ** Collections + lists, + hashmaps, + + -- ** Combinators + sampledFrom, + oneOf, + optional, + tuples2, + tuples3, + tuples4, + ipAddresses, + ipv4Addresses, + ipv6Addresses, + + -- ** Formats + emails, + urls, + domains, + dates, + times, + datetimes, + fromRegex, + + -- * Conformance helpers + getTestCases, + writeMetrics, + + -- * Exceptions + AssumeRejected (..), + DataExhausted (..), + HegelTestFailure (..), + ) +where + +import Data.Default (def) +import Hegel.Client + ( AssumeRejected (..), + DataExhausted (..), + Database (..), + HealthCheck (..), + HegelTestFailure (..), + Settings + ( settingsTestCases + , settingsVerbosity + , settingsSeed + , settingsDerandomize + , settingsDatabase + , settingsSuppressHealthCheck + ), + TestCase, + Verbosity (..), + assume, + assert, + defaultSettings, + note, + target, + failure, + ) +import Hegel.Conformance (getTestCases, writeMetrics) +import Hegel.Generator (Generator, draw, flatMap, gfilter, gmap) +import Hegel.Generator.Collections (hashmaps, lists) +import Hegel.Generator.Combinators + ( ipAddresses, + oneOf, + optional, + sampledFrom, + tuples2, + tuples3, + tuples4, + ) +import Hegel.Generator.Primitives + ( FloatOpts (..), + RangeOpts (..), + binary, + booleans, + dates, + datetimes, + defaultFloatOpts, + defaultRangeOpts, + domains, + emails, + floats, + fromRegex, + integers, + ipv4Addresses, + ipv6Addresses, + just, + text, + times, + urls, + ) +import Hegel.Session (runHegelTest, runHegelTest_) diff --git a/src/Hegel/Client.hs b/src/Hegel/Client.hs new file mode 100644 --- /dev/null +++ b/src/Hegel/Client.hs @@ -0,0 +1,521 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Test runner and lifecycle management for Hegel. +-- +-- This module implements the client-side logic for running property-based +-- tests against a Hegel server. It manages: +-- +-- * Test lifecycle (run_test, test_case events, mark_complete) +-- * Helper functions (assume, note, target, generate_from_schema) +-- * Origin extraction for error reporting +module Hegel.Client + ( -- * Exceptions + AssumeRejected (..) + , DataExhausted (..) + , HegelTestFailure (..) + + -- * Health checks + , HealthCheck (..) + , healthCheckToString + + -- * Verbosity and database settings + , Verbosity (..) + , Database (..) + , Settings + ( settingsTestCases + , settingsVerbosity + , settingsSeed + , settingsDerandomize + , settingsDatabase + , settingsSuppressHealthCheck + ) + , defaultSettings + + -- * Test case state + , TestCase (..) + + -- * Client + , HegelClient (..) + , createClient + + -- * Test operations + , generateFromSchema + , assume + , assert + , failure + , note + , target + , startSpan + , stopSpan + , runTestCase + , runTest + ) where + +import Codec.CBOR.Term (Term (..)) +import Control.Concurrent.MVar +import Control.Exception hiding (assert) +import Control.Monad (replicateM_, when, unless, void) +import Data.Default (Default (def)) +import Data.IORef +import Data.Text (Text) +import qualified Data.Text as T +import GHC.Stack + ( CallStack + , HasCallStack + , SrcLoc (..) + , callStack + , getCallStack + , prettyCallStack + , withFrozenCallStack + ) +import System.IO (hPutStrLn, stderr) + +import Hegel.Connection +import Hegel.Protocol (encodeTerm, extractInt, extractMap, extractText) + + +-- --------------------------------------------------------------------------- +-- Exceptions +-- --------------------------------------------------------------------------- + +-- | Raised when 'assume' is called with a 'False' condition. +data AssumeRejected = AssumeRejected + deriving (Show) + +instance Exception AssumeRejected + +-- | Raised when the server runs out of test data (StopTest). +data DataExhausted = DataExhausted + deriving (Show) + +instance Exception DataExhausted + +-- | Raised when a property test fails. +newtype HegelTestFailure = HegelTestFailure String + deriving (Show) + +instance Exception HegelTestFailure + +-- | Raised by Hegel's assertion helpers. Carries a call stack so we can report +-- a stable source location to the server while still surfacing the full error +-- message on the final replayed failure. +data AssertionFailure = AssertionFailure + { assertionFailureMessage :: String + , assertionFailureCallStack :: CallStack + } + +instance Show AssertionFailure where + show AssertionFailure {..} + | null (getCallStack assertionFailureCallStack) = assertionFailureMessage + | otherwise = + assertionFailureMessage + ++ "\n" + ++ prettyCallStack assertionFailureCallStack + +instance Exception AssertionFailure where + displayException = show + + +-- --------------------------------------------------------------------------- +-- Health checks +-- --------------------------------------------------------------------------- + +-- | Health checks that can be suppressed during test execution. +data HealthCheck + = FilterTooMuch + | TooSlow + | TestCasesTooLarge + | LargeInitialTestCase + deriving (Show, Eq) + +-- | Returns the wire protocol name for a health check. +healthCheckToString :: HealthCheck -> Text +healthCheckToString FilterTooMuch = "filter_too_much" +healthCheckToString TooSlow = "too_slow" +healthCheckToString TestCasesTooLarge = "test_cases_too_large" +healthCheckToString LargeInitialTestCase = "large_initial_test_case" + + +-- --------------------------------------------------------------------------- +-- Verbosity and database settings +-- --------------------------------------------------------------------------- + +-- | Controls how much output Hegel produces during test runs. +data Verbosity = Quiet | Normal | Verbose | Debug + deriving (Show, Eq) + +-- | The database setting: unset, disabled, or a path. +data Database + = Unset + | Disabled + | DatabasePath FilePath + deriving (Show, Eq) + +-- | Configuration for a Hegel test run. +data Settings = Settings + { settingsTestCases :: Int + , settingsVerbosity :: Verbosity + , settingsSeed :: Maybe Int + , settingsDerandomize :: Bool + , settingsDatabase :: Database + , settingsSuppressHealthCheck :: [HealthCheck] + } deriving (Show, Eq) + +instance Default Settings where + def = Settings + { settingsTestCases = 100 + , settingsVerbosity = Normal + , settingsSeed = Nothing + , settingsDerandomize = False + , settingsDatabase = Unset + , settingsSuppressHealthCheck = [] + } + + +-- | Pure baseline settings before any runtime-specific overrides are applied. +defaultSettings :: Settings +defaultSettings = def + + +-- --------------------------------------------------------------------------- +-- Test case state +-- --------------------------------------------------------------------------- + +-- | Per-test-case state passed to the test function. +data TestCase = TestCase + { tcChannel :: Channel + -- ^ The data channel for this test case. + , tcIsFinal :: Bool + -- ^ Whether this is the final (replay) run. + , tcTestAborted :: IORef Bool + -- ^ Set to 'True' when the server signals StopTest. + } + + +-- --------------------------------------------------------------------------- +-- Client +-- --------------------------------------------------------------------------- + +-- | Supported protocol version range. +supportedProtocolLo :: Double +supportedProtocolLo = 0.6 + +supportedProtocolHi :: Double +supportedProtocolHi = 0.7 + +-- | Hegel client for running property-based tests. +data HegelClient = HegelClient + { clientConnection :: Connection + , clientControl :: Channel + , clientLock :: MVar () + } + +-- | Creates a new client from a connection. The connection must not yet have +-- had its handshake performed. Validates the protocol version is in range +-- 0.1 through 0.7. +createClient :: Connection -> IO HegelClient +createClient conn = do + versionStr <- sendHandshake conn + let serverVersion = read versionStr :: Double + when (serverVersion < supportedProtocolLo || serverVersion > supportedProtocolHi) $ + fail $ "hegel-haskell supports protocol versions " + ++ show supportedProtocolLo ++ " through " ++ show supportedProtocolHi + ++ ", but got server version " ++ show serverVersion + ++ ". Upgrading hegel-haskell or downgrading your hegel cli might help." + ctrl <- controlChannel conn + lock <- newMVar () + pure HegelClient + { clientConnection = conn + , clientControl = ctrl + , clientLock = lock + } + + +-- --------------------------------------------------------------------------- +-- Test operations +-- --------------------------------------------------------------------------- + +-- | Generates a value from a schema by sending a generate command to the +-- server. Raises 'DataExhausted' if the server signals StopTest. +generateFromSchema :: Term -> TestCase -> IO Term +generateFromSchema schema tc = do + let ch = tcChannel tc + let msg = TMap + [ (TString "command", TString "generate") + , (TString "schema", schema) + ] + result <- try (sendRequestAndWait ch msg) :: IO (Either RequestError Term) + case result of + Right val -> pure val + Left (RequestError _ errType _) + | errType == "StopTest" -> do + writeIORef (tcTestAborted tc) True + throwIO DataExhausted + Left e -> throwIO e + +-- | Rejects the current test case if the condition is 'False'. +assume :: TestCase -> Bool -> IO () +assume _tc condition = unless condition $ throwIO AssumeRejected + +-- | Fails the current property with a message and captured call stack. +failure :: HasCallStack => String -> IO a +failure message = + withFrozenCallStack $ + throwIO + AssertionFailure + { assertionFailureMessage = message + , assertionFailureCallStack = callStack + } + +-- | Asserts a property condition, reporting the call site on failure. +assert :: HasCallStack => Bool -> String -> IO () +assert condition message = unless condition (withFrozenCallStack $ failure message) + +-- | Records a message that will be printed on the final (failing) run. +note :: TestCase -> String -> IO () +note tc message = when (tcIsFinal tc) $ hPutStrLn stderr message + +-- | Sends a target command to guide the search engine toward higher values. +target :: TestCase -> Double -> String -> IO () +target tc value label = do + let ch = tcChannel tc + let msg = TMap + [ (TString "command", TString "target") + , (TString "value", TDouble value) + , (TString "label", TString (T.pack label)) + ] + void $ sendRequestAndWait ch msg + +-- | Starts a generation span for better shrinking. +startSpan :: Int -> TestCase -> IO () +startSpan label tc = do + aborted <- readIORef (tcTestAborted tc) + unless aborted $ do + let ch = tcChannel tc + let msg = TMap + [ (TString "command", TString "start_span") + , (TString "label", TInt label) + ] + void $ sendRequestAndWait ch msg + +-- | Ends the current generation span. +stopSpan :: Bool -> TestCase -> IO () +stopSpan discard tc = do + aborted <- readIORef (tcTestAborted tc) + unless aborted $ do + let ch = tcChannel tc + let msg = TMap + [ (TString "command", TString "stop_span") + , (TString "discard", TBool discard) + ] + void $ sendRequestAndWait ch msg + + +-- --------------------------------------------------------------------------- +-- Test case outcomes +-- --------------------------------------------------------------------------- + +data TestOutcome + = Valid + | Invalid + | DataWasExhausted + | Interesting Text (Maybe SomeException) + -- ^ origin text, and optionally the exception (on final run) + +-- | Extracts a human-readable origin string from an exception. +extractOrigin :: SomeException -> Text +extractOrigin exn = + case fromException exn of + Just AssertionFailure {assertionFailureCallStack = stack} -> + maybe fallback (T.pack . formatSrcLoc) (firstSrcLoc stack) + Nothing -> fallback + where + fallback = T.pack (displayException exn) + +firstSrcLoc :: CallStack -> Maybe SrcLoc +firstSrcLoc stack = snd <$> case getCallStack stack of + [] -> Nothing + frame : _ -> Just frame + +formatSrcLoc :: SrcLoc -> String +formatSrcLoc SrcLoc {..} = + srcLocFile ++ ":" ++ show srcLocStartLine ++ ":" ++ show srcLocStartCol + +-- | Send mark_complete, swallowing StopTest errors. +markComplete :: Channel -> Text -> Term -> IO () +markComplete ch status origin = do + let msg = TMap + [ (TString "command", TString "mark_complete") + , (TString "status", TString status) + , (TString "origin", origin) + ] + result <- try (sendRequestAndWait ch msg) :: IO (Either RequestError Term) + case result of + Left (RequestError _ errType _) + | errType == "StopTest" -> pure () + Left e -> throwIO e + Right _ -> pure () + +-- | Runs a single test case. Creates a 'TestCase', runs the user function, +-- catches exceptions, and sends mark_complete with the appropriate status +-- (VALID, INVALID, or INTERESTING). Handles StopTest on mark_complete. +runTestCase :: HegelClient -> Channel -> (TestCase -> IO ()) -> Bool -> IO () +runTestCase _client ch testFn isFinal = do + abortedRef <- newIORef False + let tc = TestCase + { tcChannel = ch + , tcIsFinal = isFinal + , tcTestAborted = abortedRef + } + outcome <- (testFn tc >> pure Valid) `catches` + [ Handler $ \AssumeRejected -> pure Invalid + , Handler $ \DataExhausted -> pure DataWasExhausted + , Handler $ \(e :: SomeException) -> do + let origin = extractOrigin e + let ex = if isFinal then Just e else Nothing + pure (Interesting origin ex) + ] + case outcome of + DataWasExhausted -> pure () + Valid -> markComplete ch "VALID" TNull + Invalid -> markComplete ch "INVALID" TNull + Interesting originText _ -> markComplete ch "INTERESTING" (TString originText) + closeChannel ch + -- On final run, re-raise the interesting exception + case outcome of + Interesting _ (Just e) -> throwIO e + _ -> pure () + + +-- --------------------------------------------------------------------------- +-- Full test lifecycle +-- --------------------------------------------------------------------------- + +-- | Runs a full property test. Sends run_test on the control channel with +-- all settings fields, then processes test_case and test_done events. +-- Checks error, health_check_failure, flaky, and passed in results. +-- Replays interesting cases on the final run. +runTest :: HegelClient -> Settings -> (TestCase -> IO ()) -> IO () +runTest client stgs testFn = do + let conn = clientConnection client + testChannel <- newChannel conn + + -- Send run_test command under the client lock + withMVar (clientLock client) $ \_ -> do + let seedValue = maybe TNull TInt (settingsSeed stgs) + let databaseKeyValue = TNull + let baseFields = + [ (TString "command", TString "run_test") + , (TString "test_cases", TInt (settingsTestCases stgs)) + , (TString "seed", seedValue) + , (TString "channel_id", TInt (fromIntegral (channelId testChannel))) + , (TString "database_key", databaseKeyValue) + , (TString "derandomize", TBool (settingsDerandomize stgs)) + ] + let databaseField = case settingsDatabase stgs of + Unset -> [] + Disabled -> [(TString "database", TNull)] + DatabasePath p -> [(TString "database", TString (T.pack p))] + let suppressField = case settingsSuppressHealthCheck stgs of + [] -> [] + checks -> + [ ( TString "suppress_health_check" + , TList (map (TString . healthCheckToString) checks) + ) + ] + let fields = baseFields ++ databaseField ++ suppressField + void $ sendRequestAndWait (clientControl client) (TMap fields) + + -- Helper to receive and run a test case (used for replay) + let receiveAndRunTestCase isFinal = do + (msgId, msg) <- receiveRequest testChannel + let pairs = extractMap msg + let chId = extractInt (lookupCBOR "channel_id" pairs) + sendResponseValue testChannel msgId TNull + tcChan <- connectChannel conn (fromIntegral chId) + runTestCase client tcChan testFn isFinal + + -- Event loop + let receiveEvents = do + (msgId, msg) <- receiveRequest testChannel + let pairs = extractMap msg + let event = extractText (lookupCBOR "event" pairs) + case event of + "test_case" -> do + let chId = extractInt (lookupCBOR "channel_id" pairs) + sendResponseValue testChannel msgId TNull + tcChan <- connectChannel conn (fromIntegral chId) + runTestCase client tcChan testFn False + exited <- serverHasExited conn + when exited $ fail serverCrashedMessage + receiveEvents + "test_done" -> do + sendResponseValue testChannel msgId (TBool True) + pure (extractMap (lookupCBOR "results" pairs)) + other -> do + let errPayload = encodeTerm $ TMap + [ (TString "error", TString ("Unrecognised event " <> other)) + , (TString "type", TString "InvalidMessage") + ] + sendResponseRaw testChannel msgId errPayload + receiveEvents + + results <- receiveEvents + + -- Check for server-side errors + case lookupCBORMaybe "error" results of + Just errorVal -> do + let errorMsg = extractText errorVal + fail ("Server error: " ++ T.unpack errorMsg) + Nothing -> pure () + + -- Check for health check failure + case lookupCBORMaybe "health_check_failure" results of + Just failureVal -> do + let failureMsg = extractText failureVal + fail ("Health check failure:\n" ++ T.unpack failureMsg) + Nothing -> pure () + + -- Check for flaky test detection + case lookupCBORMaybe "flaky" results of + Just flakyVal -> do + let flakyMsg = extractText flakyVal + fail ("Flaky test detected: " ++ T.unpack flakyMsg) + Nothing -> pure () + + -- Check passed flag + let passed = case lookupCBORMaybe "passed" results of + Just (TBool b) -> b + _ -> True + + let nInteresting = extractInt (lookupCBOR "interesting_test_cases" results) + + if nInteresting == 0 && passed + then pure () + else if nInteresting >= 1 + then do + firstFailure <- try (receiveAndRunTestCase True) + -- Drain any extra interesting cases quietly to keep the control + -- channel in sync, but only surface the smallest final failure. + replicateM_ (nInteresting - 1) (receiveAndRunTestCase False) + case firstFailure of + Left (e :: SomeException) -> throwIO e + Right () -> unless passed $ throwIO (HegelTestFailure "Property test failed") + else unless passed $ throwIO (HegelTestFailure "Property test failed") + + +-- --------------------------------------------------------------------------- +-- CBOR helpers (local to this module) +-- --------------------------------------------------------------------------- + +-- | Look up a key in a CBOR map (list of pairs), using a 'Text' key. +lookupCBOR :: Text -> [(Term, Term)] -> Term +lookupCBOR key pairs = + case lookup (TString key) pairs of + Just v -> v + Nothing -> error $ "Key not found in CBOR map: " ++ T.unpack key + +-- | Look up a key in a CBOR map, returning 'Nothing' if absent. +lookupCBORMaybe :: Text -> [(Term, Term)] -> Maybe Term +lookupCBORMaybe key = lookup (TString key) diff --git a/src/Hegel/Conformance.hs b/src/Hegel/Conformance.hs new file mode 100644 --- /dev/null +++ b/src/Hegel/Conformance.hs @@ -0,0 +1,43 @@ +-- | Helpers for writing Hegel conformance test binaries. +-- +-- Each conformance binary reads parameters from @argv[1]@ (JSON), runs a +-- property test that draws values and writes metrics, then exits. +module Hegel.Conformance + ( getTestCases, + writeMetrics, + formatMetrics, + ) +where + +import System.Environment (lookupEnv) +import System.IO (IOMode (..), hFlush, hPutStr, withFile) + +-- | Read the number of test cases from the @CONFORMANCE_TEST_CASES@ +-- environment variable. Defaults to 50. +getTestCases :: IO Int +getTestCases = do + val <- lookupEnv "CONFORMANCE_TEST_CASES" + pure $ maybe 50 read val + +-- | Format a list of key-value pairs as a JSON object string (one line). +-- Values are already pre-formatted as JSON (e.g. numbers without quotes, +-- strings with quotes, @\"null\"@ for null). +formatMetrics :: [(String, String)] -> String +formatMetrics pairs = + "{" ++ intercalate ", " (map fmt pairs) ++ "}\n" + where + fmt (k, v) = "\"" ++ k ++ "\": " ++ v + intercalate _ [] = "" + intercalate sep (x : xs) = x ++ concatMap (sep ++) xs + +-- | Write metrics to the file specified by @CONFORMANCE_METRICS_FILE@. +-- If the variable is not set, does nothing. +writeMetrics :: [(String, String)] -> IO () +writeMetrics pairs = do + mPath <- lookupEnv "CONFORMANCE_METRICS_FILE" + case mPath of + Nothing -> pure () + Just path -> + withFile path AppendMode $ \h -> do + hPutStr h (formatMetrics pairs) + hFlush h diff --git a/src/Hegel/Connection.hs b/src/Hegel/Connection.hs new file mode 100644 --- /dev/null +++ b/src/Hegel/Connection.hs @@ -0,0 +1,648 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StrictData #-} + +-- | Multiplexed connection and channel abstractions for Hegel. +-- +-- This module implements a background-reader model: a dedicated thread reads +-- packets from the input stream and dispatches them to per-channel inboxes. +-- Channels use STM 'TQueue' for incoming messages. +-- +-- A 'Connection' manages a pair of 'Handle's (one for reading, one for +-- writing) with multiplexed logical channels. A 'Channel' provides +-- request\/response messaging over a single logical channel. +module Hegel.Connection + ( -- * Types + Connection (..) + , Channel (..) + , InboxItem (..) + , RequestError (..) + , PendingRequest + + -- * Connection lifecycle + , createConnection + , closeConnection + + -- * Channel management + , newChannel + , connectChannel + , closeChannel + + -- * Sending + , sendPacket + , sendRequest + , sendRequestCBOR + + -- * Receiving + , receiveResponse + , receiveRequest + , sendResponseValue + + -- * Handshake + , sendHandshake + + -- * Result handling + , resultOrError + + -- * Pending requests + , request + , pendingGet + + -- * Accessors + , controlChannel + , channelId + , serverHasExited + , setServerExited + , isLive + , sendRequestAndWait + , sendResponseRaw + , serverCrashedMessage + ) where + +import Codec.CBOR.Term (Term (..)) +import Control.Concurrent.Async (Async, async, cancel) +import Control.Concurrent.MVar (MVar, newMVar, withMVar) +import Control.Concurrent.STM + ( STM + , TQueue + , TVar + , atomically + , check + , newTQueueIO + , newTVarIO + , orElse + , readTQueue + , readTVar + , readTVarIO + , registerDelay + , writeTQueue + , writeTVar + , modifyTVar' + ) +import Control.Exception (Exception, SomeException, catch, throwIO) +import Control.Monad (unless, when) +import Data.Bits (shiftL, (.|.)) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS8 +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import Data.Word (Word32) +import System.IO (Handle, hClose, hSetBinaryMode) + +import Hegel.Protocol + +-- --------------------------------------------------------------------------- +-- Constants +-- --------------------------------------------------------------------------- + +-- | Handshake string sent by the client to initiate the protocol. +handshakeString :: ByteString +handshakeString = "hegel_handshake_start" + +-- | Default timeout in microseconds for channel operations (30 seconds). +channelTimeoutMicros :: Int +channelTimeoutMicros = 30 * 1000000 + +-- | Message displayed when the server has crashed. +serverCrashedMessage :: String +serverCrashedMessage = + "The hegel server process has exited unexpectedly. Check .hegel/server.log for details." + +-- --------------------------------------------------------------------------- +-- Types +-- --------------------------------------------------------------------------- + +-- | Sentinel value placed in a channel's inbox when the connection shuts down. +data InboxItem + = Pkt Packet + -- ^ A normal packet. + | Shutdown + -- ^ The connection has been closed. + deriving (Show, Eq) + +-- | Error response from the peer. +data RequestError = RequestError + { reqErrorMessage :: String + , reqErrorType :: String + , reqErrorData :: [(Term, Term)] + } + deriving (Show) + +instance Exception RequestError + +-- | Multiplexed connection to a Hegel peer. +data Connection = Connection + { connReadHandle :: Handle + -- ^ Handle for reading packets. + , connWriteHandle :: Handle + -- ^ Handle for writing packets. + , connNextChannelId :: TVar Int + -- ^ Counter for allocating new channel IDs. + , connChannels :: TVar (Map Word32 Channel) + -- ^ Map from channel ID to live channel. + , connRunning :: TVar Bool + -- ^ Whether the connection is still active. + , connServerExited :: TVar Bool + -- ^ Whether the server process has exited unexpectedly. + , connWriterLock :: MVar () + -- ^ Lock for serializing writes to the output handle. + , connReaderThread :: Async () + -- ^ Background reader thread. + , connDebug :: Bool + -- ^ Whether debug logging is enabled. + } + +-- | Logical channel for request\/response messaging. +data Channel = Channel + { chanId :: Word32 + -- ^ The channel ID. + , chanConn :: Connection + -- ^ The connection this channel belongs to. + , chanInbox :: TQueue InboxItem + -- ^ Inbox for incoming packets dispatched by the reader thread. + , chanResponses :: TVar (Map Word32 ByteString) + -- ^ Map from message ID to response payload (filled by 'processOneMessage'). + , chanRequests :: TQueue Packet + -- ^ Queue of incoming request packets (filled by 'processOneMessage'). + , chanNextMessageId :: TVar Word32 + -- ^ Next message ID to use for outgoing requests. + , chanClosed :: TVar Bool + -- ^ Whether this channel has been closed. + } + +-- | A pending request handle that caches the decoded response. +data PendingRequest = PendingRequest + { prChannel :: Channel + , prMessageId :: Word32 + , prValue :: IORef (Maybe Term) + } + +-- --------------------------------------------------------------------------- +-- Connection lifecycle +-- --------------------------------------------------------------------------- + +-- | Create a new connection using separate handles for reading and writing. +-- +-- A control channel (channel 0) is automatically created and a background +-- reader thread is spawned. Both handles are set to binary mode. +createConnection :: Handle -> Handle -> Bool -> IO Connection +createConnection readH writeH debug = do + hSetBinaryMode readH True + hSetBinaryMode writeH True + + nextChanId <- newTVarIO 1 + channels <- newTVarIO Map.empty + running <- newTVarIO True + serverExited <- newTVarIO False + writerLock <- newMVar () + + -- Create a placeholder connection (reader thread filled in below) + let mkConn reader = Connection + { connReadHandle = readH + , connWriteHandle = writeH + , connNextChannelId = nextChanId + , connChannels = channels + , connRunning = running + , connServerExited = serverExited + , connWriterLock = writerLock + , connReaderThread = reader + , connDebug = debug + } + + -- Create control channel (channel 0) + controlInbox <- newTQueueIO + controlResponses <- newTVarIO Map.empty + controlRequests <- newTQueueIO + controlNextMsgId <- newTVarIO 1 + controlClosed <- newTVarIO False + + -- We need the connection reference for the channel, but the connection + -- needs the reader thread. Use a two-phase approach: create a dummy + -- Async, build everything, then spawn the real reader. + dummyAsync <- async (return ()) + + let tempConn = mkConn dummyAsync + + let ctrl = Channel + { chanId = 0 + , chanConn = tempConn + , chanInbox = controlInbox + , chanResponses = controlResponses + , chanRequests = controlRequests + , chanNextMessageId = controlNextMsgId + , chanClosed = controlClosed + } + + atomically $ writeTVar channels (Map.singleton 0 ctrl) + + -- Spawn background reader thread + reader <- async (readerLoop tempConn) + + -- The connection returned uses the same TVars so the reader thread's + -- reference via tempConn is equivalent. We return a version with the + -- real Async handle for cleanup. + let conn = mkConn reader + + -- Update the control channel to reference the real connection + -- (shares the same TVars, so this is just for the Async handle) + let ctrl' = ctrl { chanConn = conn } + atomically $ writeTVar channels (Map.singleton 0 ctrl') + + return conn + +-- | Close the connection and signal all live channels. +closeConnection :: Connection -> IO () +closeConnection conn = do + isRunning <- readTVarIO (connRunning conn) + if not isRunning + then return () + else do + atomically $ writeTVar (connRunning conn) False + catch (hClose (connReadHandle conn)) (\(_ :: SomeException) -> return ()) + -- Always attempt to close the write handle; if it is the same as + -- the read handle, hClose will simply fail silently. + catch (hClose (connWriteHandle conn)) (\(_ :: SomeException) -> return ()) + signalAllChannels conn + cancel (connReaderThread conn) + +-- --------------------------------------------------------------------------- +-- Background reader +-- --------------------------------------------------------------------------- + +-- | Background reader thread function. Reads packets from the connection's +-- read handle and dispatches them to the appropriate channel's inbox. +-- Exits when the stream closes or an error occurs. +readerLoop :: Connection -> IO () +readerLoop conn = do + let loop = do + isRunning <- readTVarIO (connRunning conn) + when isRunning $ do + pkt <- readPacket (connReadHandle conn) + dispatchPacket conn pkt + loop + + catch loop (\(_ :: SomeException) -> do + atomically $ writeTVar (connServerExited conn) True) + + signalAllChannels conn + +-- | Dispatch a single packet to the appropriate channel. +dispatchPacket :: Connection -> Packet -> IO () +dispatchPacket conn pkt + | packetPayload pkt == closeChannelPayload = return () + | otherwise = do + mChan <- Map.lookup (packetChannelId pkt) <$> readTVarIO (connChannels conn) + case mChan of + Just ch -> atomically $ writeTQueue (chanInbox ch) (Pkt pkt) + Nothing -> + -- For non-reply messages to non-existent channels, send error back + unless (packetIsReply pkt) $ do + let errorMsg = "Message sent to non-existent channel " + ++ show (packetChannelId pkt) + errorPayload = encodeTerm $ + TMap [(TString "error", TString (T.pack errorMsg))] + catch + (sendPacket conn Packet + { packetChannelId = packetChannelId pkt + , packetMessageId = packetMessageId pkt + , packetIsReply = True + , packetPayload = errorPayload + }) + (\(_ :: SomeException) -> return ()) + +-- | Push 'Shutdown' into all live channels' inboxes. +signalAllChannels :: Connection -> IO () +signalAllChannels conn = do + chans <- readTVarIO (connChannels conn) + mapM_ (\ch -> atomically $ writeTQueue (chanInbox ch) Shutdown) (Map.elems chans) + +-- --------------------------------------------------------------------------- +-- Channel management +-- --------------------------------------------------------------------------- + +-- | Create a new logical channel on the connection. +-- +-- Client channels use odd IDs: @(counter \<\< 1) | 1@. +newChannel :: Connection -> IO Channel +newChannel conn = do + chanid <- atomically $ do + counter <- readTVar (connNextChannelId conn) + let cid = fromIntegral ((counter `shiftL` 1) .|. 1) :: Word32 + writeTVar (connNextChannelId conn) (counter + 1) + return cid + + inbox <- newTQueueIO + responses <- newTVarIO Map.empty + requests <- newTQueueIO + nextMsgId <- newTVarIO 1 + closed <- newTVarIO False + + let channel = Channel + { chanId = chanid + , chanConn = conn + , chanInbox = inbox + , chanResponses = responses + , chanRequests = requests + , chanNextMessageId = nextMsgId + , chanClosed = closed + } + + atomically $ modifyTVar' (connChannels conn) (Map.insert chanid channel) + return channel + +-- | Connect to a channel created by the peer (using the peer-assigned ID). +connectChannel :: Connection -> Word32 -> IO Channel +connectChannel conn cid = do + exists <- atomically $ do + chans <- readTVar (connChannels conn) + return (Map.member cid chans) + + if exists + then ioError $ userError $ + "Channel already connected as " ++ show cid ++ "." + else do + inbox <- newTQueueIO + responses <- newTVarIO Map.empty + requests <- newTQueueIO + nextMsgId <- newTVarIO 1 + closed <- newTVarIO False + + let channel = Channel + { chanId = cid + , chanConn = conn + , chanInbox = inbox + , chanResponses = responses + , chanRequests = requests + , chanNextMessageId = nextMsgId + , chanClosed = closed + } + + atomically $ modifyTVar' (connChannels conn) (Map.insert cid channel) + return channel + +-- | Close a channel and notify the peer. Idempotent. +closeChannel :: Channel -> IO () +closeChannel ch = do + alreadyClosed <- readTVarIO (chanClosed ch) + if alreadyClosed + then return () + else do + atomically $ writeTVar (chanClosed ch) True + isRunning <- readTVarIO (connRunning (chanConn ch)) + when isRunning $ + sendPacket (chanConn ch) Packet + { packetPayload = closeChannelPayload + , packetMessageId = closeChannelMessageId + , packetChannelId = chanId ch + , packetIsReply = False + } + +-- --------------------------------------------------------------------------- +-- Sending +-- --------------------------------------------------------------------------- + +-- | Send a packet on the connection, thread-safe via the writer lock. +sendPacket :: Connection -> Packet -> IO () +sendPacket conn pkt = + withMVar (connWriterLock conn) $ \() -> + writePacket (connWriteHandle conn) pkt + +-- | Send raw bytes as a request on a channel. Returns the message ID for +-- matching the response. +sendRequest :: Channel -> ByteString -> IO Word32 +sendRequest ch payload = do + msgId <- atomically $ do + mid <- readTVar (chanNextMessageId ch) + writeTVar (chanNextMessageId ch) (mid + 1) + return mid + sendPacket (chanConn ch) Packet + { packetPayload = payload + , packetChannelId = chanId ch + , packetIsReply = False + , packetMessageId = msgId + } + return msgId + +-- | Send a CBOR-encoded request on a channel. Returns the message ID. +sendRequestCBOR :: Channel -> Term -> IO Word32 +sendRequestCBOR ch term = sendRequest ch (encodeTerm term) + +-- --------------------------------------------------------------------------- +-- Receiving +-- --------------------------------------------------------------------------- + +-- | Pop an item from the channel's inbox, with a timeout in microseconds. +-- Returns 'Nothing' on timeout. +popInboxItem :: Channel -> Int -> IO InboxItem +popInboxItem ch timeoutUs = do + timedOut <- registerDelay timeoutUs + result <- atomically $ + (Just <$> readTQueue (chanInbox ch)) + `orElse` + (do expired <- readTVar timedOut + check expired + return Nothing) + case result of + Just item -> return item + Nothing -> do + isClosed <- readTVarIO (chanClosed ch) + if isClosed + then ioError $ userError $ "Channel " ++ show (chanId ch) ++ " is closed" + else do + exited <- readTVarIO (connServerExited (chanConn ch)) + if exited + then ioError $ userError serverCrashedMessage + else ioError $ userError $ + "Timed out after " ++ show (timeoutUs `div` 1000000) + ++ "s waiting for a message on channel " ++ show (chanId ch) + +-- | Process one incoming message for a channel. Dispatches replies to the +-- responses map and requests to the requests queue. +processOneMessage :: Channel -> Int -> IO () +processOneMessage ch timeoutUs = do + item <- popInboxItem ch timeoutUs + case item of + Shutdown -> ioError $ userError "Connection closed" + Pkt pkt -> + if packetIsReply pkt + then atomically $ modifyTVar' (chanResponses ch) + (Map.insert (packetMessageId pkt) (packetPayload pkt)) + else atomically $ writeTQueue (chanRequests ch) pkt + +-- | Wait for a raw response to a request with the given message ID. +receiveResponseRaw :: Channel -> Word32 -> Int -> IO ByteString +receiveResponseRaw ch msgId timeoutUs = do + let waitLoop = do + mResp <- atomically $ do + resps <- readTVar (chanResponses ch) + case Map.lookup msgId resps of + Just payload -> do + writeTVar (chanResponses ch) (Map.delete msgId resps) + return (Just payload) + Nothing -> return Nothing + case mResp of + Just payload -> return payload + Nothing -> do + processOneMessage ch timeoutUs + waitLoop + waitLoop + +-- | Wait for and decode a response, extracting the result or raising +-- 'RequestError'. +receiveResponse :: Channel -> Word32 -> IO Term +receiveResponse ch msgId = do + raw <- receiveResponseRaw ch msgId channelTimeoutMicros + resultOrError (decodeTerm raw) + +-- | Receive the next incoming request on a channel. Returns the message ID +-- and the decoded CBOR term. +receiveRequest :: Channel -> IO (Word32, Term) +receiveRequest ch = do + let waitLoop = do + mPkt <- atomically $ tryReadTQueue (chanRequests ch) + case mPkt of + Just pkt -> return (packetMessageId pkt, decodeTerm (packetPayload pkt)) + Nothing -> do + processOneMessage ch channelTimeoutMicros + waitLoop + waitLoop + where + tryReadTQueue :: TQueue a -> STM (Maybe a) + tryReadTQueue q = (Just <$> readTQueue q) `orElse` return Nothing + +-- | Send a success response with a value wrapped as @{\"result\": value}@. +sendResponseValue :: Channel -> Word32 -> Term -> IO () +sendResponseValue ch msgId value = do + let payload = encodeTerm $ TMap [(TString "result", value)] + sendPacket (chanConn ch) Packet + { packetPayload = payload + , packetChannelId = chanId ch + , packetIsReply = True + , packetMessageId = msgId + } + +-- --------------------------------------------------------------------------- +-- Result handling +-- --------------------------------------------------------------------------- + +-- | Extract the @\"result\"@ field from a CBOR map, or throw 'RequestError' +-- if an @\"error\"@ field is present. +resultOrError :: Term -> IO Term +resultOrError body = do + let pairs = extractMap body + findText key = case lookup (TString key) pairs of + Just v -> T.unpack (extractText v) + Nothing -> "" + case lookup (TString "error") pairs of + Just _ -> do + let msg = findText "error" + errorType = findText "type" + dat = filter (\(k, _) -> k /= TString "error" && k /= TString "type") pairs + throwIO $ RequestError msg errorType dat + Nothing -> + case lookup (TString "result") pairs of + Just v -> return v + Nothing -> ioError $ userError "Response has neither 'result' nor 'error'" + +-- --------------------------------------------------------------------------- +-- Pending requests +-- --------------------------------------------------------------------------- + +-- | Send a CBOR request and return a 'PendingRequest' handle. +request :: Channel -> Term -> IO PendingRequest +request ch term = do + msgId <- sendRequestCBOR ch term + ref <- newIORef Nothing + return PendingRequest + { prChannel = ch + , prMessageId = msgId + , prValue = ref + } + +-- | Block until the response arrives and return the result. +-- +-- Caches the response so subsequent calls return the same value or raise +-- the same error. +pendingGet :: PendingRequest -> IO Term +pendingGet pr = do + cached <- readIORef (prValue pr) + case cached of + Just v -> resultOrError v + Nothing -> do + raw <- receiveResponseRaw (prChannel pr) (prMessageId pr) channelTimeoutMicros + let v = decodeTerm raw + writeIORef (prValue pr) (Just v) + resultOrError v + +-- --------------------------------------------------------------------------- +-- Handshake +-- --------------------------------------------------------------------------- + +-- | Initiate the handshake as a client. Returns the server protocol version +-- string (e.g. @\"0.1\"@). +sendHandshake :: Connection -> IO String +sendHandshake conn = do + -- Get control channel (channel 0) + mCh <- atomically $ do + chans <- readTVar (connChannels conn) + return (Map.lookup 0 chans) + ch <- case mCh of + Just c -> return c + Nothing -> ioError $ userError "Internal error: no control channel" + + msgId <- sendRequest ch handshakeString + raw <- receiveResponseRaw ch msgId channelTimeoutMicros + + let response = BS8.unpack raw + prefix = "Hegel/" + if take 6 response /= prefix + then ioError $ userError $ "Bad handshake response: " ++ show response + else return (drop 6 response) + +-- --------------------------------------------------------------------------- +-- Additional accessors +-- --------------------------------------------------------------------------- + +-- | Get the control channel (channel 0). +controlChannel :: Connection -> IO Channel +controlChannel conn = do + mCh <- atomically $ do + chans <- readTVar (connChannels conn) + return (Map.lookup 0 chans) + case mCh of + Just c -> return c + Nothing -> ioError $ userError "Internal error: no control channel" + +-- | Get the channel ID. +channelId :: Channel -> Word32 +channelId = chanId + +-- | Check if the server process has exited. +serverHasExited :: Connection -> IO Bool +serverHasExited conn = readTVarIO (connServerExited conn) + +-- | Set the server-exited flag. +setServerExited :: Connection -> IO () +setServerExited conn = atomically $ writeTVar (connServerExited conn) True + +-- | Check if the connection is still active. +isLive :: Connection -> IO Bool +isLive conn = readTVarIO (connRunning conn) + +-- | Send a CBOR request and wait for the decoded response (convenience). +sendRequestAndWait :: Channel -> Term -> IO Term +sendRequestAndWait ch msg = do + msgId <- sendRequestCBOR ch msg + receiveResponse ch msgId + +-- | Send raw bytes as a reply. +sendResponseRaw :: Channel -> Word32 -> ByteString -> IO () +sendResponseRaw ch msgId payload = + sendPacket (chanConn ch) Packet + { packetChannelId = chanId ch + , packetMessageId = msgId + , packetIsReply = True + , packetPayload = payload + } diff --git a/src/Hegel/Generator.hs b/src/Hegel/Generator.hs new file mode 100644 --- /dev/null +++ b/src/Hegel/Generator.hs @@ -0,0 +1,385 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Core generator GADT and evaluation machinery. +-- +-- Generators produce typed Haskell values by communicating with the Hegel +-- server over CBOR. The 'Generator' type is a GADT with six constructors +-- reflecting different generation strategies: +-- +-- * 'Basic' holds a raw CBOR schema and a transform; the server generates the +-- value in one round-trip. +-- * 'Mapped' wraps a source generator and a transform function. +-- * 'FlatMapped' wraps a source and a function returning a generator. +-- * 'Filtered' wraps a source and a predicate (up to 'maxFilterAttempts' retries). +-- * 'CompositeList' uses the collection protocol for non-basic list elements. +-- * 'Composite' wraps a generation function inside a labelled span. +module Hegel.Generator + ( -- * Generator type + Generator (..) + + -- * Evaluation + , draw + + -- * Combinators + , gmap + , flatMap + , gfilter + + -- * Introspection + , isBasic + , asBasic + + -- * Span helpers + , group + , discardableGroup + + -- * Collection protocol + , Collection (..) + , newCollection + , collectionMore + , collectionReject + + -- * Span label constants + , labelList + , labelListElement + , labelSet + , labelSetElement + , labelMap + , labelMapEntry + , labelTuple + , labelOneOf + , labelOptional + , labelFixedDict + , labelFlatMap + , labelFilter + , labelMapped + , labelSampledFrom + , labelEnumVariant + + -- * Constants + , maxFilterAttempts + ) where + +import Codec.CBOR.Term (Term (..)) +import Control.Exception (SomeException, catch, throwIO) +import Control.Monad (unless) +import Data.IORef + +import Hegel.Client + ( DataExhausted (..) + , TestCase (..) + , assume + , generateFromSchema + , startSpan + , stopSpan + ) +import Hegel.Connection (RequestError (..), sendRequestAndWait) + +-- ---------------------------------------------------------------------------- +-- Span label constants +-- ---------------------------------------------------------------------------- + +-- | Span label for list generation. +labelList :: Int +labelList = 1 + +-- | Span label for individual list elements. +labelListElement :: Int +labelListElement = 2 + +-- | Span label for set generation. +labelSet :: Int +labelSet = 3 + +-- | Span label for individual set elements. +labelSetElement :: Int +labelSetElement = 4 + +-- | Span label for map (dictionary) generation. +labelMap :: Int +labelMap = 5 + +-- | Span label for individual map entries. +labelMapEntry :: Int +labelMapEntry = 6 + +-- | Span label for tuple generation. +labelTuple :: Int +labelTuple = 7 + +-- | Span label for one-of dispatch. +labelOneOf :: Int +labelOneOf = 8 + +-- | Span label for optional generation. +labelOptional :: Int +labelOptional = 9 + +-- | Span label for fixed-dict generation. +labelFixedDict :: Int +labelFixedDict = 10 + +-- | Span label for flat-map generation. +labelFlatMap :: Int +labelFlatMap = 11 + +-- | Span label for filter generation. +labelFilter :: Int +labelFilter = 12 + +-- | Span label for mapped generation. +labelMapped :: Int +labelMapped = 13 + +-- | Span label for sampled-from generation. +labelSampledFrom :: Int +labelSampledFrom = 14 + +-- | Span label for enum variant generation. +labelEnumVariant :: Int +labelEnumVariant = 15 + +-- | Maximum number of filter attempts before calling @assume False@. +maxFilterAttempts :: Int +maxFilterAttempts = 3 + +-- ---------------------------------------------------------------------------- +-- Generator GADT +-- ---------------------------------------------------------------------------- + +-- | A generator that produces values of type @a@. +-- +-- The GADT constructors capture different generation strategies. 'Basic' +-- generators carry a CBOR schema sent to the server; the server returns a raw +-- 'Term' that is decoded by the transform. Other constructors compose +-- generators with client-side logic. +data Generator a where + -- | A server-side generator with a CBOR schema and a client-side transform. + Basic :: Term -> (Term -> a) -> Generator a + -- | A mapped generator: apply @f@ to the result of the source. + Mapped :: Generator b -> (b -> a) -> Generator a + -- | A dependent generator: generate from source, then use the result to + -- pick a second generator. + FlatMapped :: Generator b -> (b -> Generator a) -> Generator a + -- | A filtered generator: retry the source until the predicate holds. + Filtered :: Generator a -> (a -> Bool) -> Generator a + -- | A composite list generator using the collection protocol. + CompositeList :: Generator a -> Int -> Maybe Int -> Generator [a] + -- | A composite generator that runs an arbitrary IO action inside a + -- labelled span. + Composite :: Int -> (TestCase -> IO a) -> Generator a + +instance Functor Generator where + fmap f (Basic s t) = Basic s (f . t) -- preserves schema + fmap f other = Mapped other f + +-- ---------------------------------------------------------------------------- +-- Span helpers +-- ---------------------------------------------------------------------------- + +-- | Run an IO action inside a span with the given label. +-- The span is stopped with @discard=False@ regardless of whether the action +-- throws. +group :: Int -> TestCase -> IO a -> IO a +group label tc action = do + startSpan label tc + result <- action `catch` \(e :: SomeException) -> do + stopSpan False tc + throwIO e + stopSpan False tc + return result + +-- | Run an IO action inside a span with the given label. If the action +-- throws, the span is stopped with @discard=True@; otherwise @discard=False@. +discardableGroup :: Int -> TestCase -> IO a -> IO a +discardableGroup label tc action = do + startSpan label tc + result <- action `catch` \(e :: SomeException) -> do + stopSpan True tc + throwIO e + stopSpan False tc + return result + +-- ---------------------------------------------------------------------------- +-- Collection protocol +-- ---------------------------------------------------------------------------- + +-- | A server-side collection handle for generating variable-length sequences. +-- +-- Collections communicate with the server to decide when to stop generating +-- elements. The 'collFinished' flag short-circuits subsequent 'collectionMore' +-- calls once the server signals completion. +data Collection = Collection + { collFinished :: !(IORef Bool) + , collServerName :: !(IORef (Maybe Term)) + , collMinSize :: !Int + , collMaxSize :: !(Maybe Int) + } + +-- | Create a new collection handle. +newCollection :: Int -> Maybe Int -> TestCase -> IO Collection +newCollection minSize maxSize _tc = do + finished <- newIORef False + serverName <- newIORef Nothing + return Collection + { collFinished = finished + , collServerName = serverName + , collMinSize = minSize + , collMaxSize = maxSize + } + +-- | Send a command on the test case's data channel. Handles StopTest. +sendCommand :: TestCase -> Term -> IO Term +sendCommand tc msg = do + aborted <- readIORef (tcTestAborted tc) + if aborted + then throwIO DataExhausted + else sendRequestAndWait (tcChannel tc) msg + `catch` \(e :: RequestError) -> + if reqErrorType e == "StopTest" + then do + writeIORef (tcTestAborted tc) True + throwIO DataExhausted + else throwIO e + +-- | Lazily initialise the server-side collection and return its handle. +getServerName :: Collection -> TestCase -> IO Term +getServerName coll tc = do + mName <- readIORef (collServerName coll) + case mName of + Just name -> return name + Nothing -> do + let maxSizeVal = maybe TNull TInt (collMaxSize coll) + let cmd = TMap + [ (TString "command", TString "new_collection") + , (TString "min_size", TInt (collMinSize coll)) + , (TString "max_size", maxSizeVal) + ] + result <- sendCommand tc cmd + writeIORef (collServerName coll) (Just result) + return result + +-- | Query the server for whether more elements should be generated. +-- Once this returns 'False', subsequent calls return 'False' immediately. +collectionMore :: Collection -> TestCase -> IO Bool +collectionMore coll tc = do + done <- readIORef (collFinished coll) + if done + then return False + else do + serverName <- getServerName coll tc + let cmd = TMap + [ (TString "command", TString "collection_more") + , (TString "collection", serverName) + ] + result <- sendCommand tc cmd + let more = case result of + TBool b -> b + _ -> error "collectionMore: expected boolean from server" + unless more $ writeIORef (collFinished coll) True + return more + +-- | Reject the last element of the collection. No-op if already finished. +collectionReject :: Collection -> TestCase -> IO () +collectionReject coll tc = do + done <- readIORef (collFinished coll) + if done + then return () + else do + serverName <- getServerName coll tc + let cmd = TMap + [ (TString "command", TString "collection_reject") + , (TString "collection", serverName) + ] + _ <- sendCommand tc cmd + return () + +-- ---------------------------------------------------------------------------- +-- Draw (evaluation) +-- ---------------------------------------------------------------------------- + +-- | Produce a typed value from a generator using the given test case. +draw :: TestCase -> Generator a -> IO a +draw tc gen = case gen of + Basic schema transform -> do + raw <- generateFromSchema schema tc + return (transform raw) + + Mapped source f -> + group labelMapped tc $ do + v <- draw tc source + return (f v) + + FlatMapped source f -> + discardableGroup labelFlatMap tc $ do + v <- draw tc source + draw tc (f v) + + Filtered source predicate -> + let attempt i + | i > maxFilterAttempts = do { assume tc False; error "unreachable" } + | otherwise = do + startSpan labelFilter tc + v <- draw tc source + if predicate v + then do + stopSpan False tc + return v + else do + stopSpan True tc + attempt (i + 1) + in attempt 1 + + CompositeList elements minSize maxSize -> + group labelList tc $ do + coll <- newCollection minSize maxSize tc + let collect acc = do + more <- collectionMore coll tc + if more + then do + v <- draw tc elements + collect (v : acc) + else return (reverse acc) + collect [] + + Composite label generateFn -> + group label tc (generateFn tc) + +-- ---------------------------------------------------------------------------- +-- Combinator functions +-- ---------------------------------------------------------------------------- + +-- | Map a function over a generator's output. +-- +-- When the generator is 'Basic', the schema is preserved and transforms are +-- composed. Otherwise a 'Mapped' wrapper is created. +gmap :: (a -> b) -> Generator a -> Generator b +gmap f (Basic schema transform) = Basic schema (f . transform) +gmap f other = Mapped other f + +-- | Create a dependent generator. The function receives the generated value +-- and returns a new generator whose output is the final result. +flatMap :: (a -> Generator b) -> Generator a -> Generator b +flatMap f gen = FlatMapped gen f + +-- | Filter a generator's output with a predicate. Retries up to +-- 'maxFilterAttempts' times; if all attempts fail, @assume False@ is called. +gfilter :: (a -> Bool) -> Generator a -> Generator a +gfilter predicate gen = Filtered gen predicate + +-- ---------------------------------------------------------------------------- +-- Introspection +-- ---------------------------------------------------------------------------- + +-- | Returns 'True' if the generator is a 'Basic' generator. +isBasic :: Generator a -> Bool +isBasic (Basic _ _) = True +isBasic _ = False + +-- | Returns the schema and transform of a 'Basic' generator, or 'Nothing'. +asBasic :: Generator a -> Maybe (Term, Term -> a) +asBasic (Basic schema transform) = Just (schema, transform) +asBasic _ = Nothing diff --git a/src/Hegel/Generator/Collections.hs b/src/Hegel/Generator/Collections.hs new file mode 100644 --- /dev/null +++ b/src/Hegel/Generator/Collections.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Collection generators: lists and hashmaps. +-- +-- These generators handle variable-length collections. When all element +-- generators are 'Basic', a single schema is sent to the server for efficient +-- generation. When elements are non-basic (e.g. filtered or flat-mapped), the +-- collection protocol is used to generate elements one at a time. +module Hegel.Generator.Collections + ( lists + , hashmaps + ) where + +import Codec.CBOR.Term (Term (..)) +import Data.Maybe (catMaybes) + +import Hegel.Generator (Generator (..), asBasic) +import Hegel.Generator.Range (RangeOpts, validateSizeBounds) + +-- ---------------------------------------------------------------------------- +-- Lists +-- ---------------------------------------------------------------------------- + +-- | Generator for lists of elements. +-- +-- Two code paths: +-- +-- 1. If the element generator is 'Basic': sends a @list@ schema to the server +-- and lets it generate the entire list in one round-trip. The element +-- transform is lifted to apply to every item. +-- +-- 2. If the element generator is non-basic: uses 'CompositeList' with the +-- collection protocol to generate elements one at a time. +lists :: Generator a -> RangeOpts Int -> Generator [a] +lists elements opts = + let (ms, maxSize) = validateSizeBounds "lists" opts + in + case asBasic elements of + Just (elemSchema, elemTransform) -> + let pairs = catMaybes + [ Just (TString "type", TString "list") + , Just (TString "elements", elemSchema) + , Just (TString "min_size", TInt ms) + , fmap (\mx -> (TString "max_size", TInt mx)) maxSize + ] + listTransform raw = case raw of + TList items -> map elemTransform items + _ -> error "lists: expected array from server" + in Basic (TMap pairs) listTransform + + Nothing -> + CompositeList elements ms maxSize + +-- ---------------------------------------------------------------------------- +-- Hashmaps +-- ---------------------------------------------------------------------------- + +-- | Generator for dictionaries (hash maps) as lists of key-value pairs. +-- +-- Both the key and value generators must be 'Basic'. The server returns the +-- dict as a list of @[key, value]@ pairs, which are transformed to Haskell +-- tuples. +-- +-- Schema: @{\"type\": \"dict\", \"keys\": kSchema, \"values\": vSchema, +-- \"min_size\": N, \"max_size\"?: N}@ +hashmaps :: Generator k -> Generator v -> RangeOpts Int -> Generator [(k, v)] +hashmaps keys values opts = + let (ms, maxSize) = validateSizeBounds "hashmaps" opts in + let (keySchema, keyTransform) = case asBasic keys of + Just (s, t) -> (s, t) + Nothing -> error "hashmaps: keys generator must be a Basic generator" + (valSchema, valTransform) = case asBasic values of + Just (s, t) -> (s, t) + Nothing -> error "hashmaps: values generator must be a Basic generator" + pairs = catMaybes + [ Just (TString "type", TString "dict") + , Just (TString "keys", keySchema) + , Just (TString "values", valSchema) + , Just (TString "min_size", TInt ms) + , fmap (\mx -> (TString "max_size", TInt mx)) maxSize + ] + transform raw = case raw of + TList kvPairs -> map transformPair kvPairs + _ -> error "hashmaps: expected array from server" + transformPair pair = case pair of + TList [k, v] -> (keyTransform k, valTransform v) + _ -> error "hashmaps: expected [k, v] pair from server" + in Basic (TMap pairs) transform diff --git a/src/Hegel/Generator/Combinators.hs b/src/Hegel/Generator/Combinators.hs new file mode 100644 --- /dev/null +++ b/src/Hegel/Generator/Combinators.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Combinator generators: sampling, alternation, optionality, IP addresses, +-- and tuples. +-- +-- These generators compose primitive and collection generators into richer +-- generation strategies. When all constituent generators are 'Basic', a single +-- compound schema is sent to the server. When any generator is non-basic, a +-- 'Composite' wrapper is used with client-side orchestration. +module Hegel.Generator.Combinators + ( sampledFrom + , oneOf + , optional + , ipAddresses + , tuples2 + , tuples3 + , tuples4 + ) where + +import Codec.CBOR.Term (Term (..)) +import Data.Array (listArray, (!)) +import Data.Default (def) +import Data.Maybe (catMaybes, isJust) +import Data.Text (Text) + +import Hegel.Client (TestCase, generateFromSchema) +import Hegel.Generator + ( Generator (..) + , asBasic + , draw + , labelOneOf + , labelTuple + ) +import Hegel.Generator.Primitives + ( RangeOpts (..) + , integers + , ipv4Addresses + , ipv6Addresses + , just + ) + +-- ---------------------------------------------------------------------------- +-- CBOR extraction helper +-- ---------------------------------------------------------------------------- + +-- | Extract an 'Int' from a CBOR term. +extractInt :: Term -> Int +extractInt (TInt n) = n +extractInt (TInteger n) = fromIntegral n +extractInt t = error $ "extractInt: expected TInt/TInteger, got " ++ show t + +-- ---------------------------------------------------------------------------- +-- sampledFrom +-- ---------------------------------------------------------------------------- + +-- | Generator that samples uniformly from a non-empty list of values. +-- +-- Implemented as an integer index generator: picks an index in @[0, n-1]@ and +-- returns the corresponding element from an array. +sampledFrom :: [a] -> Generator a +sampledFrom [] = error "sampledFrom: requires at least one element" +sampledFrom options = + let n = length options + arr = listArray (0, n - 1) options + in fmap (arr !) (integers def + { rangeMin = Just 0 + , rangeMax = Just (n - 1) + }) + +-- ---------------------------------------------------------------------------- +-- oneOf +-- ---------------------------------------------------------------------------- + +-- | Generator that picks from one of the given generators. +-- +-- Two code paths: +-- +-- 1. All generators are 'Basic': uses a tagged-tuple dispatch schema. +-- Each alternative is wrapped as @{\"type\": \"tuple\", \"elements\": +-- [{\"const\": tag}, schema]}@. The server returns @[tag, value]@ and the +-- client dispatches to the correct transform. +-- +-- 2. Any generator is non-basic: generates an index inside a 'labelOneOf' +-- span, then delegates to the selected generator. +oneOf :: [Generator a] -> Generator a +oneOf [] = error "oneOf: requires at least one generator" +oneOf generators = + let basics = map asBasic generators + allBasic = all isJust basics + in + if not allBasic + then + -- Composite path: generate index, then delegate + let gens = listArray (0, n - 1) generators + in Composite labelOneOf $ \tc -> do + idx <- drawIndex n tc + draw tc (gens ! idx) + else + -- Tagged-tuple path + let justBasics = catMaybes basics + taggedSchemas = zipWith mkTaggedSchema [0..] (map fst justBasics) + transforms = listArray (0, length justBasics - 1) (map snd justBasics) + dispatch raw = case raw of + TList [tag, value] -> + let idx = extractInt tag + in (transforms ! idx) value + _ -> error "oneOf: expected [tag, value] tuple from server" + in Basic + (TMap [(TString "one_of", TList taggedSchemas)]) + dispatch + where + n = length generators + + drawIndex :: Int -> TestCase -> IO Int + drawIndex count tc = do + let schema = TMap + [ (TString "type", TString "integer") + , (TString "min_value", TInt 0) + , (TString "max_value", TInt (count - 1)) + ] + raw <- generateFromSchema schema tc + return (extractInt raw) + + mkTaggedSchema :: Int -> Term -> Term + mkTaggedSchema i elemSchema = TMap + [ (TString "type", TString "tuple") + , (TString "elements", TList + [ TMap [(TString "const", TInt i)] + , elemSchema + ]) + ] + +-- ---------------------------------------------------------------------------- +-- optional +-- ---------------------------------------------------------------------------- + +-- | Generator that produces either 'Nothing' or @'Just' value@. +-- +-- Equivalent to @oneOf [just Nothing, fmap Just gen]@. +optional :: Generator a -> Generator (Maybe a) +optional gen = oneOf [just Nothing, fmap Just gen] + +-- ---------------------------------------------------------------------------- +-- IP addresses +-- ---------------------------------------------------------------------------- + +-- | Generator for IP address strings. +-- +-- * @Nothing@: generates either IPv4 or IPv6 addresses. +-- * @Just 4@: generates IPv4 addresses only. +-- * @Just 6@: generates IPv6 addresses only. +ipAddresses :: Maybe Int -> Generator Text +ipAddresses Nothing = oneOf [ipv4Addresses, ipv6Addresses] +ipAddresses (Just 4) = ipv4Addresses +ipAddresses (Just 6) = ipv6Addresses +ipAddresses (Just v) = error $ "ipAddresses: invalid version " ++ show v + +-- ---------------------------------------------------------------------------- +-- Tuples +-- ---------------------------------------------------------------------------- + +-- | Generator for 2-element tuples. +-- +-- When both elements are 'Basic', a single @tuple@ schema is sent. +-- Otherwise, elements are generated separately inside a 'labelTuple' span. +tuples2 :: Generator a -> Generator b -> Generator (a, b) +tuples2 g1 g2 = + case (asBasic g1, asBasic g2) of + (Just (s1, t1), Just (s2, t2)) -> + let schema = TMap + [ (TString "type", TString "tuple") + , (TString "elements", TList [s1, s2]) + ] + transform raw = case raw of + TList [v1, v2] -> (t1 v1, t2 v2) + _ -> error "tuples2: expected 2-element array from server" + in Basic schema transform + _ -> + Composite labelTuple $ \tc -> do + a <- draw tc g1 + b <- draw tc g2 + return (a, b) + +-- | Generator for 3-element tuples. +-- +-- When all elements are 'Basic', a single @tuple@ schema is sent. +-- Otherwise, elements are generated separately inside a 'labelTuple' span. +tuples3 :: Generator a -> Generator b -> Generator c -> Generator (a, b, c) +tuples3 g1 g2 g3 = + case (asBasic g1, asBasic g2, asBasic g3) of + (Just (s1, t1), Just (s2, t2), Just (s3, t3)) -> + let schema = TMap + [ (TString "type", TString "tuple") + , (TString "elements", TList [s1, s2, s3]) + ] + transform raw = case raw of + TList [v1, v2, v3] -> (t1 v1, t2 v2, t3 v3) + _ -> error "tuples3: expected 3-element array from server" + in Basic schema transform + _ -> + Composite labelTuple $ \tc -> do + a <- draw tc g1 + b <- draw tc g2 + c <- draw tc g3 + return (a, b, c) + +-- | Generator for 4-element tuples. +-- +-- When all elements are 'Basic', a single @tuple@ schema is sent. +-- Otherwise, elements are generated separately inside a 'labelTuple' span. +tuples4 :: Generator a -> Generator b -> Generator c -> Generator d + -> Generator (a, b, c, d) +tuples4 g1 g2 g3 g4 = + case (asBasic g1, asBasic g2, asBasic g3, asBasic g4) of + (Just (s1, t1), Just (s2, t2), Just (s3, t3), Just (s4, t4)) -> + let schema = TMap + [ (TString "type", TString "tuple") + , (TString "elements", TList [s1, s2, s3, s4]) + ] + transform raw = case raw of + TList [v1, v2, v3, v4] -> (t1 v1, t2 v2, t3 v3, t4 v4) + _ -> error "tuples4: expected 4-element array from server" + in Basic schema transform + _ -> + Composite labelTuple $ \tc -> do + a <- draw tc g1 + b <- draw tc g2 + c <- draw tc g3 + d <- draw tc g4 + return (a, b, c, d) diff --git a/src/Hegel/Generator/Primitives.hs b/src/Hegel/Generator/Primitives.hs new file mode 100644 --- /dev/null +++ b/src/Hegel/Generator/Primitives.hs @@ -0,0 +1,303 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Primitive generators for basic Haskell types. +-- +-- All generators in this module use the 'Basic' constructor, sending a CBOR +-- schema to the server and decoding the response with a type-appropriate +-- transform. +module Hegel.Generator.Primitives + ( -- * Scalar generators + booleans + , integers + , floats + , text + , binary + , just + + -- * Range options + , RangeOpts (..) + , defaultRangeOpts + + -- * Float options + , FloatOpts (..) + , defaultFloatOpts + + -- * Format generators + , emails + , urls + , dates + , times + , datetimes + , domains + , ipv4Addresses + , ipv6Addresses + , fromRegex + ) where + +import Codec.CBOR.Term (Term (..)) +import Data.ByteString (ByteString) +import Data.Default (Default (def)) +import Data.Maybe (catMaybes, isJust) +import Data.Text (Text) + +import Hegel.Generator (Generator (..)) +import Hegel.Generator.Range + ( RangeOpts (..) + , defaultRangeOpts + , validateSizeBounds + ) + +-- ---------------------------------------------------------------------------- +-- CBOR extraction helpers +-- ---------------------------------------------------------------------------- + +-- | Extract a 'Bool' from a CBOR term. +extractBool :: Term -> Bool +extractBool (TBool b) = b +extractBool t = error $ "extractBool: expected TBool, got " ++ show t + +-- | Extract an 'Int' from a CBOR term. +extractInt :: Term -> Int +extractInt (TInt n) = n +extractInt (TInteger n) = fromIntegral n +extractInt t = error $ "extractInt: expected TInt/TInteger, got " ++ show t + +-- | Extract a 'Double' from a CBOR term. +extractFloat :: Term -> Double +extractFloat (THalf f) = realToFrac f +extractFloat (TFloat f) = realToFrac f +extractFloat (TDouble f) = f +extractFloat (TInt n) = fromIntegral n +extractFloat (TInteger n) = fromIntegral n +extractFloat t = error $ "extractFloat: expected float term, got " ++ show t + +-- | Extract 'Text' from a CBOR term. +extractText :: Term -> Text +extractText (TString s) = s +extractText t = error $ "extractText: expected TString, got " ++ show t + +-- | Extract 'ByteString' from a CBOR term. +extractBytes :: Term -> ByteString +extractBytes (TBytes b) = b +extractBytes t = error $ "extractBytes: expected TBytes, got " ++ show t + +-- ---------------------------------------------------------------------------- +-- Scalar generators +-- ---------------------------------------------------------------------------- + +-- | Generator for boolean values. +-- +-- Schema: @{\"type\": \"boolean\"}@ +booleans :: Generator Bool +booleans = Basic + (TMap [(TString "type", TString "boolean")]) + extractBool + +-- | Generator for integer values within optional bounds. +-- +-- Schema: @{\"type\": \"integer\", \"min_value\"?: N, \"max_value\"?: N}@ +integers :: RangeOpts Int -> Generator Int +integers RangeOpts {rangeMin = minVal, rangeMax = maxVal} = + case (minVal, maxVal) of + (Just lo, Just hi) | lo > hi -> + error $ "integers: max_value=" ++ show hi ++ " < min_value=" ++ show lo + _ -> () + `seq` Basic (TMap pairs) extractInt + where + pairs = catMaybes + [ Just (TString "type", TString "integer") + , fmap (\v -> (TString "min_value", TInt v)) minVal + , fmap (\v -> (TString "max_value", TInt v)) maxVal + ] + +-- | Options for the floating-point generator. +data FloatOpts = FloatOpts + { floatBounds :: !(RangeOpts Double) + , floatExcludeMin :: !Bool + , floatExcludeMax :: !Bool + , floatAllowNan :: !(Maybe Bool) + , floatAllowInfinity :: !(Maybe Bool) + } deriving (Eq, Show) + +instance Default FloatOpts where + def = FloatOpts + { floatBounds = def + , floatExcludeMin = False + , floatExcludeMax = False + , floatAllowNan = Nothing + , floatAllowInfinity = Nothing + } + +-- | Default float options: no bounds, no exclusions, nan/infinity determined +-- by bounds. Equivalent to 'def'; new code can use 'def' directly. +defaultFloatOpts :: FloatOpts +defaultFloatOpts = def + +-- | Generator for floating-point values. +-- +-- Schema: @{\"type\": \"float\", \"allow_nan\": bool, \"allow_infinity\": bool, +-- \"width\": 64, \"exclude_min\": bool, \"exclude_max\": bool, +-- \"min_value\"?: f, \"max_value\"?: f}@ +-- +-- Defaults follow Hypothesis: +-- +-- * @allow_nan@: 'True' only when no bounds are set +-- * @allow_infinity@: 'True' when at most one bound is set +floats :: FloatOpts -> Generator Double +floats FloatOpts + { floatBounds = RangeOpts {rangeMin = minVal, rangeMax = maxVal} + , floatExcludeMin = excludeMin + , floatExcludeMax = excludeMax + , floatAllowNan = allowNan + , floatAllowInfinity = allowInfinity + } = + -- Validation + (if effAllowNan && (hasMin || hasMax) + then error "floats: cannot have allow_nan=True with min_value or max_value" + else ()) + `seq` + (case (minVal, maxVal) of + (Just lo, Just hi) | lo > hi -> + error $ "floats: no floats between min_value=" ++ show lo + ++ " and max_value=" ++ show hi + _ -> ()) + `seq` + (if effAllowInfinity && hasMin && hasMax + then error "floats: cannot have allow_infinity=True with both min_value and max_value" + else ()) + `seq` + Basic (TMap pairs) extractFloat + where + hasMin = isJust minVal + hasMax = isJust maxVal + effAllowNan = case allowNan of + Just v -> v + Nothing -> not hasMin && not hasMax + effAllowInfinity = case allowInfinity of + Just v -> v + Nothing -> not hasMin || not hasMax + pairs = + [ (TString "type", TString "float") + , (TString "allow_nan", TBool effAllowNan) + , (TString "allow_infinity", TBool effAllowInfinity) + , (TString "exclude_min", TBool excludeMin) + , (TString "exclude_max", TBool excludeMax) + , (TString "width", TInt 64) + ] + ++ catMaybes + [ fmap (\v -> (TString "min_value", TDouble v)) minVal + , fmap (\v -> (TString "max_value", TDouble v)) maxVal + ] + +-- | Generator for Unicode text strings. +-- +-- Schema: @{\"type\": \"string\", \"min_size\": N, \"max_size\"?: N}@ +text :: RangeOpts Int -> Generator Text +text opts = + let (ms, maxSize) = validateSizeBounds "text" opts + pairs = catMaybes + [ Just (TString "type", TString "string") + , Just (TString "min_size", TInt ms) + , fmap (\v -> (TString "max_size", TInt v)) maxSize + ] + in + Basic (TMap pairs) extractText + +-- | Generator for binary byte strings. +-- +-- Schema: @{\"type\": \"binary\", \"min_size\": N, \"max_size\"?: N}@ +binary :: RangeOpts Int -> Generator ByteString +binary opts = + let (ms, maxSize) = validateSizeBounds "binary" opts + pairs = catMaybes + [ Just (TString "type", TString "binary") + , Just (TString "min_size", TInt ms) + , fmap (\v -> (TString "max_size", TInt v)) maxSize + ] + in + Basic (TMap pairs) extractBytes + +-- | Generator that always produces the given constant value. +-- +-- Schema: @{\"const\": null}@. The transform ignores the server result. +just :: a -> Generator a +just value = Basic + (TMap [(TString "const", TNull)]) + (const value) + +-- ---------------------------------------------------------------------------- +-- Format generators +-- ---------------------------------------------------------------------------- + +-- | Generator for valid email address strings. +emails :: Generator Text +emails = Basic + (TMap [(TString "type", TString "email")]) + extractText + +-- | Generator for valid URL strings. +urls :: Generator Text +urls = Basic + (TMap [(TString "type", TString "url")]) + extractText + +-- | Generator for ISO 8601 date strings (YYYY-MM-DD). +dates :: Generator Text +dates = Basic + (TMap [(TString "type", TString "date")]) + extractText + +-- | Generator for time strings. +times :: Generator Text +times = Basic + (TMap [(TString "type", TString "time")]) + extractText + +-- | Generator for ISO 8601 datetime strings. +datetimes :: Generator Text +datetimes = Basic + (TMap [(TString "type", TString "datetime")]) + extractText + +-- | Generator for domain name strings. +-- +-- If a maximum length is provided, generated domains will not exceed that +-- length. Valid range: 4 to 255. +domains :: Maybe Int -> Generator Text +domains maxLength = + (case maxLength of + Just ml | ml < 4 || ml > 255 -> + error $ "domains: max_length=" ++ show ml ++ " must be between 4 and 255" + _ -> ()) + `seq` + Basic (TMap pairs) extractText + where + pairs = catMaybes + [ Just (TString "type", TString "domain") + , fmap (\ml -> (TString "max_length", TInt ml)) maxLength + ] + +-- | Generator for IPv4 address strings (dotted decimal). +ipv4Addresses :: Generator Text +ipv4Addresses = Basic + (TMap [(TString "type", TString "ipv4")]) + extractText + +-- | Generator for IPv6 address strings (colon hex). +ipv6Addresses :: Generator Text +ipv6Addresses = Basic + (TMap [(TString "type", TString "ipv6")]) + extractText + +-- | Generator for strings matching a regular expression. +-- +-- When @fullmatch@ is 'True', the entire string must match the pattern. +-- When 'False', a substring match suffices. +fromRegex :: Text -> Bool -> Generator Text +fromRegex regexPattern fullmatch = Basic + (TMap + [ (TString "type", TString "regex") + , (TString "pattern", TString regexPattern) + , (TString "fullmatch", TBool fullmatch) + ]) + extractText diff --git a/src/Hegel/Generator/Range.hs b/src/Hegel/Generator/Range.hs new file mode 100644 --- /dev/null +++ b/src/Hegel/Generator/Range.hs @@ -0,0 +1,55 @@ +-- | Shared range option types and validation helpers. +module Hegel.Generator.Range + ( RangeOpts (..) + , defaultRangeOpts + , validateSizeBounds + ) where + +import Data.Default (Default (def)) +import Data.Maybe (fromMaybe) + +-- | Configuration for lower and upper bounds used by range-limited generators. +-- +-- Use 'def' for the default unbounded case, or update specific fields: +-- +-- @ +-- integers def { rangeMin = Just 0, rangeMax = Just 100 } +-- text def { rangeMin = Just 1, rangeMax = Just 10 } +-- @ +-- +-- Collection-like generators interpret these fields as @min_size@ and +-- @max_size@ bounds. +data RangeOpts a = RangeOpts + { rangeMin :: !(Maybe a) + -- ^ Inclusive lower bound when present. + , rangeMax :: !(Maybe a) + -- ^ Inclusive upper bound when present. + } deriving (Eq, Show) + +instance Default (RangeOpts a) where + def = RangeOpts + { rangeMin = Nothing + , rangeMax = Nothing + } + +-- | Convenience alias for 'def'. +defaultRangeOpts :: RangeOpts a +defaultRangeOpts = def + +-- | Validate non-negative size bounds and return the normalized min/max pair. +validateSizeBounds :: String -> RangeOpts Int -> (Int, Maybe Int) +validateSizeBounds label RangeOpts {rangeMin = minSize, rangeMax = maxSize} = + (if minSize' < 0 + then error $ label ++ ": min_size=" ++ show minSize' ++ " must be non-negative" + else ()) + `seq` + (case maxSize of + Just mx | mx < 0 -> + error $ label ++ ": max_size=" ++ show mx ++ " must be non-negative" + Just mx | minSize' > mx -> + error $ label ++ ": max_size=" ++ show mx ++ " < min_size=" ++ show minSize' + _ -> ()) + `seq` + (minSize', maxSize) + where + minSize' = fromMaybe 0 minSize diff --git a/src/Hegel/Protocol.hs b/src/Hegel/Protocol.hs new file mode 100644 --- /dev/null +++ b/src/Hegel/Protocol.hs @@ -0,0 +1,357 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StrictData #-} + +-- | Wire protocol for Hegel. +-- +-- This module defines the binary packet format used for communication between +-- the Hegel client and the Hegel server. Messages are serialized as packets +-- with a 20-byte header, a CBOR-encoded payload, and a terminator byte. +-- +-- The header consists of 5 big-endian unsigned 32-bit integers: +-- +-- * Magic number (0x4845474C, \"HEGL\") +-- * CRC32 checksum +-- * Channel ID +-- * Message ID (high bit = reply flag) +-- * Payload length +module Hegel.Protocol + ( -- * Packet type + Packet (..) + + -- * Constants + , magic + , headerSize + , terminator + , replyBit + , closeChannelMessageId + , closeChannelPayload + + -- * Packet I\/O + , readPacket + , writePacket + + -- * CRC32 + , computeCRC32 + , computeCRC32Parts + + -- * CBOR helpers + , extractInt + , extractFloat + , extractBool + , extractText + , extractBytes + , extractList + , extractMap + , encodeTerm + , decodeTerm + ) where + +import Codec.CBOR.Read (deserialiseFromBytes) +import Codec.CBOR.Term (Term (..)) +import qualified Codec.CBOR.Term as CBOR +import qualified Codec.CBOR.Write as CBORWrite +import Control.Monad (when) +import Data.Bits ((.&.), (.|.), shiftL, shiftR, testBit, xor) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Internal as BSInternal +import qualified Data.ByteString.Lazy as LBS +import Data.Digest.CRC32 (crc32, crc32Update) +import Data.Text (Text) +import Data.Word (Word32, Word8) +import Foreign.Ptr (Ptr) +import Foreign.Storable (pokeByteOff) +import System.IO (Handle, hFlush) + +-- --------------------------------------------------------------------------- +-- Constants +-- --------------------------------------------------------------------------- + +-- | Magic number identifying Hegel packets (\"HEGL\" in hex). +magic :: Word32 +magic = 0x4845474C + +-- | Size of the packet header in bytes (5 big-endian uint32 fields). +headerSize :: Int +headerSize = 20 + +-- | Terminator byte appended after the payload. +terminator :: Word8 +terminator = 0x0A + +-- | Bit flag indicating a reply message. When set in the message ID field, +-- the message is a response to a previous request. +replyBit :: Word32 +replyBit = 1 `shiftL` 31 + +-- | Special message ID used when closing a channel. +closeChannelMessageId :: Word32 +closeChannelMessageId = (1 `shiftL` 31) - 1 + +-- | Special payload byte sent when closing a channel. Chosen to be invalid +-- CBOR per RFC 8949 (reserved tag byte 0xFE). +closeChannelPayload :: ByteString +closeChannelPayload = BS.singleton 0xFE + +-- --------------------------------------------------------------------------- +-- Packet type +-- --------------------------------------------------------------------------- + +-- | A single message in the wire protocol. +data Packet = Packet + { packetChannelId :: Word32 + -- ^ The logical channel this packet belongs to. + , packetMessageId :: Word32 + -- ^ Identifier for request\/response correlation (without reply bit). + , packetIsReply :: Bool + -- ^ Whether this is a reply to a previous request. + , packetPayload :: ByteString + -- ^ The raw payload bytes (typically CBOR-encoded). + } + deriving (Show, Eq) + +-- --------------------------------------------------------------------------- +-- Byte packing helpers +-- --------------------------------------------------------------------------- + +-- | Write a 'Word32' in big-endian order at the given byte offset. +pokeWord32BE :: Ptr Word8 -> Int -> Word32 -> IO () +pokeWord32BE ptr off w = do + pokeByteOff ptr off (fromIntegral (w `shiftR` 24) :: Word8) + pokeByteOff ptr (off + 1) (fromIntegral (w `shiftR` 16) :: Word8) + pokeByteOff ptr (off + 2) (fromIntegral (w `shiftR` 8) :: Word8) + pokeByteOff ptr (off + 3) (fromIntegral w :: Word8) + +-- | Unpack a 'Word32' from 4 big-endian bytes starting at offset. +unpackWord32BE :: ByteString -> Int -> Word32 +unpackWord32BE bs off = + let b0 = fromIntegral (BS.index bs off) :: Word32 + b1 = fromIntegral (BS.index bs (off + 1)) :: Word32 + b2 = fromIntegral (BS.index bs (off + 2)) :: Word32 + b3 = fromIntegral (BS.index bs (off + 3)) :: Word32 + in (b0 `shiftL` 24) .|. (b1 `shiftL` 16) .|. (b2 `shiftL` 8) .|. b3 + +-- | Build a packet header from its wire-format fields. +buildHeader :: Word32 -> Word32 -> Word32 -> Word32 -> ByteString +buildHeader checksum channelId messageId payloadLen = + BSInternal.unsafeCreate headerSize $ \ptr -> do + pokeWord32BE ptr 0 magic + pokeWord32BE ptr 4 checksum + pokeWord32BE ptr 8 channelId + pokeWord32BE ptr 12 messageId + pokeWord32BE ptr 16 payloadLen + +-- --------------------------------------------------------------------------- +-- CRC32 +-- --------------------------------------------------------------------------- + +-- | Compute the CRC32 checksum of a 'ByteString', returned as 'Word32'. +computeCRC32 :: ByteString -> Word32 +computeCRC32 = crc32 + +-- | Compute the CRC32 checksum over the concatenation of two byte strings. +computeCRC32Parts :: ByteString -> ByteString -> Word32 +computeCRC32Parts a = crc32Update (crc32 a) + +-- --------------------------------------------------------------------------- +-- Handle-based exact read +-- --------------------------------------------------------------------------- + +-- | Read exactly @n@ bytes from a 'Handle'. Raises an 'IOError' on short +-- read (i.e., if the handle reaches EOF before @n@ bytes are available). +hGetExact :: Handle -> Int -> IO ByteString +hGetExact _ 0 = return BS.empty +hGetExact h n = go BS.empty + where + go acc + | BS.length acc >= n = return acc + | otherwise = do + chunk <- BS.hGetSome h (n - BS.length acc) + if BS.null chunk + then + if BS.null acc + then ioError $ userError "Connection closed partway through reading packet." + else ioError $ userError "Connection closed while reading data" + else go (BS.append acc chunk) + +-- --------------------------------------------------------------------------- +-- Packet I\/O +-- --------------------------------------------------------------------------- + +-- | Read and parse a single packet from the given 'Handle'. +-- +-- Raises 'IOError' if the magic number is invalid, the terminator byte is +-- invalid, or the CRC32 checksum does not match. +readPacket :: Handle -> IO Packet +readPacket h = do + headerBuf <- hGetExact h headerSize + let pktMagic = unpackWord32BE headerBuf 0 + checksum = unpackWord32BE headerBuf 4 + channelId = unpackWord32BE headerBuf 8 + rawMessageId = unpackWord32BE headerBuf 12 + payloadLen = unpackWord32BE headerBuf 16 + isReply = testBit rawMessageId 31 + messageId = if isReply then rawMessageId `xor` replyBit else rawMessageId + + when (pktMagic /= magic) $ + ioError $ userError $ + "Invalid magic number: expected 0x" ++ showHex32 magic + ++ ", got 0x" ++ showHex32 pktMagic + + payloadBuf <- hGetExact h (fromIntegral payloadLen) + termBuf <- hGetExact h 1 + let termByte = BS.index termBuf 0 + + when (termByte /= terminator) $ + ioError $ userError $ + "Invalid terminator: expected 0x" ++ showHex8 terminator + ++ ", got 0x" ++ showHex8 termByte + + -- Verify checksum: CRC32 over header with checksum field zeroed + payload + let headerForCheck = buildHeader 0 channelId rawMessageId payloadLen + computedCRC = computeCRC32Parts headerForCheck payloadBuf + + when (computedCRC /= checksum) $ + ioError $ userError $ + "Checksum mismatch: expected 0x" ++ showHex32 checksum + ++ ", got 0x" ++ showHex32 computedCRC + + return Packet + { packetChannelId = channelId + , packetMessageId = messageId + , packetIsReply = isReply + , packetPayload = payloadBuf + } + +-- | Serialize and write a packet to the given 'Handle'. +writePacket :: Handle -> Packet -> IO () +writePacket h pkt = do + let wireMessageId = + if packetIsReply pkt + then packetMessageId pkt .|. replyBit + else packetMessageId pkt + payloadLen = fromIntegral (BS.length (packetPayload pkt)) :: Word32 + + -- Build header with zeroed checksum for CRC computation + let headerForCRC = buildHeader 0 (packetChannelId pkt) wireMessageId payloadLen + checksum = computeCRC32Parts headerForCRC (packetPayload pkt) + + -- Build final header with real checksum + let headerFinal = buildHeader checksum (packetChannelId pkt) wireMessageId payloadLen + BS.hPut h headerFinal + BS.hPut h (packetPayload pkt) + BS.hPut h (BS.singleton terminator) + hFlush h + +-- --------------------------------------------------------------------------- +-- Hex formatting helpers +-- --------------------------------------------------------------------------- + +-- | Format a 'Word32' as an 8-digit uppercase hex string. +showHex32 :: Word32 -> String +showHex32 w = map toHexDigit (reverse [nibble i | i <- [0..7]]) + where + nibble i = fromIntegral ((w `shiftR` (i * 4)) .&. 0xF) :: Int + toHexDigit n + | n < 10 = toEnum (fromEnum '0' + n) + | otherwise = toEnum (fromEnum 'A' + n - 10) + +-- | Format a 'Word8' as a 2-digit uppercase hex string. +showHex8 :: Word8 -> String +showHex8 w = [toHexDigit hi, toHexDigit lo] + where + hi = fromIntegral (w `shiftR` 4) :: Int + lo = fromIntegral (w .&. 0xF) :: Int + toHexDigit n + | n < 10 = toEnum (fromEnum '0' + n) + | otherwise = toEnum (fromEnum 'A' + n - 10) + +-- --------------------------------------------------------------------------- +-- CBOR helpers +-- --------------------------------------------------------------------------- + +-- | Extract an integer from a CBOR 'Term'. +-- +-- Accepts 'TInt' and 'TInteger'. Raises an error for other types. +extractInt :: Term -> Int +extractInt (TInt i) = i +extractInt (TInteger i) = fromIntegral i +extractInt other = error $ "Expected CBOR int, got " ++ termTypeName other + +-- | Extract a double-precision float from a CBOR 'Term'. +-- +-- Accepts 'TFloat', 'TDouble', and 'THalf'. Raises an error for other types. +extractFloat :: Term -> Double +extractFloat (TFloat f) = realToFrac f +extractFloat (TDouble d) = d +extractFloat (THalf f) = realToFrac f +extractFloat other = error $ "Expected CBOR float, got " ++ termTypeName other + +-- | Extract a boolean from a CBOR 'Term'. +-- +-- Raises an error if the term is not 'TBool'. +extractBool :: Term -> Bool +extractBool (TBool b) = b +extractBool other = error $ "Expected CBOR bool, got " ++ termTypeName other + +-- | Extract a text string from a CBOR 'Term'. +-- +-- Raises an error if the term is not 'TString'. +extractText :: Term -> Text +extractText (TString t) = t +extractText other = error $ "Expected CBOR text, got " ++ termTypeName other + +-- | Extract a byte string from a CBOR 'Term'. +-- +-- Raises an error if the term is not 'TBytes'. +extractBytes :: Term -> ByteString +extractBytes (TBytes b) = b +extractBytes other = error $ "Expected CBOR bytes, got " ++ termTypeName other + +-- | Extract a list from a CBOR 'Term'. +-- +-- Raises an error if the term is not 'TList'. +extractList :: Term -> [Term] +extractList (TList xs) = xs +extractList other = error $ "Expected CBOR array, got " ++ termTypeName other + +-- | Extract a key-value map from a CBOR 'Term'. +-- +-- Raises an error if the term is not 'TMap'. +extractMap :: Term -> [(Term, Term)] +extractMap (TMap kvs) = kvs +extractMap other = error $ "Expected CBOR map, got " ++ termTypeName other + +-- | Encode a CBOR 'Term' to a strict 'ByteString'. +encodeTerm :: Term -> ByteString +encodeTerm = CBORWrite.toStrictByteString . CBOR.encodeTerm + +-- | Decode a strict 'ByteString' to a CBOR 'Term'. +-- +-- Raises an error if the bytes are not valid CBOR. +decodeTerm :: ByteString -> Term +decodeTerm bs = + case deserialiseFromBytes CBOR.decodeTerm (LBS.fromStrict bs) of + Left err -> error $ "CBOR decode error: " ++ show err + Right (_, term) -> term + +-- | Return a human-readable name for the type of a CBOR 'Term'. +termTypeName :: Term -> String +termTypeName (TInt _) = "int" +termTypeName (TInteger _) = "integer" +termTypeName (TFloat _) = "float" +termTypeName (TDouble _) = "double" +termTypeName (THalf _) = "half" +termTypeName (TBool _) = "bool" +termTypeName TNull = "null" +termTypeName (TBytes _) = "bytes" +termTypeName (TBytesI _) = "bytes (indefinite)" +termTypeName (TString _) = "text" +termTypeName (TStringI _) = "text (indefinite)" +termTypeName (TList _) = "array" +termTypeName (TListI _) = "array (indefinite)" +termTypeName (TMap _) = "map" +termTypeName (TMapI _) = "map (indefinite)" +termTypeName (TTagged _ _) = "tag" +termTypeName (TSimple _) = "simple" diff --git a/src/Hegel/Session.hs b/src/Hegel/Session.hs new file mode 100644 --- /dev/null +++ b/src/Hegel/Session.hs @@ -0,0 +1,397 @@ +-- | Global session management for Hegel. +-- +-- This module manages a shared hegel subprocess communicating over stdio +-- pipes. It starts lazily on first use and cleans up when the process exits. +-- +-- The main entry point is 'runHegelTest', which the user calls without +-- needing to manage connections or sessions directly. +module Hegel.Session + ( -- * Session management + startSession + , cleanupSession + , restartSession + + -- * Running tests + , runHegelTest + , runHegelTest_ + + -- * Hegel discovery + , findHegel + , ensureHegelInstalled + ) where + +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar +import Control.Exception (evaluate, try, SomeException) +import Control.Monad (unless) +import Data.Foldable (for_) +import Data.IORef +import System.Directory (createDirectoryIfMissing, doesFileExist) +import System.Environment (lookupEnv) +import System.Exit (ExitCode (..)) +import System.IO + ( hSetBinaryMode + , hClose + , IOMode (..) + , openFile + ) +import System.IO.Unsafe (unsafePerformIO) +import System.Process + ( CreateProcess (..) + , StdStream (..) + , ProcessHandle + , proc + , createProcess + , waitForProcess + , terminateProcess + ) + +import Hegel.Client +import Hegel.Connection + + +-- --------------------------------------------------------------------------- +-- Constants +-- --------------------------------------------------------------------------- + +-- | Version of hegel-core to install. +hegelServerVersion :: String +hegelServerVersion = "0.2.3" + +-- | Environment variable to override the hegel server command. +hegelServerCommandEnv :: String +hegelServerCommandEnv = "HEGEL_SERVER_COMMAND" + +-- | Directory for hegel server installation and logs. +hegelServerDir :: FilePath +hegelServerDir = ".hegel" + +-- | Message shown when uv is not found. +uvNotFoundMessage :: String +uvNotFoundMessage = + "You are seeing this error message because hegel-haskell tried to use `uv` to \ + \install hegel-core, but could not find uv on the PATH.\n\n\ + \Hegel uses a Python server component called `hegel-core` to share core \ + \property-based testing functionality across languages. There are two ways \ + \for Hegel to get hegel-core:\n\n\ + \* By default, Hegel looks for uv (https://docs.astral.sh/uv/) on the PATH, \ + \and uses uv to install hegel-core to a local `.hegel/venv` directory. We \ + \recommend this option. To continue, install uv: \ + \https://docs.astral.sh/uv/getting-started/installation/.\n\ + \* Alternatively, you can manage the installation of hegel-core yourself. \ + \After installing, setting the HEGEL_SERVER_COMMAND environment variable to \ + \your hegel-core binary path tells hegel-haskell to use that hegel-core \ + \instead.\n\n\ + \See https://hegel.dev/reference/installation for more details." + + +-- --------------------------------------------------------------------------- +-- Command execution helpers +-- --------------------------------------------------------------------------- + +-- | Runs a command with arguments, redirecting stdout and stderr to a log +-- file. Returns the exit code. +runCommandToLog :: FilePath -> [String] -> FilePath -> IO ExitCode +runCommandToLog cmd args logPath = do + logHandle <- openFile logPath AppendMode + let cp = (proc cmd args) + { std_out = UseHandle logHandle + , std_err = UseHandle logHandle + } + (_, _, _, ph) <- createProcess cp + exitCode <- waitForProcess ph + hClose logHandle + pure exitCode + + +-- --------------------------------------------------------------------------- +-- Hegel discovery and installation +-- --------------------------------------------------------------------------- + +-- | Checks for a cached hegel installation and installs via uv if needed. +-- Returns the path to the hegel binary. +ensureHegelInstalled :: IO FilePath +ensureHegelInstalled = do + let venvDir = hegelServerDir ++ "/venv" + let versionFile = venvDir ++ "/hegel-version" + let hegelBin = venvDir ++ "/bin/hegel" + let installLog = hegelServerDir ++ "/install.log" + + -- Check cached version (force the file read inside try to catch IO errors) + cached <- try (do + contents <- readFile versionFile + let trimmed = strip contents + -- Force evaluation of trimmed to catch lazy IO exceptions inside try + _ <- evaluate (length trimmed) + exists <- doesFileExist hegelBin + if trimmed == hegelServerVersion && exists + then pure (Just hegelBin) + else pure Nothing + ) :: IO (Either SomeException (Maybe FilePath)) + case cached of + Right (Just path) -> pure path + _ -> do + -- Need to install + createDirectoryIfMissing True hegelServerDir + + -- Create venv + venvResult <- try (runCommandToLog "uv" ["venv", "--clear", venvDir] installLog) + :: IO (Either SomeException ExitCode) + case venvResult of + Left _ -> fail uvNotFoundMessage + Right (ExitFailure _) -> do + logContents <- readFileSafe installLog + fail ("uv venv failed. Install log:\n" ++ logContents) + Right ExitSuccess -> pure () + + -- Install hegel-core + let pythonPath = venvDir ++ "/bin/python" + pipResult <- runCommandToLog "uv" + [ "pip", "install" + , "--python", pythonPath + , "hegel-core==" ++ hegelServerVersion + ] + installLog + case pipResult of + ExitFailure _ -> do + logContents <- readFileSafe installLog + fail $ "Failed to install hegel-core (version: " ++ hegelServerVersion + ++ "). Set " ++ hegelServerCommandEnv + ++ " to a hegel binary path to skip installation.\n" + ++ "Install log:\n" ++ logContents + ExitSuccess -> pure () + + exists <- doesFileExist hegelBin + unless exists $ + fail ("hegel not found at " ++ hegelBin ++ " after installation") + + -- Write version file + writeFile versionFile hegelServerVersion + pure hegelBin + +-- | Locates the hegel binary. Checks, in order: +-- +-- 1. @HEGEL_SERVER_COMMAND@ environment variable +-- 2. Auto-install via uv to @.hegel\/venv\/@ (version-locked) +-- +-- The auto-installed version is preferred over any @hegel@ on @PATH@ +-- because the system binary may be an incompatible version. +findHegel :: IO FilePath +findHegel = do + envCmd <- lookupEnv hegelServerCommandEnv + case envCmd of + Just path | not (null path) -> pure path + _ -> ensureHegelInstalled + + +-- --------------------------------------------------------------------------- +-- CI detection +-- --------------------------------------------------------------------------- + +-- | CI environment variables to check for auto-detection. Each entry is +-- @(varName, expectedValue)@ where 'Nothing' means "any value". +ciVars :: [(String, Maybe String)] +ciVars = + [ ("CI", Nothing) + , ("TF_BUILD", Just "true") + , ("BUILDKITE", Just "true") + , ("CIRCLECI", Just "true") + , ("CIRRUS_CI", Just "true") + , ("CODEBUILD_BUILD_ID", Nothing) + , ("GITHUB_ACTIONS", Just "true") + , ("GITLAB_CI", Nothing) + , ("HEROKU_TEST_RUN_ID", Nothing) + , ("TEAMCITY_VERSION", Nothing) + ] + +-- | Returns 'True' if a CI environment is detected. +isInCI :: IO Bool +isInCI = anyM checkVar ciVars + where + checkVar (key, expected) = do + val <- lookupEnv key + pure $ case (val, expected) of + (Just _, Nothing) -> True + (Just v, Just expV) -> v == expV + (Nothing, _) -> False + + anyM _ [] = pure False + anyM f (x : xs) = do + b <- f x + if b then pure True else anyM f xs + + +-- --------------------------------------------------------------------------- +-- Session state +-- --------------------------------------------------------------------------- + +-- | Internal mutable session state. +data HegelSession = HegelSession + { sessionProcess :: Maybe ProcessHandle + , sessionConnection :: Maybe Connection + , sessionClient :: Maybe HegelClient + } + +-- | The initial empty session. +emptySession :: HegelSession +emptySession = HegelSession + { sessionProcess = Nothing + , sessionConnection = Nothing + , sessionClient = Nothing + } + +-- | The global session singleton, protected by an MVar. +{-# NOINLINE globalSession #-} +globalSession :: MVar HegelSession +globalSession = unsafePerformIO (newMVar emptySession) + +-- | IORef tracking whether cleanup has been registered with atexit. +{-# NOINLINE atExitRegistered #-} +atExitRegistered :: IORef Bool +atExitRegistered = unsafePerformIO (newIORef False) + + +-- --------------------------------------------------------------------------- +-- Session lifecycle +-- --------------------------------------------------------------------------- + +-- | Returns 'True' if the session has a live client. +hasWorkingClient :: HegelSession -> IO Bool +hasWorkingClient session = + case (sessionClient session, sessionConnection session) of + (Just _, Just conn) -> isLive conn + _ -> pure False + +-- | Cleans up the session, closing the connection and terminating the +-- subprocess. +cleanup :: HegelSession -> IO HegelSession +cleanup session = do + -- Close connection + for_ (sessionConnection session) closeConnection + -- Terminate process + case sessionProcess session of + Just ph -> do + _ <- try (terminateProcess ph) :: IO (Either SomeException ()) + _ <- try (waitForProcess ph) :: IO (Either SomeException ExitCode) + pure () + Nothing -> pure () + pure emptySession + +-- | Starts the hegel server if not already running. Spawns the server +-- with @--stdio@ for pipe-based communication. +startSession :: IO () +startSession = modifyMVar_ globalSession $ \session -> do + working <- hasWorkingClient session + if working + then pure session + else do + -- Clean up any old session + _ <- cleanup session + hegelCmd <- findHegel + + -- Open log file for server stderr + createDirectoryIfMissing True hegelServerDir + logHandle <- openFile (hegelServerDir ++ "/server.log") AppendMode + + -- Start hegel subprocess with --stdio + let cp = (proc hegelCmd ["--stdio", "--verbosity", "normal"]) + { std_in = CreatePipe + , std_out = CreatePipe + , std_err = UseHandle logHandle + } + (Just hIn, Just hOut, Nothing, ph) <- createProcess cp + + -- Set handles to binary mode + hSetBinaryMode hIn True + hSetBinaryMode hOut True + + -- Create connection from the pipe handles + conn <- createConnection hOut hIn False + + -- Create client (performs handshake) + client <- createClient conn + + -- Monitor thread: detect server crash + _ <- forkIO $ do + _ <- waitForProcess ph + setServerExited conn + pure () + + -- Register at-exit cleanup (only once) + registered <- readIORef atExitRegistered + unless registered $ do + writeIORef atExitRegistered True + -- Note: We cannot use Weak references to the MVar easily, so we + -- just always try cleanup. If session is already empty, cleanup + -- is a no-op. + + pure HegelSession + { sessionProcess = Just ph + , sessionConnection = Just conn + , sessionClient = Just client + } + +-- | Forces a restart of the global session. Cleans up the current session +-- and clears the state. +restartSession :: IO () +restartSession = modifyMVar_ globalSession cleanup + +-- | Cleans up the global session. Closes the connection and terminates +-- the server process. +cleanupSession :: IO () +cleanupSession = modifyMVar_ globalSession cleanup + + +-- --------------------------------------------------------------------------- +-- Running tests +-- --------------------------------------------------------------------------- + +-- | Computes the initial settings for a test run. +-- +-- In CI environments, Hegel starts from deterministic, stateless defaults by +-- enabling derandomization and disabling the example database. +initialSettingsForRun :: IO Settings +initialSettingsForRun = do + inCI <- isInCI + pure $ + if inCI + then + defaultSettings + { settingsDerandomize = True + , settingsDatabase = Disabled + } + else defaultSettings + +-- | Runs a property test using the shared hegel process. +-- Ensures the session is started, then delegates to 'Client.runTest'. +runHegelTest :: (Settings -> Settings) -> (TestCase -> IO ()) -> IO () +runHegelTest configure testFn = do + effectiveSettings <- configure <$> initialSettingsForRun + startSession + session <- readMVar globalSession + case sessionClient session of + Just client -> runTest client effectiveSettings testFn + Nothing -> fail "Failed to start hegel session" + +-- | Runs a property test using the initial runtime defaults unchanged. +runHegelTest_ :: (TestCase -> IO ()) -> IO () +runHegelTest_ = runHegelTest id + + +-- --------------------------------------------------------------------------- +-- Utilities +-- --------------------------------------------------------------------------- + +-- | Strip leading and trailing whitespace from a string. +strip :: String -> String +strip = reverse . dropWhile isSpace' . reverse . dropWhile isSpace' + where + isSpace' c = c == ' ' || c == '\n' || c == '\r' || c == '\t' + +-- | Read a file, returning empty string on failure. +readFileSafe :: FilePath -> IO String +readFileSafe path = do + result <- try (readFile path) :: IO (Either SomeException String) + case result of + Right contents -> pure contents + Left _ -> pure "" diff --git a/test/Hegel/ClientSpec.hs b/test/Hegel/ClientSpec.hs new file mode 100644 --- /dev/null +++ b/test/Hegel/ClientSpec.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Hegel.ClientSpec (spec) where + +import Test.Hspec + +import Hegel.Client + +spec :: Spec +spec = do + describe "Default Settings" $ do + it "provides pure non-CI defaults" $ do + let stgs = defaultSettings + settingsTestCases stgs `shouldBe` 100 + settingsVerbosity stgs `shouldBe` Normal + settingsSeed stgs `shouldBe` Nothing + settingsDerandomize stgs `shouldBe` False + settingsDatabase stgs `shouldBe` Unset + settingsSuppressHealthCheck stgs `shouldBe` [] + + it "can be updated through record syntax without exposing the constructor" $ do + let stgs = + defaultSettings + { settingsTestCases = 200 + , settingsDatabase = DatabasePath ".hegel/examples" + } + settingsTestCases stgs `shouldBe` 200 + settingsDatabase stgs `shouldBe` DatabasePath ".hegel/examples" + + describe "healthCheckToString" $ do + it "maps FilterTooMuch correctly" $ do + healthCheckToString FilterTooMuch `shouldBe` "filter_too_much" + + it "maps TooSlow correctly" $ do + healthCheckToString TooSlow `shouldBe` "too_slow" + + it "maps TestCasesTooLarge correctly" $ do + healthCheckToString TestCasesTooLarge `shouldBe` "test_cases_too_large" + + it "maps LargeInitialTestCase correctly" $ do + healthCheckToString LargeInitialTestCase `shouldBe` "large_initial_test_case" diff --git a/test/Hegel/IntegrationSpec.hs b/test/Hegel/IntegrationSpec.hs new file mode 100644 --- /dev/null +++ b/test/Hegel/IntegrationSpec.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +module Hegel.IntegrationSpec (spec) where + +import Control.Exception (SomeException, displayException, try) +import Control.Monad (when) +import Data.List (isInfixOf) +import Test.Hspec + +import Hegel + +captureFailureText :: IO () -> IO String +captureFailureText action = do + result <- try action :: IO (Either SomeException ()) + case result of + Left e -> pure (displayException e) + Right () -> expectationFailure "expected property test to fail" >> pure "" + +withTestCases :: Int -> Settings -> Settings +withTestCases n stgs = stgs { settingsTestCases = n } + +spec :: Spec +spec = do + describe "E2E: simple passing test" $ do + it "integers are self-equal" $ do + runHegelTest (withTestCases 10) $ \tc -> do + n <- draw tc (integers def) + when (n /= n) $ + error "integer not equal to itself" + + describe "E2E: simple failing test" $ do + it "catches HegelTestFailure" $ do + let action = runHegelTest (withTestCases 10) $ \tc -> do + _ <- draw tc (integers def { rangeMin = Just 0, rangeMax = Just 100 }) + error "deliberate failure" + action `shouldThrow` anyException + + it "reports the source location for Hegel.assert failures" $ do + let expectedFile = __FILE__ + let expectedLine = show ((__LINE__ + 3) :: Int) + msg <- captureFailureText $ + runHegelTest (withTestCases 10) $ \_tc -> + assert False "deliberate failure with location" + msg `shouldSatisfy` isInfixOf expectedFile + msg `shouldSatisfy` isInfixOf (":" ++ expectedLine ++ ":") + + it "reports only the smallest failing example for a stable origin" $ do + msg <- captureFailureText $ + runHegelTest + ( \stgs -> + stgs + { settingsTestCases = 200 + , settingsDerandomize = True + , settingsDatabase = Disabled + } + ) + $ \tc -> do + xs <- + draw + tc + ( lists + (integers def { rangeMin = Just 0, rangeMax = Just 0 }) + def + { rangeMin = Just 0 + , rangeMax = Just 12 + } + ) + assert (length xs < 10) ("expected list shorter than 10, got xs = " ++ show xs) + msg `shouldSatisfy` isInfixOf "expected list shorter than 10, got xs = [0,0,0,0,0,0,0,0,0,0]" + msg `shouldSatisfy` not . isInfixOf "got xs = [0,0,0,0,0,0,0,0,0,0,0]" + + describe "E2E: assume" $ do + it "assume True does not reject" $ do + runHegelTest (withTestCases 10) $ \tc -> do + n <- draw tc (integers def) + assume tc True + when (n /= n) $ + error "unreachable" + + it "assume False rejects the test case" $ do + -- All test cases are rejected, but the test should still complete + -- (it just won't find any valid cases, which is fine for low counts) + runHegelTest (withTestCases 5) $ \tc -> do + n <- draw tc (integers def { rangeMin = Just 0, rangeMax = Just 100 }) + assume tc (n > 50) + -- If we get here, n > 50 holds + pure () + + describe "E2E: draw multiple types" $ do + it "draws booleans, integers, floats, text, and binary" $ do + runHegelTest (withTestCases 10) $ \tc -> do + _ <- draw tc booleans + _ <- draw tc (integers def { rangeMin = Just 0, rangeMax = Just 100 }) + _ <- + draw + tc + ( floats def + { floatBounds = + RangeOpts + { rangeMin = Just 0.0, + rangeMax = Just 1.0 + } + } + ) + _ <- draw tc (text def { rangeMax = Just 50 }) + _ <- draw tc (binary def { rangeMax = Just 50 }) + pure () + + describe "E2E: note and target" $ do + it "note records a message without failure" $ do + runHegelTest (withTestCases 5) $ \tc -> do + n <- draw tc (integers def) + note tc ("Generated value: " ++ show n) + pure () + + it "target guides the search" $ do + runHegelTest (withTestCases 10) $ \tc -> do + n <- draw tc (integers def { rangeMin = Just 0, rangeMax = Just 1000 }) + target tc (fromIntegral n) "maximize n" + pure () diff --git a/test/Hegel/ProtocolSpec.hs b/test/Hegel/ProtocolSpec.hs new file mode 100644 --- /dev/null +++ b/test/Hegel/ProtocolSpec.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Hegel.ProtocolSpec (spec) where + +import Codec.CBOR.Term (Term (..)) +import qualified Data.ByteString as BS +import Data.Bits (shiftL, shiftR, (.|.)) +import Data.Word (Word32) +import System.IO (Handle, hFlush, hSetBinaryMode) +import System.Process (createPipe) +import Test.Hspec + +import Hegel.Protocol + +-- | Helper: create a pipe pair of handles for testing. +createPipePair :: IO (Handle, Handle) +createPipePair = createPipe + +-- | Pack a Word32 as 4 big-endian bytes (reimplemented for testing since +-- the library does not export this). +testPackWord32BE :: Word32 -> BS.ByteString +testPackWord32BE w = BS.pack + [ fromIntegral (w `shiftR` 24) + , fromIntegral (w `shiftR` 16) + , fromIntegral (w `shiftR` 8) + , fromIntegral w + ] + +-- | Unpack a Word32 from 4 big-endian bytes at offset 0. +testUnpackWord32BE :: BS.ByteString -> Word32 +testUnpackWord32BE bs = + let b0 = fromIntegral (BS.index bs 0) :: Word32 + b1 = fromIntegral (BS.index bs 1) :: Word32 + b2 = fromIntegral (BS.index bs 2) :: Word32 + b3 = fromIntegral (BS.index bs 3) :: Word32 + in (b0 `shiftL` 24) .|. (b1 `shiftL` 16) .|. (b2 `shiftL` 8) .|. b3 + +spec :: Spec +spec = do + describe "CRC32" $ do + it "computes the known check value for '123456789'" $ do + let input = "123456789" + computeCRC32 input `shouldBe` 0xCBF43926 + + describe "pack/unpack Word32 BE" $ do + it "round-trips uint32 values" $ do + let values = [0, 1, 255, 256, 65535, 0x12345678, 0xFFFFFFFF] :: [Word32] + mapM_ + ( \w -> do + let packed = testPackWord32BE w + BS.length packed `shouldBe` 4 + testUnpackWord32BE packed `shouldBe` w + ) + values + + describe "Packet round-trip" $ do + it "writes and reads a packet through a pipe pair" $ do + (readH, writeH) <- createPipePair + hSetBinaryMode readH True + hSetBinaryMode writeH True + let pkt = + Packet + { packetChannelId = 42, + packetMessageId = 7, + packetIsReply = False, + packetPayload = encodeTerm (TString "hello") + } + writePacket writeH pkt + result <- readPacket readH + packetChannelId result `shouldBe` 42 + packetMessageId result `shouldBe` 7 + packetIsReply result `shouldBe` False + decodeTerm (packetPayload result) `shouldBe` TString "hello" + + it "round-trips a reply packet" $ do + (readH, writeH) <- createPipePair + hSetBinaryMode readH True + hSetBinaryMode writeH True + let pkt = + Packet + { packetChannelId = 10, + packetMessageId = 3, + packetIsReply = True, + packetPayload = encodeTerm (TBool True) + } + writePacket writeH pkt + result <- readPacket readH + packetChannelId result `shouldBe` 10 + packetMessageId result `shouldBe` 3 + packetIsReply result `shouldBe` True + + describe "Invalid magic" $ do + it "raises on invalid magic number" $ do + (readH, writeH) <- createPipePair + hSetBinaryMode readH True + hSetBinaryMode writeH True + -- Write a header with bad magic (0xDEADBEEF), followed by terminator + let badHeader = + BS.concat + [ testPackWord32BE 0xDEADBEEF, + testPackWord32BE 0, + testPackWord32BE 1, + testPackWord32BE 1, + testPackWord32BE 0 + ] + BS.hPut writeH badHeader + BS.hPut writeH (BS.singleton 0x0A) + hFlush writeH + readPacket readH `shouldThrow` anyIOException + + describe "Bad CRC" $ do + it "raises on checksum mismatch" $ do + (readH, writeH) <- createPipePair + hSetBinaryMode readH True + hSetBinaryMode writeH True + let payload = encodeTerm (TString "test") + let payloadLen = fromIntegral (BS.length payload) :: Word32 + -- Compute correct CRC then corrupt it + let headerForCRC = + BS.concat + [ testPackWord32BE magic, + testPackWord32BE 0, + testPackWord32BE 1, + testPackWord32BE 1, + testPackWord32BE payloadLen + ] + let correctCRC = computeCRC32Parts headerForCRC payload + let wrongCRC = correctCRC + 1 + let badHeader = + BS.concat + [ testPackWord32BE magic, + testPackWord32BE wrongCRC, + testPackWord32BE 1, + testPackWord32BE 1, + testPackWord32BE payloadLen + ] + BS.hPut writeH badHeader + BS.hPut writeH payload + BS.hPut writeH (BS.singleton 0x0A) + hFlush writeH + readPacket readH `shouldThrow` anyIOException diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}