diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,13 @@ +# Changelog + +All notable changes to `atelier-core` will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/), +and this project adheres to the [PVP](https://pvp.haskell.org/). + +## [Unreleased] + +### Added + +- Initial release: foundational Effectful-based effects and utilities, + extracted from the atelier toolkit. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2025 Christian Georgii + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,33 @@ +# atelier-core + +Foundational effects and utilities for effect-based applications, built on [Effectful](https://github.com/haskell-effectful/effectful). Part of the **atelier** toolkit. + +## Overview + +`atelier-core` provides a set of composable Effectful effects and supporting types for building structured, observable applications. + +| Module | Purpose | +|---|---| +| `Atelier.Component` | Structured component lifecycle (`setup → listeners → start`) | +| `Atelier.Config` | Configuration with environment variable overrides | +| `Atelier.Effects.Log` | Structured logging with hierarchical namespaces | +| `Atelier.Effects.Conc` | Thread management via [Ki](https://github.com/awkward-squad/ki) (structured concurrency) | +| `Atelier.Effects.Cache` | Caching with singleflight deduplication | +| `Atelier.Effects.Publishing` | Event publishing with context propagation | +| `Atelier.Effects.Monitoring.Tracing` | OpenTelemetry tracing | +| `Atelier.Effects.Monitoring.Metrics` | Prometheus metrics | +| `Atelier.Effects.FileWatcher` | Filesystem change notifications | +| `Atelier.Effects.Process` | External process management | + +It also wraps a number of `IO`-based primitives (environment, clock, file system, console, POSIX) as effects so they can be interpreted and tested explicitly: `Atelier.Effects.Env`, `Atelier.Effects.Clock`, `Atelier.Effects.FileSystem`, `Atelier.Effects.Console`, `Atelier.Effects.Posix.*`, and more. + +## Part of atelier + +- [`atelier-prelude`](https://github.com/atelier-hub/tricorder/tree/main/atelier-prelude) — relude-based prelude with Effectful conventions +- [`atelier-core`](https://github.com/atelier-hub/tricorder/tree/main/atelier-core) — this package +- [`atelier-db`](https://github.com/atelier-hub/tricorder/tree/main/atelier-db) — relational database effect (Hasql/Rel8) +- [`atelier-testing`](https://github.com/atelier-hub/tricorder/tree/main/atelier-testing) — database-backed test utilities + +## License + +MIT — see [LICENSE](LICENSE). diff --git a/atelier-core.cabal b/atelier-core.cabal new file mode 100644 --- /dev/null +++ b/atelier-core.cabal @@ -0,0 +1,215 @@ +cabal-version: 2.0 + +-- This file has been generated from package.yaml by hpack version 0.38.2. +-- +-- see: https://github.com/sol/hpack + +name: atelier-core +version: 0.1.0.0 +synopsis: Foundational Effectful-based effects and utilities +description: Core effects and utilities for effect-based applications, built on Effectful — part of the atelier toolkit. +category: Control +homepage: https://github.com/atelier-hub/tricorder#readme +bug-reports: https://github.com/atelier-hub/tricorder/issues +author: Christian Georgii +maintainer: christian.georgii@tweag.io +license: MIT +license-file: LICENSE +build-type: Simple +extra-doc-files: + CHANGELOG.md + README.md + +source-repository head + type: git + location: https://github.com/atelier-hub/tricorder + +library + exposed-modules: + Atelier.Component + Atelier.Config + Atelier.Effects.Arguments + Atelier.Effects.Await + Atelier.Effects.Cache + Atelier.Effects.Cache.Config + Atelier.Effects.Cache.Singleflight + Atelier.Effects.Chan + Atelier.Effects.Clock + Atelier.Effects.Conc + Atelier.Effects.Conc.Traced + Atelier.Effects.Console + Atelier.Effects.Debounce + Atelier.Effects.Delay + Atelier.Effects.Env + Atelier.Effects.Exit + Atelier.Effects.File + Atelier.Effects.FileSystem + Atelier.Effects.FileWatcher + Atelier.Effects.Input + Atelier.Effects.Internal.Coroutine + Atelier.Effects.Iterator + Atelier.Effects.Log + Atelier.Effects.Monitoring.Metrics + Atelier.Effects.Monitoring.Metrics.Registry + Atelier.Effects.Monitoring.Metrics.Server + Atelier.Effects.Monitoring.Tracing + Atelier.Effects.Monitoring.Tracing.Provider + Atelier.Effects.Posix.Daemons + Atelier.Effects.Posix.IO + Atelier.Effects.Process + Atelier.Effects.Publishing + Atelier.Effects.Tally + Atelier.Effects.Timeout + Atelier.Effects.UUID + Atelier.Effects.Yield + Atelier.Exception + Atelier.Time + Atelier.Types.Base64 + Atelier.Types.HttpApiDataReadShow + Atelier.Types.JsonReadShow + Atelier.Types.QuietSnake + Atelier.Types.Semaphore + Atelier.Types.Semaphore.STM + Atelier.Types.WithDefaults + other-modules: + Paths_atelier_core + autogen-modules: + Paths_atelier_core + hs-source-dirs: + src + default-extensions: + BlockArguments + DataKinds + DeriveAnyClass + DerivingStrategies + DerivingVia + DuplicateRecordFields + FlexibleContexts + GADTs + LambdaCase + MultiWayIf + OverloadedLabels + OverloadedRecordDot + OverloadedStrings + StrictData + TemplateHaskell + TypeFamilies + ghc-options: -Weverything -Wno-unsafe -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-missing-kind-signatures -Wno-missing-poly-kind-signatures -Wno-missing-role-annotations -Wno-missing-local-signatures -Wno-missing-import-lists -Wno-implicit-prelude -Wno-unticked-promoted-constructors -Wno-unused-packages -Wno-all-missed-specialisations -Wno-missed-specialisations -fplugin=Effectful.Plugin -threaded + build-depends: + aeson ==2.2.* + , atelier-prelude ==0.1.* + , base ==4.20.* + , base64-bytestring ==1.2.* + , bytestring ==0.12.* + , casing ==0.1.* + , containers ==0.7.* + , contra-tracer ==0.2.* + , daemons ==0.4.* + , data-default ==0.8.* + , directory ==1.3.* + , effectful ==2.6.* + , effectful-core ==2.6.* + , effectful-plugin ==2.0.* + , effectful-th ==1.0.* + , filepath ==1.5.* + , fsnotify ==0.4.* + , hs-opentelemetry-api ==0.3.* + , hs-opentelemetry-exporter-otlp ==0.1.* + , hs-opentelemetry-sdk ==0.1.* + , http-api-data ==0.7.* + , http-types ==0.12.* + , ki ==1.0.* + , list-t ==1.0.* + , optparse-applicative ==0.19.* + , process ==1.6.* + , prometheus-client ==1.1.* + , prometheus-metrics-ghc ==1.0.* + , stm ==2.5.* + , stm-containers ==1.2.* + , text ==2.1.* + , time ==1.12.* + , time-units ==1.0.* + , typed-process ==0.2.* + , unagi-chan ==0.4.* + , unix ==2.8.* + , unordered-containers ==0.2.* + , uuid ==1.3.* + , wai ==3.2.* + , warp ==3.4.* + mixins: + base hiding (Prelude) + default-language: GHC2021 + +test-suite atelier-test + type: exitcode-stdio-1.0 + main-is: Driver.hs + other-modules: + Unit.Atelier.ConfigSpec + Unit.Atelier.Effects.AwaitSpec + Unit.Atelier.Effects.Cache.SingleflightSpec + Unit.Atelier.Effects.CacheSpec + Unit.Atelier.Effects.ChanSpec + Unit.Atelier.Effects.Conc.TeardownStressSpec + Unit.Atelier.Effects.Conc.TracedSpec + Unit.Atelier.Effects.ConcSpec + Unit.Atelier.Effects.ConsoleSpec + Unit.Atelier.Effects.DebounceSpec + Unit.Atelier.Effects.FileSystemSpec + Unit.Atelier.Effects.FileWatcherSpec + Unit.Atelier.Effects.IteratorSpec + Unit.Atelier.Effects.LogSpec + Unit.Atelier.Effects.PublishingSpec + Unit.Atelier.Effects.TallySpec + Unit.Atelier.Effects.YieldSpec + Unit.Atelier.Types.Semaphore.STMSpec + Unit.Atelier.Types.SemaphoreSpec + Unit.Atelier.Types.WithDefaultsSpec + Paths_atelier_core + autogen-modules: + Paths_atelier_core + hs-source-dirs: + test + default-extensions: + BlockArguments + DataKinds + DeriveAnyClass + DerivingStrategies + DerivingVia + DuplicateRecordFields + FlexibleContexts + GADTs + LambdaCase + MultiWayIf + OverloadedLabels + OverloadedRecordDot + OverloadedStrings + StrictData + TemplateHaskell + TypeFamilies + ghc-options: -Weverything -Wno-unsafe -Wno-missing-safe-haskell-mode -Wno-monomorphism-restriction -Wno-missing-kind-signatures -Wno-missing-poly-kind-signatures -Wno-missing-role-annotations -Wno-missing-local-signatures -Wno-missing-import-lists -Wno-implicit-prelude -Wno-unticked-promoted-constructors -Wno-unused-packages -Wno-all-missed-specialisations -Wno-missed-specialisations -fplugin=Effectful.Plugin -threaded -Wno-prepositive-qualified-module + build-tool-depends: + tasty-discover:tasty-discover + build-depends: + aeson ==2.2.* + , async ==2.2.* + , atelier-core ==0.1.* + , atelier-prelude ==0.1.* + , base ==4.20.* + , bytestring ==0.12.* + , containers ==0.7.* + , data-default ==0.8.* + , effectful ==2.6.* + , effectful-core ==2.6.* + , effectful-plugin ==2.0.* + , hedgehog ==1.7.* + , hs-opentelemetry-api ==0.3.* + , hspec ==2.11.* + , hspec-hedgehog ==0.3.* + , stm ==2.5.* + , stm-containers ==1.2.* + , tasty ==1.5.* + , tasty-hspec ==1.2.* + , time ==1.12.* + mixins: + base hiding (Prelude) + default-language: GHC2021 diff --git a/src/Atelier/Component.hs b/src/Atelier/Component.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Component.hs @@ -0,0 +1,132 @@ +-- | A small component model for assembling long-running applications. +-- +-- A 'Component' bundles a named unit of work with a lifecycle: one-off 'setup', +-- a set of 'listeners' and 'triggers' that run as forked threads, and a +-- post-'start' action. 'runSystem' drives a collection of components through +-- these phases in lockstep, so that (for example) every component has finished +-- 'setup' before any 'start' action runs and publishes events the others react +-- to. +module Atelier.Component + ( -- * Components + Component (..) + , defaultComponent + , Listener + , Trigger + + -- * Running + , runComponent + , runSystem + ) where + +import Text.Casing (fromHumps, toQuietSnake) + +import Atelier.Effects.Conc (Conc) +import Atelier.Effects.Log (Log) +import Atelier.Effects.Monitoring.Tracing (Tracing, withSpan) + +import Atelier.Effects.Conc qualified as Conc +import Atelier.Effects.Log qualified as Log + + +-- | A listener reacts to events and runs forever; it never returns normally, +-- hence the 'Void' result. +type Listener es = Eff es Void + + +-- | A trigger initiates periodic or scheduled work and, like a 'Listener', runs +-- forever and never returns normally. +type Trigger es = Eff es Void + + +-- | A named unit of application work together with its lifecycle hooks. +-- +-- Build one by overriding the fields of 'defaultComponent' you care about. +data Component es = Component + { name :: ~Text + -- ^ Component name for tracing + , setup :: Eff es () + -- ^ Setup component (runs before listeners/triggers start) + , listeners :: Eff es [Listener es] + -- ^ Event listeners (react to events) + , triggers :: Eff es [Trigger es] + -- ^ Triggers (initiate periodic/scheduled work) + , start :: Eff es () + -- ^ Post-start actions (runs after all components have started) + } + + +-- | A 'Component' with no-op lifecycle hooks and no listeners or triggers. +-- +-- Override the fields you need. 'name' is deliberately left as an 'error' so a +-- component created without a name fails fast rather than tracing anonymously. +defaultComponent :: (HasCallStack) => Component es +defaultComponent = + Component + { name = error "Missing component name" + , setup = pure () + , listeners = pure [] + , triggers = pure [] + , start = pure () + } + + +-- | Run a component by forking its listeners and triggers +runComponent :: (Conc :> es, Tracing :> es) => Component es -> Eff es () +runComponent c = withSpan c.name $ do + ls <- c.listeners + ts <- c.triggers + traverse_ Conc.fork_ ls + traverse_ Conc.fork_ ts + + +-- | Run multiple components with structured lifecycle coordination +-- +-- Executes components in three sequential phases: +-- 1. Run @setup for all components (initialization before activation) +-- 2. Fork all listeners and triggers (components become active) +-- 3. Fork @start for all components (background startup actions) +-- +-- This separation allows components to prepare resources during setup, then perform +-- work during start that depends on listeners already running (e.g., publishing events). +-- The start phase is forked to allow parallel execution across components. +runSystem + :: forall es + . (Conc :> es, Log :> es, Tracing :> es) + => [Component es] + -> Eff es () +runSystem components = Conc.scoped do + -- Phase 1: Setup all components + traverse_ setupComponent components + + -- Phase 2: Start all components (fork listeners/triggers) + traverse_ startComponent components + + -- Phase 3: Fork post-start actions + traverse_ postStartComponent components + + Conc.awaitAll + where + setupComponent :: Component es -> Eff es () + setupComponent c = do + let name = formatName c.name + Log.debug $ "Setting up component: " <> name + withSpan (name <> ":setup") + $ c.setup + + startComponent :: Component es -> Eff es () + startComponent c = do + let name = formatName c.name + Log.debug $ "Starting listeners/triggers for component: " <> name + runComponent c + + postStartComponent :: Component es -> Eff es () + postStartComponent c = do + let name = formatName c.name + Log.debug $ "Forking start phase for component: " <> name + void . Conc.fork + $ withSpan (name <> ":start") + $ c.start + + +formatName :: Text -> Text +formatName = toText . toQuietSnake . fromHumps . toString diff --git a/src/Atelier/Config.hs b/src/Atelier/Config.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Config.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Layered application configuration. +-- +-- A configuration is assembled from a base JSON\/YAML document plus environment +-- variable overrides, then decoded on demand by type-level key: +-- +-- * 'envOverrides' turns @PREFIX__A__B=value@ variables into a nested JSON +-- 'Value'; +-- * 'deepMerge' overlays that onto the base document, producing a +-- 'LoadedConfig'; +-- * 'extractConfig' and 'extractNestedConfig' decode a section by 'Symbol' key, +-- falling back to the target type's 'Default' instance when the key is +-- missing or fails to decode; +-- * 'runConfig' hands a decoded section to a computation as a 'Reader'. +-- +-- == Worked example +-- +-- Given a base document (say, decoded from a @base.yaml@ holding +-- @server: { port: 8080, host: localhost }@) and a @MYAPP@ environment prefix: +-- +-- @ +-- data Server = Server { port :: Int, host :: Text } +-- deriving stock (Generic) +-- deriving (FromJSON) via (QuietSnake Server) +-- +-- instance Default Server where +-- def = Server { port = 80, host = \"0.0.0.0\" } +-- +-- loadServer :: (Env :> es) => Value -> Eff es Server +-- loadServer base = do +-- overrides <- envOverrides \"MYAPP\" -- e.g. MYAPP__SERVER__PORT=9090 +-- let loaded = LoadedConfig (deepMerge base overrides) +-- pure (extractNestedConfig \@\"server\" loaded) +-- @ +-- +-- With @MYAPP__SERVER__PORT=9090@ set in the environment, @loadServer@ yields +-- @Server { port = 9090, host = \"localhost\" }@: the env override wins on +-- @port@, the base document supplies @host@, and the 'Default' instance would +-- cover any field absent from both. +module Atelier.Config + ( envOverrides + , deepMerge + , extractConfig + , extractNestedConfig + , LoadedConfig (..) + , runConfig + ) where + +import Data.Aeson (FromJSON (..), Value (..)) +import Data.Default (Default (..)) +import Effectful.Exception (evaluate) +import Effectful.Reader.Static (Reader, ask, runReader) +import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) + +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KM +import Data.Text qualified as T +import Data.Text.Encoding qualified as TE + +import Atelier.Effects.Env (Env, getEnvironment) + + +-- | Build a nested JSON Object from environment variables with the given prefix. +-- Variables are expected in the form PREFIX__SEG1__SEG2=value. +-- Double underscore is the path separator; single underscore is preserved within segments. +envOverrides :: (Env :> es) => Text -> Eff es Value +envOverrides prefix = do + allEnv <- getEnvironment + let prefixStr = toString prefix <> "__" + matching = [(k, v) | (k, v) <- allEnv, prefixStr `isPrefixOf` k] + pairs = [(splitPath (drop (length prefixStr) k), parseScalar (toText v)) | (k, v) <- matching] + pure $ foldl' insertNested (Object KM.empty) pairs + where + splitPath :: String -> [Text] + splitPath = map T.toLower . T.splitOn "__" . toText + + insertNested :: Value -> ([Text], Value) -> Value + insertNested base ([], _) = base + insertNested base ([k], v) = + let key = fromString (toString k) + in Object $ case base of + Object m -> KM.insert key v m + _ -> KM.singleton key v + insertNested base (k : ks, v) = + let key = fromString (toString k) + child = case base of + Object m -> fromMaybe (Object KM.empty) (KM.lookup key m) + _ -> Object KM.empty + merged = insertNested child (ks, v) + in Object $ case base of + Object m -> KM.insert key merged m + _ -> KM.singleton key merged + + +-- | Parse a scalar text value as its natural JSON type when possible, +-- falling back to a JSON String. +parseScalar :: Text -> Value +parseScalar t = + fromMaybe (String t) + $ Aeson.decodeStrict + $ TE.encodeUtf8 t + + +-- | Deep merge two JSON values. Right wins on conflict for non-Object values; +-- Objects are merged recursively. +deepMerge :: Value -> Value -> Value +deepMerge (Object l) (Object r) = Object $ KM.unionWith deepMerge l r +deepMerge _ r = r + + +-- | A fully merged configuration document (base overlaid with overrides), ready +-- to have sections extracted from it by key. +newtype LoadedConfig = LoadedConfig Value + + +-- | Pure variant of 'runConfig': extract and decode a config section from a 'LoadedConfig' +-- without entering the effect stack. Falls back to the type's 'Default' instance on +-- missing key or decode failure. +extractConfig + :: forall (key :: Symbol) r + . (Default r, FromJSON r, KnownSymbol key) + => LoadedConfig + -> r +extractConfig (LoadedConfig root) = + case root of + Aeson.Object m -> + case KM.lookup (fromString (symbolVal (Proxy @key))) m of + Nothing -> def + Just v -> case Aeson.fromJSON v of + Aeson.Success a -> a + Aeson.Error _ -> def + _ -> def + + +-- | Variant of 'extractConfig' that extracts nested configuration values. +-- Nested properties are delimited by @"."@, so @foo.bar@ would attempt to +-- extract the nested property @bar@ contained in the top-level property @foo@. +-- +-- Example: +-- +-- Assuming @cfg@ is a 'LoadedConfig' representing the following JSON/YAML +-- structure: +-- +-- @ +-- { +-- "foo": { +-- "bar": "test" +-- } +-- } +-- @ +-- +-- The following will be @True@: +-- +-- @ +-- extractNestedConfig \@"foo.bar" \@Text cfg == "test" +-- @ +extractNestedConfig :: forall (key :: Symbol) r. (Default r, FromJSON r, KnownSymbol key) => LoadedConfig -> r +extractNestedConfig (LoadedConfig root) = go props root + where + props = T.splitOn "." $ toText $ symbolVal $ Proxy @key + + go (p : ps) (Aeson.Object m) = maybe def (go ps) $ KM.lookup (fromString $ toString p) m + go (_ : _) _ = def + go [] x = fromJSON x + + fromJSON x = case Aeson.fromJSON x of + Aeson.Success a -> a + Aeson.Error _ -> def + + +-- | Extract and decode a (potentially nested) config section by type-level key +-- from the root config Value. +-- Falls back to the type's 'Default' instance if the (nested) key is absent. +runConfig + :: forall (key :: Symbol) r es a + . (Default r, FromJSON r, KnownSymbol key, Reader LoadedConfig :> es) + => Eff (Reader r : es) a -> Eff es a +runConfig act = do + loadedCfg <- ask + cfg <- evaluate $ extractNestedConfig @key loadedCfg + runReader (cfg) act diff --git a/src/Atelier/Effects/Arguments.hs b/src/Atelier/Effects/Arguments.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Effects/Arguments.hs @@ -0,0 +1,39 @@ +-- | Effect for parsing command-line arguments. +-- +-- A thin wrapper over @optparse-applicative@'s 'Opt.execParser', so callers +-- read and parse @argv@ through the effect system rather than raw 'IO'. +module Atelier.Effects.Arguments + ( -- * Effect + Arguments + + -- * Re-exported from @optparse-applicative@ + , ParserInfo + + -- * Operations + , execParser + + -- * Interpreters + , runArgumentsIO + ) where + +import Effectful (Effect, IOE) +import Effectful.Dispatch.Dynamic (interpret_) +import Effectful.TH (makeEffect) +import Options.Applicative (ParserInfo) + +import Options.Applicative qualified as Opt + + +-- | Reading and parsing command-line arguments. +data Arguments :: Effect where + -- | Read @argv@ and parse it with the given parser, printing usage and + -- exiting on failure (see @optparse-applicative@'s 'Opt.execParser'). + ExecParser :: ParserInfo a -> Arguments m a + + +makeEffect ''Arguments + + +runArgumentsIO :: (IOE :> es) => Eff (Arguments : es) a -> Eff es a +runArgumentsIO = interpret_ \case + ExecParser pinfo -> liftIO $ Opt.execParser pinfo diff --git a/src/Atelier/Effects/Await.hs b/src/Atelier/Effects/Await.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Effects/Await.hs @@ -0,0 +1,28 @@ +-- | The consuming half of a 'Yield'\/'Await' coroutine pair. +-- +-- An 'Await' computation requests values one at a time, analogous to the +-- @Reader@\/@Input@ effects. Pair it with a 'Yield' producer — for example via +-- 'awaitYield' — to stream values from one computation into another. The effect +-- and its operations live in "Atelier.Effects.Internal.Coroutine" and are +-- re-exported here. +module Atelier.Effects.Await + ( -- * Effect + Await + + -- * Operations + , await + , takeAwait + + -- * Interpreters + , eachAwait + , awaitYield + ) where + +import Atelier.Effects.Internal.Coroutine + ( Await + , await + , awaitYield + , eachAwait + , takeAwait + ) + diff --git a/src/Atelier/Effects/Cache.hs b/src/Atelier/Effects/Cache.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Effects/Cache.hs @@ -0,0 +1,184 @@ +-- | Generic key-value cache effect with pluggable eviction strategies +module Atelier.Effects.Cache + ( -- * Effect + Cache + , cacheLookup + , cacheInsert + , cacheDelete + , cacheModify + + -- * Re-exports + , module Atelier.Effects.Cache.Config + + -- * Interpreters + , runCacheTtl + , runCacheTtlWithWait + , runCacheForever + ) where + +import Data.Time (NominalDiffTime, UTCTime, addUTCTime) +import Effectful (Effect) +import Effectful.Concurrent (Concurrent) +import Effectful.Concurrent.STM (STM) +import Effectful.Dispatch.Dynamic (interpretWith) +import Effectful.Reader.Static (Reader, ask) +import Effectful.TH (makeEffect) +import StmContainers.Map (Map) +import Prelude hiding (Map) + +import Effectful.Concurrent.STM qualified as STM +import ListT qualified +import StmContainers.Map qualified as Map + +import Atelier.Effects.Cache.Config +import Atelier.Effects.Clock (Clock, currentTime) +import Atelier.Effects.Conc (Conc) +import Atelier.Effects.Delay (Delay) +import Atelier.Effects.Log (Log) +import Atelier.Time (Microsecond, nominalDiffTime) + +import Atelier.Effects.Conc qualified as Conc +import Atelier.Effects.Delay qualified as Delay +import Atelier.Effects.Log qualified as Log + + +-- | Effect for a generic key-value cache. +data Cache key value :: Effect where + -- | Look up a key, returning 'Nothing' if it is absent. + CacheLookup :: key -> Cache key value m (Maybe value) + -- | Insert or overwrite the value at a key. + CacheInsert :: key -> value -> Cache key value m () + -- | Remove a key from the cache. + CacheDelete :: key -> Cache key value m () + -- | Apply a function to a key's current value (or its absence), store the + -- result, and return it. + CacheModify :: key -> (Maybe value -> value) -> Cache key value m value + + +makeEffect ''Cache + + +-- | Internal entry wrapping a value with its insertion timestamp +data CacheEntry value = CacheEntry + { value :: !value + , createdAt :: !UTCTime + } + + +-- | Run the Cache effect with TTL-based eviction +-- +-- Entries are evicted after @entryTtl@ from their first insertion. +-- Subsequent updates to the same key preserve the original timestamp. +-- A background thread runs every @cleanupInterval@ to remove expired entries. +runCacheTtl + :: forall key value es a + . ( Clock :> es + , Conc :> es + , Concurrent :> es + , Delay :> es + , Hashable key + , Log :> es + , Reader Config :> es + ) + => Eff (Cache key value : es) a -> Eff es a +runCacheTtl act = do + cfg <- ask + runCacheTtlWithWait (Delay.wait $ nominalDiffTime @Microsecond cfg.cleanupInterval) act + + +-- | Like 'runCacheTtl', but with the cleanup cadence supplied explicitly as a +-- waiting action rather than read from 'Config'. Each time the action +-- completes, expired entries are swept. Useful for tests that drive cleanup +-- deterministically. +runCacheTtlWithWait + :: forall key value es a + . ( Clock :> es + , Conc :> es + , Concurrent :> es + , Hashable key + , Log :> es + , Reader Config :> es + ) + => Eff es () + -- ^ Action that completes when it is time to perform cleanup. + -> Eff (Cache key value : es) a + -> Eff es a +runCacheTtlWithWait waitForNextCleanup action = do + cfg <- ask @Config + store <- STM.atomically (Map.new :: STM (Map key (CacheEntry value))) + + Conc.fork_ $ forever $ Log.withNamespace "Cache" do + waitForNextCleanup + now <- currentTime + evicted <- STM.atomically $ evictExpiredEntries store cfg.entryTtl now + + when (evicted > 0) + $ Log.debug + $ "Evicted " <> show evicted <> " entries" + + interpretWith action $ \_ -> \case + CacheLookup key -> + fmap (.value) <$> STM.atomically (Map.lookup key store) + CacheInsert key val -> do + now <- currentTime + STM.atomically $ do + existing <- Map.lookup key store + let entry = case existing of + Nothing -> CacheEntry {value = val, createdAt = now} + Just e -> e {value = val} -- preserve original timestamp + Map.insert entry key store + CacheDelete key -> + STM.atomically $ Map.delete key store + CacheModify key f -> do + now <- currentTime + STM.atomically $ do + existing <- Map.lookup key store + let newEntry = case existing of + Nothing -> CacheEntry {value = f Nothing, createdAt = now} + Just e -> e {value = f (Just e.value)} + Map.insert newEntry key store + pure newEntry.value + + +evictExpiredEntries + :: (Hashable key) + => Map key (CacheEntry value) + -> NominalDiffTime + -> UTCTime + -> STM Int +evictExpiredEntries store ttl now = + ListT.fold + ( \count (k, v) -> + if now >= addUTCTime ttl v.createdAt then + Map.delete k store $> count + 1 + else + pure count + ) + 0 + $ Map.listT store + + +-- | Run the Cache effect with no TTL (entries live forever). +-- +-- Uses a plain STM 'Map' with no eviction. Useful for tests and +-- session-scoped caches where eviction is never needed. +runCacheForever + :: forall key value es a + . (Concurrent :> es, Hashable key) + => Eff (Cache key value : es) a + -> Eff es a +runCacheForever action = do + store <- STM.atomically (Map.new :: STM (Map key value)) + interpretWith action $ \_ -> \case + CacheLookup key -> + STM.atomically $ Map.lookup key store + CacheInsert key val -> + STM.atomically $ Map.insert val key store + CacheDelete key -> + STM.atomically $ Map.delete key store + CacheModify key f -> + STM.atomically $ do + existing <- Map.lookup key store + let newVal = f existing + Map.insert newVal key store + pure newVal diff --git a/src/Atelier/Effects/Cache/Config.hs b/src/Atelier/Effects/Cache/Config.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Effects/Cache/Config.hs @@ -0,0 +1,33 @@ +-- | Configuration shared by the TTL cache interpreters. +-- +-- 'Config' controls how long entries live and how often the background eviction +-- sweep runs. It is re-exported by "Atelier.Effects.Cache" and +-- "Atelier.Effects.Tally". +module Atelier.Effects.Cache.Config + ( Config (..) + ) where + +import Data.Aeson (FromJSON) +import Data.Default (Default (..)) +import Data.Time (NominalDiffTime) + +import Atelier.Types.QuietSnake (QuietSnake (..)) + + +-- | Configuration for a TTL-evicting cache +data Config = Config + { entryTtl :: !NominalDiffTime + -- ^ Time-to-live for cache entries. After this duration from first insertion, entries are evicted. + , cleanupInterval :: !NominalDiffTime + -- ^ How often the background cleanup thread runs to evict expired entries. + } + deriving stock (Eq, Generic, Show) + deriving (FromJSON) via QuietSnake Config + + +instance Default Config where + def = + Config + { entryTtl = 12 * 3600 -- 12 hours in seconds + , cleanupInterval = 3600 -- 1 hour in seconds + } diff --git a/src/Atelier/Effects/Cache/Singleflight.hs b/src/Atelier/Effects/Cache/Singleflight.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Effects/Cache/Singleflight.hs @@ -0,0 +1,140 @@ +-- | A singleflight cache effect: deduplicate concurrent computations of the +-- same key. +-- +-- When several threads request the same key at once, the first runs the +-- computation while the rest wait and share its result — so an expensive lookup +-- happens once per key per in-flight window. Results (and exceptions) can also +-- be seeded with 'updateCache' or invalidated with 'removeFromCache'. Each +-- operation is traced (see "Atelier.Effects.Monitoring.Tracing"). +module Atelier.Effects.Cache.Singleflight + ( Singleflight + , withCache + , updateCache + , removeFromCache + , runSingleflight + ) where + +import Effectful (Effect) +import Effectful.Concurrent (Concurrent) +import Effectful.Concurrent.STM (TMVar) +import Effectful.Dispatch.Dynamic (interpretWith, localSeqUnlift) +import Effectful.Exception (throwIO, trySync) +import Effectful.TH (makeEffect) +import StmContainers.Map (Map) +import Prelude hiding (Map) + +import Effectful.Concurrent.STM qualified as STM +import StmContainers.Map qualified as Map + +import Atelier.Effects.Monitoring.Tracing (Tracing, addAttribute, withSpan) + + +-- | Singleflight cache effect for deduplicating concurrent computations +-- +-- When multiple concurrent operations request the same key: +-- - The first request executes the computation +-- - Subsequent requests wait for and share the result +-- - After completion, all requests receive the same result +data Singleflight key value :: Effect where + -- | Execute a computation with singleflight semantics + -- If another computation for the same key is in-flight, wait for its result + WithCache :: (Hashable key) => key -> m value -> Singleflight key value m value + -- | Pre-populate the cache with known values + -- Useful when values are already available to avoid redundant computation + UpdateCache :: [(key, value)] -> Singleflight key value m () + -- | Remove keys from the cache so future requests recompute from source + RemoveFromCache :: [key] -> Singleflight key value m () + + +makeEffect ''Singleflight + + +type InFlightMap key value = Map key (TMVar (Either SomeException value)) + + +-- | Run the Singleflight effect with an in-memory cache +runSingleflight + :: forall key value es a + . (Concurrent :> es, Hashable key, Tracing :> es) + => Eff (Singleflight key value : es) a + -> Eff es a +runSingleflight action = do + -- Initialize the cache + cache :: InFlightMap key value <- STM.atomically Map.new + + -- Run with the cache in Reader context, interpreting Singleflight operations + interpretWith action $ \env -> \case + WithCache key computation -> localSeqUnlift env $ \unlift -> withSpan "singleflight.with_cache" do + -- Singleflight pattern: check if computation is already in-flight. + -- Also attempt a non-blocking read of any existing result in the same transaction. + (mvar, isFirst, mResult) <- STM.atomically $ do + existing <- Map.lookup key cache + case existing of + Just tmvar -> do + mResult <- STM.tryReadTMVar tmvar + pure (tmvar, False, mResult) + Nothing -> do + -- Create new empty TMVar and insert into cache + tmvar <- STM.newEmptyTMVar + Map.insert tmvar key cache + pure (tmvar, True, Nothing) + + case (isFirst, mResult) of + (_, Just (Right value)) -> do + addAttribute @Text "singleflight.outcome" "hit" + pure value + (_, Just (Left exception)) -> do + addAttribute @Text "singleflight.outcome" "hit" + throwIO exception + (True, Nothing) -> do + addAttribute @Text "singleflight.outcome" "compute" + result <- unlift $ trySync computation + + -- Try to fill the TMVar with result (success or failure) for waiters + -- Use tryPutTMVar in case updateCache already filled it + filled <- STM.atomically $ STM.tryPutTMVar mvar result + + if filled then do + -- We successfully filled the TMVar with our result + -- If it was an exception, remove from cache so future requests can retry + case result of + Left _exception -> do + STM.atomically $ Map.delete key cache + Right _ -> pure () + + -- Return the result or re-throw the exception + case result of + Left exception -> throwIO exception + Right value -> pure value + else do + -- updateCache filled it before us - read and use that value + finalResult <- STM.atomically $ STM.readTMVar mvar + case finalResult of + Left exception -> throwIO exception + Right value -> pure value + (False, Nothing) -> do + addAttribute @Text "singleflight.outcome" "wait" + result <- + withSpan "singleflight.wait" + $ STM.atomically + $ STM.readTMVar mvar + case result of + Left exception -> throwIO exception + Right value -> pure value + UpdateCache entries -> withSpan "singleflight.update_cache" do + STM.atomically $ do + forM_ entries $ \(key, value) -> do + existing <- Map.lookup key cache + case existing of + Just existingTMVar -> do + -- In-flight computation exists: update its result + -- Try to take whatever value is there (or Nothing if empty) + _ <- STM.tryTakeTMVar existingTMVar + -- Put the correct value (wrapped in Right for success) + STM.putTMVar existingTMVar (Right value) + Nothing -> do + -- No in-flight computation: create fresh TMVar with value + tmvar <- STM.newTMVar (Right value) + Map.insert tmvar key cache + RemoveFromCache keys -> withSpan "singleflight.remove_from_cache" do + STM.atomically $ forM_ keys $ \key -> Map.delete key cache diff --git a/src/Atelier/Effects/Chan.hs b/src/Atelier/Effects/Chan.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Effects/Chan.hs @@ -0,0 +1,122 @@ +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +-- | A typed, unbounded channel effect backed by @unagi-chan@. +-- +-- Exposes the split in\/out ends of a fast concurrent queue as an effect, plus a +-- batched read ('readChanBatched') for draining several items at once. The +-- 'InChan' and 'OutChan' types are re-exported so callers need not depend on +-- @unagi-chan@ directly. +-- +-- @ +-- -- write a few items (writeChan never blocks), then drain them in one batch: +-- pipeline :: (Chan :> es, Timeout :> es) => Eff es (NonEmpty Int) +-- pipeline = do +-- (inn, out) <- newChan +-- traverse_ (writeChan inn) [1 .. 10] +-- readChanBatched (50 :: Millisecond) 100 out -- one blocking read, up to 100 items +-- +-- -- dupChan gives a second, independent read end that sees later writes: +-- broadcast :: (Chan :> es) => Eff es (Int, Int) +-- broadcast = do +-- (inn, out1) <- newChan +-- out2 <- dupChan inn +-- writeChan inn 7 +-- (,) <$> readChan out1 <*> readChan out2 -- (7, 7) +-- @ +module Atelier.Effects.Chan + ( -- * Effect + Chan + , newChan + , readChan + , writeChan + , dupChan + , runChan + + -- * Channel Types + + -- | Re-exported from the underlying channel implementation. + -- Import these from this module rather than directly from Unagi + -- to maintain abstraction boundaries. + , InChan + , OutChan + , readChanBatched + ) where + +import Control.Concurrent.Chan.Unagi (InChan, OutChan) +import Data.Time.Units (TimeUnit, toMicroseconds) +import Effectful (Dispatch (..), DispatchOf, Effect, IOE) +import Effectful.Dispatch.Static (SideEffects (..), StaticRep, evalStaticRep, unsafeEff_) +import Effectful.State.Static.Shared (evalState, get, modify) +import Effectful.Timeout (Timeout, timeout) + +import Control.Concurrent.Chan.Unagi qualified as Unagi + + +-- | Effect for creating and operating on bidirectional channels. +data Chan :: Effect + + +type instance DispatchOf Chan = Static WithSideEffects +data instance StaticRep Chan = Chan + + +-- | Run the 'Chan' effect, allowing channel operations to perform their IO. +runChan :: forall a es. (IOE :> es) => Eff (Chan : es) a -> Eff es a +runChan = evalStaticRep Chan + + +-- | Create a new channel, returning its write ('InChan') and read ('OutChan') +-- ends. +newChan :: forall a es. (Chan :> es) => Eff es (InChan a, OutChan a) +newChan = + unsafeEff_ Unagi.newChan + + +-- | Read the next item from a channel, blocking until one is available. +readChan :: forall a es. (Chan :> es) => OutChan a -> Eff es a +readChan outChan = + unsafeEff_ $ Unagi.readChan outChan + + +-- | Write an item to a channel. Never blocks (the channel is unbounded). +writeChan :: forall a es. (Chan :> es) => InChan a -> a -> Eff es () +writeChan inChan val = + unsafeEff_ $ Unagi.writeChan inChan val + + +-- | Duplicate a channel, producing a new read end that observes every item +-- written after the duplication. +dupChan :: forall a es. (Chan :> es) => InChan a -> Eff es (OutChan a) +dupChan inChan = + unsafeEff_ $ Unagi.dupChan inChan + + +-- | Read a batch of items from a channel. +-- +-- Blocks until at least one item is available, then attempts to read +-- up to @batchSize@ items total within the given timeout. Always returns +-- at least one item. +readChanBatched + :: forall t a es + . ( Chan :> es + , TimeUnit t + , Timeout :> es + ) + => t + -- ^ Timeout for reading additional items after the first + -> Int + -- ^ Maximum number of items to read (batch size) + -> OutChan a + -- ^ Channel to read from + -> Eff es (NonEmpty a) + -- ^ Non-empty batch of items (at least one, up to batch size) +readChanBatched timeoutDuration batchSize outChan = do + evalState @[a] [] $ do + h <- readChan outChan -- blocking, get first item + _ <- timeout (fromIntegral (toMicroseconds timeoutDuration)) + $ replicateM_ (batchSize - 1) + $ do + x <- readChan outChan + modify (x :) + rest <- get + pure $ h :| reverse rest diff --git a/src/Atelier/Effects/Clock.hs b/src/Atelier/Effects/Clock.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Effects/Clock.hs @@ -0,0 +1,69 @@ +-- | A clock effect for reading the current time and time zone. +-- +-- Putting wall-clock reads behind an effect keeps time-dependent code testable: +-- 'runClock' uses the system clock, while 'runClockConst', 'runClockState' and +-- 'runClockList' supply deterministic times for tests. +module Atelier.Effects.Clock + ( Clock + , UTCTime + , TimeZone + , currentTime + , currentTimeZone + , runClock + , runClockConst + , runClockState + , runClockList + ) where + +import Data.Time (UTCTime, getCurrentTime) +import Data.Time.LocalTime (TimeZone, getCurrentTimeZone, utc) +import Effectful (Effect, IOE) +import Effectful.Dispatch.Dynamic (interpret_, reinterpret) +import Effectful.State.Static.Shared (State, evalState, get, put) +import Effectful.TH (makeEffect) + + +-- | Effect for reading the current time and time zone. +data Clock :: Effect where + -- | The current wall-clock time, in UTC. + CurrentTime :: Clock m UTCTime + -- | The system's current time zone. + CurrentTimeZone :: Clock m TimeZone + + +makeEffect ''Clock + + +-- | Interpret 'Clock' against the real system clock. +runClock :: (IOE :> es) => Eff (Clock : es) a -> Eff es a +runClock = interpret_ $ \case + CurrentTime -> liftIO getCurrentTime + CurrentTimeZone -> liftIO getCurrentTimeZone + + +-- | Interpret 'Clock' so 'currentTime' always returns a fixed time. The time +-- zone is reported as 'utc'. +runClockConst :: UTCTime -> Eff (Clock : es) a -> Eff es a +runClockConst time = interpret_ $ \case + CurrentTime -> pure time + CurrentTimeZone -> pure utc + + +-- | Interpret 'Clock' so 'currentTime' reads from a mutable 'State' cell, +-- letting a test advance \"now\" explicitly. The time zone is reported as 'utc'. +runClockState :: (State UTCTime :> es) => Eff (Clock : es) a -> Eff es a +runClockState = interpret_ $ \case + CurrentTime -> get + CurrentTimeZone -> pure utc + + +-- | Scripted interpreter for testing: returns times from a pre-loaded list in +-- order. Each 'currentTime' call pops the next item. Crashes if the list is +-- exhausted. +runClockList :: [UTCTime] -> Eff (Clock : es) a -> Eff es a +runClockList times = reinterpret (evalState times) $ \_ -> \case + CurrentTime -> + get >>= \case + [] -> error "runClockList: no more times in queue" + t : ts -> put ts >> pure t + CurrentTimeZone -> pure utc diff --git a/src/Atelier/Effects/Conc.hs b/src/Atelier/Effects/Conc.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Effects/Conc.hs @@ -0,0 +1,175 @@ +-- | Structured concurrency built on @ki@. +-- +-- 'Conc' exposes forking, awaiting, racing and nurseries ('scoped') as an +-- effect, so concurrent code stays in 'Eff' and inherits structured-concurrency +-- guarantees: every child thread is bound to a scope and is cancelled when that +-- scope closes. The base interpreter ('runConc') ignores tracing; use +-- "Atelier.Effects.Conc.Traced" to propagate OpenTelemetry context across forks. +module Atelier.Effects.Conc + ( -- * Effect + Conc (..) + , Thread + , fork + , fork_ + , await + , awaitAll + , forkTry + , race + + -- * Scope + , Scope (..) + , scoped + , restartableForkWith + , restartableForkLoop + + -- * Interpreters + , runConcBase + , runConc + + -- * Unlift Strategy + , concStrat + ) +where + +import Effectful + ( Effect + , IOE + , Limit (..) + , Persistence (..) + , UnliftStrategy (..) + , inject + , withEffToIO + ) +import Effectful.Concurrent.MVar (Concurrent, newEmptyMVar, putMVar, takeMVar) +import Effectful.Concurrent.STM (atomically, runConcurrent) +import Effectful.Dispatch.Dynamic + ( EffectHandler + , interpose + , interpret + , localLend + , localUnlift + , localUnliftIO + ) +import Effectful.TH (makeEffect) + +import Ki qualified + + +data Conc :: Effect where + -- | Fork a thread that terminates. Use @void . fork@ to discard the handle. + Fork :: m a -> Conc m (Thread a) + -- | Fork a thread that never terminates (e.g. a server loop). + -- The @Void@ return type enforces this — use 'fork' for threads that exit. + Fork_ :: m Void -> Conc m () + -- | Block until a forked 'Thread' finishes and return its result. + Await :: Thread a -> Conc m a + -- | Block until every thread in the current scope has finished. + AwaitAll :: Conc m () + -- | Like 'Fork', but the thread captures a synchronous exception of type @e@ + -- as a 'Left' instead of propagating it to the enclosing scope. + ForkTry :: (Exception e) => m a -> Conc m (Thread (Either e a)) + -- | Races two computations concurrently and returns the result of the + -- operation that finished first. + Race :: m a -> m b -> Conc m (Either a b) + -- | Open a nursery scope. Threads forked inside it are awaited or cancelled + -- when the action returns. + Scoped :: m a -> Conc m a + + +-- | A concurrency scope (nursery) that forked threads are bound to. +newtype Scope = Scope Ki.Scope + + +-- | A handle to a forked thread, awaited with 'await'. +newtype Thread a = Thread (Ki.Thread a) + + +makeEffect ''Conc + + +-- | Forks an action in a loop, with a setup step that runs in the scope before +-- each fork. Each time @signal@ returns, the current fork is cancelled, and +-- setup and fork are run again. The setup result is passed to the forked +-- action, structurally guaranteeing it completes before the fork starts. +restartableForkWith :: (Conc :> es) => Eff es () -> Eff es r -> (r -> Eff es a) -> Eff es Void +restartableForkWith signal setup action = forever $ scoped do + r <- setup + _ <- fork (action r) + signal + + +-- | Like 'restartableForkWith', but threads a value across iterations: the +-- signal returns the next @r@, which is passed to the next fork. The initial +-- @r@ seeds the first fork. +restartableForkLoop :: (Conc :> es) => r -> Eff es r -> (r -> Eff es a) -> Eff es Void +restartableForkLoop initial signal action = go initial + where + go r = scoped do + _ <- fork (action r) + r' <- signal + go r' + + +-- | Base interpreter: resolves 'Conc' operations using Ki. +-- +-- Does not handle trace context propagation. Use 'Atelier.Effects.Conc.Traced.runConc' +-- for automatic span link propagation across forks. +runConcBase :: forall es a. (Concurrent :> es, IOE :> es) => Scope -> Eff (Conc : es) a -> Eff es a +runConcBase (Scope scope0) = interpret $ handler @es scope0 + where + handler :: forall es'. (Concurrent :> es', IOE :> es') => Ki.Scope -> EffectHandler Conc es' + handler scope env = \case + Fork action -> + localUnliftIO env concStrat \unlift -> + fmap Thread . liftIO . Ki.fork scope $ unlift action + Fork_ action -> + localUnliftIO env concStrat \unlift -> + Ki.fork_ scope $ unlift action + ForkTry action -> + localUnliftIO env concStrat \unlift -> + fmap Thread . liftIO . Ki.forkTry scope $ unlift action + Await (Thread thread) -> + runConcurrent . atomically $ Ki.await thread + AwaitAll -> + runConcurrent . atomically $ Ki.awaitAll scope + Race ma mb -> + localLend @'[Concurrent] env concStrat \lend -> + localUnliftIO env concStrat \unlift -> + Ki.scoped \raceScope -> do + ref <- unlift $ inject $ lend newEmptyMVar + void + $ Ki.fork raceScope + $ unlift + $ lend . putMVar ref . Left =<< ma + void + $ Ki.fork raceScope + $ unlift + $ lend . putMVar ref . Right =<< mb + unlift $ lend $ takeMVar ref + Scoped m -> + localUnlift env concStrat \unliftEff -> + localLend @'[IOE, Concurrent] env concStrat \lend -> + withEffToIO concStrat \unliftIO -> + Ki.scoped \subScope -> + unliftIO + . unliftEff + . lend + . interpose (handler subScope) + . inject + $ m + + +-- | Run 'Conc' in a new Ki scope without trace context propagation. +-- +-- Suitable for tests and contexts where tracing is not needed. +runConc :: (Concurrent :> es, IOE :> es) => Eff (Conc : es) a -> Eff es a +runConc eff = withEffToIO concStrat $ \unlift -> + Ki.scoped $ \scope -> + unlift $ runConcBase (Scope scope) eff + + +-- | The unlift strategy used when running forked actions: a persistent, +-- unlimited concurrent unlift, so forked threads may themselves use the effects +-- of the enclosing computation. Shared with "Atelier.Effects.Conc.Traced". +concStrat :: UnliftStrategy +concStrat = ConcUnlift Persistent Unlimited diff --git a/src/Atelier/Effects/Conc/Traced.hs b/src/Atelier/Effects/Conc/Traced.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Effects/Conc/Traced.hs @@ -0,0 +1,86 @@ +-- | Tracing integration for the 'Conc' effect. +-- +-- Provides interpreters and interposers that automatically propagate +-- OpenTelemetry trace context across thread boundaries using span links. +module Atelier.Effects.Conc.Traced + ( -- * Interpreters + runConc + , runConcByConfig + , runConcTraced + + -- * Interposers + , withConcTracingLinks + ) +where + +import Effectful (IOE, raise, withEffToIO) +import Effectful.Concurrent (Concurrent) +import Effectful.Dispatch.Dynamic (interpose, localLend, localUnlift, passthrough) +import Effectful.Reader.Static (Reader, asks) + +import Ki qualified + +import Atelier.Effects.Conc (Conc (..), Scope (..), concStrat, fork, forkTry, fork_, runConcBase) +import Atelier.Effects.Monitoring.Tracing (Tracing, TracingConfig (..)) + +import Atelier.Effects.Conc qualified as Conc +import Atelier.Effects.Monitoring.Tracing qualified as Tracing + + +-- | Run 'Conc' effect with automatic trace context propagation in a new scope. +runConc :: (Concurrent :> es, IOE :> es, Tracing :> es) => Eff (Conc : es) a -> Eff es a +runConc eff = withEffToIO concStrat $ \unlift -> + Ki.scoped $ \scope -> + unlift $ runConcTraced (Scope scope) eff + + +-- | Run 'Conc' effect, selecting the interpreter based on tracing config. +-- +-- If tracing is enabled, uses 'runConc' for automatic span link propagation. +-- If tracing is disabled, falls back to 'Conc.runConc' to skip the overhead. +runConcByConfig + :: ( Concurrent :> es + , IOE :> es + , Reader TracingConfig :> es + , Tracing :> es + ) + => Eff (Conc : es) a -> Eff es a +runConcByConfig eff = do + tracingEnabled <- asks @TracingConfig (.enabled) + if tracingEnabled then runConc eff else Conc.runConc eff + + +-- | Run 'Conc' effect with automatic trace context propagation. +-- +-- All fork variants ('fork', 'fork_', 'forkTry') use span links, i.e. forked +-- threads start a fresh trace whose root spans carry a link back to the +-- originating span. +runConcTraced + :: ( Concurrent :> es + , IOE :> es + , Tracing :> es + ) + => Scope -> Eff (Conc : es) a -> Eff es a +runConcTraced scope = runConcBase scope . withConcTracingLinks + + +-- | Intercept fork operations and wrap the forked action with span link propagation. +-- +-- Re-dispatches to the underlying 'Conc' handler via 'fork', 'fork_', 'forkTry'. +withConcTracingLinks :: (Conc :> es, Tracing :> es) => Eff es a -> Eff es a +withConcTracingLinks = interpose \env -> \case + Fork action -> tracedFork env action fork + Fork_ action -> tracedFork env action fork_ + ForkTry action -> tracedFork env action forkTry + other -> passthrough env other + where + tracedFork env action kiOp = do + parentCtx <- Tracing.getSpanContext + localUnlift env concStrat \unliftEff -> + localLend @'[Tracing] env concStrat \lend -> + kiOp + $ unliftEff + . lend + . Tracing.withLinkPropagation parentCtx + . raise @Tracing + $ action diff --git a/src/Atelier/Effects/Console.hs b/src/Atelier/Effects/Console.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Effects/Console.hs @@ -0,0 +1,69 @@ +-- | An effect for writing bytes and text to an output stream. +-- +-- The single primitive is 'putStr' (raw bytes); 'putStrLn', 'putText' and +-- 'putTextLn' build on it. 'runConsole' writes to stdout, 'runConsoleHandle' to +-- any 'Handle', and 'runConsoleToList' captures output for tests. +module Atelier.Effects.Console + ( -- * Effect + Console + , putStrLn + , putStr + , putTextLn + , putText + + -- * Interpreters + , runConsoleHandle + , runConsole + , runConsoleToList + ) where + +import Effectful (Effect, IOE) +import Effectful.Dispatch.Dynamic (interpret_, reinterpret_) +import Effectful.State.Static.Shared (modify, runState) +import Effectful.TH (makeEffect) +import System.IO (Handle, stdout) +import Prelude + +import Data.ByteString.Char8 qualified as B8 + + +-- | Effect for writing output to a stream. +data Console :: Effect where + -- | Write raw bytes to the output. + PutStr :: ByteString -> Console m () + + +makeEffect ''Console + + +-- | Write a 'ByteString' followed by a newline. +putStrLn :: (Console :> es) => ByteString -> Eff es () +putStrLn = putStr . (<> "\n") + + +-- | Write 'Text', encoded as UTF-8 bytes. +putText :: (Console :> es) => Text -> Eff es () +putText = putStr . encodeUtf8 + + +-- | Write 'Text' as UTF-8 bytes, followed by a newline. +putTextLn :: (Console :> es) => Text -> Eff es () +putTextLn = putStrLn . encodeUtf8 + + +-- | Interpret 'Console' by writing to the given 'Handle'. +runConsoleHandle :: (IOE :> es) => Handle -> Eff (Console : es) a -> Eff es a +runConsoleHandle h = interpret_ \case + PutStr s -> liftIO $ B8.hPut h s + + +-- | Interpret 'Console' by writing to 'stdout'. +runConsole :: (IOE :> es) => Eff (Console : es) a -> Eff es a +runConsole = runConsoleHandle stdout + + +-- | Interpret 'Console' by collecting all writes into a list, in order. Useful +-- for asserting on output in tests. +runConsoleToList :: Eff (Console : es) a -> Eff es (a, [ByteString]) +runConsoleToList = reinterpret_ (fmap (second reverse) . runState []) \case + PutStr s -> modify (s :) diff --git a/src/Atelier/Effects/Debounce.hs b/src/Atelier/Effects/Debounce.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Effects/Debounce.hs @@ -0,0 +1,181 @@ +-- | Debounce effect for coalescing rapid bursts of keyed events. +-- +-- == Overview +-- +-- 'debouncedWith' is the fundamental operation: it accumulates rapid successive +-- calls with the same key using a merge function, then fires the callback once +-- after the settle window with the merged result. +-- +-- 'debounced' is a convenience wrapper for the common case where only timing +-- matters and the last-registered action should fire. +-- +-- == Example +-- +-- @ +-- -- Coalesce rapid saves per file: only the last edit within a 200ms window +-- -- triggers a rebuild, keyed by path. +-- onEdit :: (Debounce FilePath :> es) => FilePath -> Eff es () +-- onEdit path = debounced 200 path (rebuild path) +-- +-- -- Or merge the burst instead of keeping just the last value. Here every +-- -- event seen within the window is combined (list append) before a single +-- -- rebuild fires with the full batch. +-- onChange :: (Debounce FilePath :> es) => FilePath -> FileEvent -> Eff es () +-- onChange path event = +-- debouncedWith 200 (<>) path [event] (rebuildWith path) +-- @ +module Atelier.Effects.Debounce + ( -- * Effect + Debounce + , debouncedWith + , debounced + + -- * Interpreters + , runDebounce + , runDebounceNoOp + + -- * Helpers + , ensureEntry + , ensureCallback + , Entry (..) + ) where + +import Data.Dynamic (Dynamic, fromDynamic, toDyn) +import Effectful (Effect, Limit (..), Persistence (..), UnliftStrategy (..)) +import Effectful.Concurrent (Concurrent) +import Effectful.Concurrent.STM (STM) +import Effectful.Dispatch.Dynamic (interpretWith, localSeqUnlift, localUnlift) +import Effectful.TH (makeEffect) + +import Effectful.Concurrent.STM qualified as STM +import StmContainers.Map qualified as Map + +import Atelier.Effects.Conc (Conc) +import Atelier.Effects.Delay (Delay) +import Atelier.Time (Millisecond) + +import Atelier.Effects.Conc qualified as Conc +import Atelier.Effects.Delay qualified as Delay + + +-- | Effect for coalescing rapid bursts of keyed events into a single delayed +-- callback. +data Debounce key :: Effect where + -- | Schedule @callback merged@ after the settle window. If another call + -- with the same @key@ arrives before the window expires, the two values are + -- combined with @merge old new@ and the timer resets. The callback fires at + -- most once per burst. + DebouncedWith + :: (Typeable arg) + => Millisecond + -> (arg -> arg -> arg) + -> key + -> arg + -> (arg -> m a) + -> Debounce key m () + + +makeEffect ''Debounce + + +-- | Schedule @action@ to run after the settle window unless a newer call with +-- the same @key@ arrives first. The last-registered action fires. +debounced :: (Debounce key :> es) => Millisecond -> key -> Eff es a -> Eff es () +debounced settleMs key action = debouncedWith settleMs (\_ _ -> ()) key () (\_ -> action) + + +-- | Per-key debounce state: the latest (merged) pending argument and a +-- generation counter used to tell whether a scheduled fire is still the most +-- recent call for that key. +data Entry = Entry + { arg :: Maybe Dynamic + -- ^ The latest pending argument (type-erased), or 'Nothing' once consumed. + , generation :: Int + -- ^ Counter bumped on every call for the key; identifies the latest one. + } + + +-- | Run the 'Debounce' effect. +-- +-- Each key maintains a generation counter. Rapid calls for the same key merge +-- their values and reset the settle timer; only the last generation fires. +runDebounce + :: forall key es a + . ( Conc :> es + , Concurrent :> es + , Delay :> es + , Hashable key + ) + => Eff (Debounce key : es) a + -> Eff es a +runDebounce eff = do + state <- STM.atomically (Map.new @key @Entry) + interpretWith eff \env -> \case + DebouncedWith settleMs merge key arg callback -> do + entry <- STM.atomically $ ensureEntry key arg state merge + localUnlift env (ConcUnlift Persistent (Limited 1)) \unlift -> + void + $ Conc.fork + $ ensureCallback settleMs state key entry.generation + $ unlift . callback + + +-- | Sleep for @settleMs@, then atomically check whether this fork's +-- @generation@ is still the latest in the map for @key@. If yes, take the +-- (possibly merged) argument, remove the entry, and fire the callback. If a +-- newer call has bumped the generation in the meantime, exit silently. +ensureCallback + :: forall key arg es a + . ( Concurrent :> es + , Delay :> es + , Hashable key + , Typeable arg + ) + => Millisecond + -> Map.Map key Entry + -> key + -> Int + -> (arg -> Eff es a) + -> Eff es () +ensureCallback settleMs state key myGeneration callback = do + Delay.wait settleMs + fire <- STM.atomically do + Map.lookup key state >>= \case + Just e | e.generation == myGeneration -> do + Map.delete key state + pure $ fromDynamic =<< e.arg + _ -> pure Nothing + case fire of + Just arg -> void $ callback arg + Nothing -> pure () + + +ensureEntry + :: (Hashable key, Typeable value) + => key + -> value + -> Map.Map key Entry + -> (value -> value -> value) + -> STM Entry +ensureEntry key value state merge = do + current <- Map.lookup key state + let (gen, prior) = case current of + Nothing -> (0, Nothing) + Just e -> (e.generation + 1, e.arg >>= fromDynamic) + let merged = case prior of + Just p -> merge p value + Nothing -> value + let updatedEntry = + Entry + { arg = Just (toDyn merged) + , generation = gen + } + Map.insert updatedEntry key state + pure updatedEntry + + +-- | No-op interpreter — fires every callback immediately with its value, without +-- debouncing. Useful for tests where timing is controlled externally. +runDebounceNoOp :: Eff (Debounce key : es) a -> Eff es a +runDebounceNoOp eff = interpretWith eff \env -> \case + DebouncedWith _ _ _ value callback -> localSeqUnlift env \unlift -> void $ unlift (callback value) diff --git a/src/Atelier/Effects/Delay.hs b/src/Atelier/Effects/Delay.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Effects/Delay.hs @@ -0,0 +1,56 @@ +-- | An effect for delaying execution. +-- +-- 'wait' suspends the current thread for a 'TimeUnit' duration; 'every' repeats +-- an action forever with a fixed gap between runs. 'runDelay' performs real +-- delays, while 'runDelayNoOp' skips them so time-based code runs instantly +-- under test. +-- +-- @ +-- -- pause within a workflow: +-- wait (250 :: Millisecond) +-- +-- -- run a health check every 30 seconds, forever (the caller forks it): +-- fork_ $ every (30 :: Second) checkHealth +-- @ +module Atelier.Effects.Delay + ( Delay + , wait + , every + , runDelay + , runDelayNoOp + ) where + +import Data.Time.Units (TimeUnit, toMicroseconds) +import Effectful (Effect) +import Effectful.Concurrent (Concurrent, threadDelay) +import Effectful.Dispatch.Dynamic (interpret_) +import Effectful.TH (makeEffect) + + +-- | Effect for suspending execution for a given duration. +data Delay :: Effect where + -- | Halt the thread and wait for the passed duration before continuing. + Wait :: (TimeUnit t) => t -> Delay m () + + +makeEffect ''Delay + + +-- | Runs an action repeatedly, waiting the given duration in between each +-- execution, starting immediately. Returns Void since it runs forever. +-- Caller is responsible for forking. +every :: (Delay :> es, TimeUnit t) => t -> Eff es () -> Eff es Void +every delay action = forever do + action + wait delay + + +-- | Interpret 'Delay' using real thread delays. +runDelay :: (Concurrent :> es) => Eff (Delay : es) a -> Eff es a +runDelay = interpret_ \(Wait delay) -> + threadDelay $ fromIntegral (toMicroseconds delay) + + +-- | Delay interpreter that makes every 'wait' a no-op — useful in unit tests. +runDelayNoOp :: Eff (Delay : es) a -> Eff es a +runDelayNoOp = interpret_ \(Wait _) -> pure () diff --git a/src/Atelier/Effects/Env.hs b/src/Atelier/Effects/Env.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Effects/Env.hs @@ -0,0 +1,35 @@ +-- | An effect for reading process environment variables. +-- +-- 'runEnv' reads the real process environment; 'runEnvConst' supplies a fixed +-- association list for tests. +module Atelier.Effects.Env + ( Env + , getEnvironment + , runEnv + , runEnvConst + ) where + +import Effectful (Effect, IOE) +import Effectful.Dispatch.Dynamic (interpret_) +import Effectful.TH (makeEffect) + +import System.Environment qualified as System + + +-- | Effect for reading the process environment. +data Env :: Effect where + -- | The full environment as a list of @(name, value)@ pairs. + GetEnvironment :: Env m [(String, String)] + + +makeEffect ''Env + + +-- | Interpret 'Env' against the real process environment. +runEnv :: (IOE :> es) => Eff (Env : es) a -> Eff es a +runEnv = interpret_ $ \GetEnvironment -> liftIO System.getEnvironment + + +-- | Interpret 'Env' with a fixed environment, for tests. +runEnvConst :: [(String, String)] -> Eff (Env : es) a -> Eff es a +runEnvConst env = interpret_ $ \GetEnvironment -> pure env diff --git a/src/Atelier/Effects/Exit.hs b/src/Atelier/Effects/Exit.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Effects/Exit.hs @@ -0,0 +1,55 @@ +-- | An effect for terminating the program with an exit code. +-- +-- 'runExit' really exits the process; 'runExitNoOp' captures the exit code +-- instead, so tests can assert on it without killing the test runner. +module Atelier.Effects.Exit + ( -- * Effect + Exit + , exitWith + , exitSuccess + , exitFailure + + -- * Interpreters + , runExit + , runExitNoOp + ) where + +import Effectful (Effect, IOE) +import Effectful.Dispatch.Dynamic (interpret_, reinterpret_) +import Effectful.Error.Static (runErrorNoCallStack, throwError) +import Effectful.TH (makeEffect) +import System.Exit (ExitCode (..)) + +import System.Exit qualified as IO + + +-- | Effect for terminating the program with an exit code. +data Exit :: Effect where + -- | Terminate the program with the given 'ExitCode'. Does not return. + ExitWith :: ExitCode -> Exit m a + + +makeEffect ''Exit + + +-- | Exit the program successfully (exit code 0). +exitSuccess :: (Exit :> es) => Eff es a +exitSuccess = exitWith ExitSuccess + + +-- | Exit the program with a generic failure (exit code 1). +exitFailure :: (Exit :> es) => Eff es a +exitFailure = exitWith (ExitFailure 1) + + +-- | Interpret 'Exit' by actually terminating the process. +runExit :: (IOE :> es) => Eff (Exit : es) a -> Eff es a +runExit = interpret_ \(ExitWith code) -> liftIO (IO.exitWith code) + + +-- | Exit interpreter that captures exit calls instead of terminating the process. +-- Returns 'Left' the exit code if the action exited, 'Right' the result otherwise. +-- Useful in unit tests. +runExitNoOp :: Eff (Exit : es) a -> Eff es (Either ExitCode a) +runExitNoOp = + reinterpret_ (runErrorNoCallStack @ExitCode) \(ExitWith code) -> throwError code diff --git a/src/Atelier/Effects/File.hs b/src/Atelier/Effects/File.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Effects/File.hs @@ -0,0 +1,103 @@ +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +-- | A handle-based file IO effect. +-- +-- A thin 'Eff' wrapper over the handle operations in "System.IO" and +-- "Data.Text.IO" ('withFile', 'hPutText', 'hGetLine', …), so file IO passes +-- through the effect system instead of raw 'IO'. 'Handle' and 'BufferMode' are +-- re-exported for convenience. +module Atelier.Effects.File + ( File + , Handle + , BufferMode (..) + , withFile + , hClose + , hFlush + , hGetLine + , hPutText + , hPutTextLn + , hPutLBs + , hPutLBsLn + , hIsEOF + , hSetBuffering + , runFile + ) where + +import Effectful (Dispatch (..), DispatchOf, Effect, IOE) +import Effectful.Dispatch.Static + ( SideEffects (..) + , StaticRep + , evalStaticRep + , unsafeEff_ + , unsafeSeqUnliftIO + ) +import System.IO (BufferMode (..), Handle) +import Prelude + +import Data.ByteString.Lazy.Char8 qualified as LB8 +import Data.Text.IO qualified as TIO +import System.IO qualified as IO + + +-- | Operations concerning file handles. +data File :: Effect + + +type instance DispatchOf File = Static WithSideEffects +data instance StaticRep File = File + + +-- | Lifted `System.IO.withFile`: +withFile :: (File :> es, HasCallStack) => FilePath -> IOMode -> (Handle -> Eff es a) -> Eff es a +withFile fp m f = unsafeSeqUnliftIO \unlift -> IO.withFile fp m (unlift . f) + + +-- | Lifted `System.IO.hClose`. +hClose :: (File :> es, HasCallStack) => Handle -> Eff es () +hClose = unsafeEff_ . IO.hClose + + +-- | Lifted `System.IO.hFlush`. +hFlush :: (File :> es, HasCallStack) => Handle -> Eff es () +hFlush = unsafeEff_ . IO.hFlush + + +-- | Lifted `System.IO.hGetLine`. +hGetLine :: (File :> es, HasCallStack) => Handle -> Eff es Text +hGetLine = unsafeEff_ . fmap toText . IO.hGetLine + + +-- | Lifted `Data.Text.IO.hPutStr`. Encodes via the handle's text encoding, +-- symmetric with `hGetLine`. +hPutText :: (File :> es, HasCallStack) => Handle -> Text -> Eff es () +hPutText h = unsafeEff_ . TIO.hPutStr h + + +-- | `hPutText` with a `\n` at the end. +hPutTextLn :: (File :> es, HasCallStack) => Handle -> Text -> Eff es () +hPutTextLn h = unsafeEff_ . TIO.hPutStrLn h + + +-- | Lifted `System.IO.hIsEOF`. +hIsEOF :: (File :> es, HasCallStack) => Handle -> Eff es Bool +hIsEOF = unsafeEff_ . IO.hIsEOF + + +-- | Lifted `Data.ByteString.Lazy.Char8.hPutStr`. +hPutLBs :: (File :> es, HasCallStack) => Handle -> LByteString -> Eff es () +hPutLBs h s = unsafeEff_ $ LB8.hPutStr h s + + +-- | Lifted `System.IO.hSetBuffering`. +hSetBuffering :: (File :> es, HasCallStack) => Handle -> BufferMode -> Eff es () +hSetBuffering h m = unsafeEff_ $ IO.hSetBuffering h m + + +-- | `hPutLBs` with a `\n` at the end. +hPutLBsLn :: (File :> es, HasCallStack) => Handle -> LByteString -> Eff es () +hPutLBsLn h = hPutLBs h . (<> "\n") + + +-- | Run file operations. +runFile :: (HasCallStack, IOE :> es) => Eff (File : es) a -> Eff es a +runFile = evalStaticRep File diff --git a/src/Atelier/Effects/FileSystem.hs b/src/Atelier/Effects/FileSystem.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Effects/FileSystem.hs @@ -0,0 +1,158 @@ +-- | An effect for filesystem operations: reading files, listing and creating +-- directories, and querying paths. +-- +-- 'runFileSystemIO' performs real filesystem IO; 'runFileSystemNoOp' returns +-- inert results; and 'runFileSystemState' simulates a filesystem backed by an +-- in-memory 'Map' for tests. 'followFile' tails a file as it grows. +module Atelier.Effects.FileSystem + ( FileSystem (..) + , readFileBs + , readFileLbsFrom + , readFileLbs + , followFile + , doesFileExist + , doesPathExist + , listDirectory + , createDirectoryIfMissing + , removeFile + , canonicalizePath + , getCurrentDirectory + , getXdgRuntimeDir + , runFileSystemIO + , runFileSystemNoOp + , runFileSystemState + ) where + +import Control.Exception (bracket) +import Effectful (Effect, IOE) +import Effectful.Dispatch.Dynamic (interpret_) +import Effectful.Exception (throwIO) +import Effectful.State.Static.Shared (State, gets, modify) +import Effectful.TH (makeEffect) +import System.Environment (lookupEnv) +import System.IO.Error (userError) +import System.Posix.Types (COff (..), FileOffset) + +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as LBS +import Data.Map.Strict qualified as M +import System.Directory qualified as Dir +import System.Posix.IO qualified as Posix + +import Atelier.Effects.Delay (Delay) +import Atelier.Effects.Posix.IO (readFdFrom) +import Atelier.Time (Millisecond) + +import Atelier.Effects.Delay qualified as Delay + + +-- | Effect for filesystem access. +data FileSystem :: Effect where + -- | Read a file's full contents strictly. + ReadFileBs :: FilePath -> FileSystem m ByteString + -- | Read a file from the given byte offset to the end, lazily. + ReadFileLbsFrom :: FilePath -> FileOffset -> FileSystem m LBS.ByteString + -- | Does a regular file exist at the path? + DoesFileExist :: FilePath -> FileSystem m Bool + -- | Does anything (file or directory) exist at the path? + DoesPathExist :: FilePath -> FileSystem m Bool + -- | List the entries of a directory. + ListDirectory :: FilePath -> FileSystem m [FilePath] + -- | Create a directory. The 'Bool' requests creation of missing parents. + CreateDirectoryIfMissing :: Bool -> FilePath -> FileSystem m () + -- | Delete a file. + RemoveFile :: FilePath -> FileSystem m () + -- | Resolve a path to a canonical, absolute form. + CanonicalizePath :: FilePath -> FileSystem m FilePath + -- | The process's current working directory. + GetCurrentDirectory :: FileSystem m FilePath + -- | The XDG runtime directory (@$XDG_RUNTIME_DIR@), falling back to @\/tmp@. + GetXdgRuntimeDir :: FileSystem m FilePath + + +makeEffect ''FileSystem + + +-- | Read a file's full contents lazily (equivalent to reading from offset 0). +readFileLbs :: (FileSystem :> es) => FilePath -> Eff es LBS.ByteString +readFileLbs path = readFileLbsFrom path 0 + + +-- | Follow a file as it grows, calling @onChunk@ with each new chunk of +-- content. Polls every 200ms. Does not return. +followFile + :: (Delay :> es, FileSystem :> es) + => FilePath + -> (ByteString -> Eff es ()) + -> Eff es a +followFile path onChunk = go 0 + where + go offset = do + newContent <- readFileLbsFrom path offset + if LBS.null newContent then pure () else onChunk (LBS.toStrict newContent) + Delay.wait (200 :: Millisecond) + go (offset + fromIntegral (LBS.length newContent)) + + +-- | Interpret 'FileSystem' against the real filesystem. +runFileSystemIO :: (IOE :> es) => Eff (FileSystem : es) a -> Eff es a +runFileSystemIO = interpret_ $ \case + ReadFileBs path -> liftIO $ BS.readFile path + ReadFileLbsFrom path offset -> + liftIO + $ bracket + (Posix.openFd path Posix.ReadOnly Posix.defaultFileFlags) + Posix.closeFd + (readFdFrom offset) + DoesFileExist path -> liftIO $ Dir.doesFileExist path + DoesPathExist path -> liftIO $ Dir.doesPathExist path + ListDirectory path -> liftIO $ Dir.listDirectory path + CreateDirectoryIfMissing p path -> liftIO $ Dir.createDirectoryIfMissing p path + RemoveFile path -> liftIO $ Dir.removeFile path + CanonicalizePath path -> liftIO $ Dir.canonicalizePath path + GetCurrentDirectory -> liftIO Dir.getCurrentDirectory + GetXdgRuntimeDir -> liftIO $ fromMaybe "/tmp" <$> lookupEnv "XDG_RUNTIME_DIR" + + +-- | Interpret 'FileSystem' with inert results: reads return empty, existence +-- checks return 'False', and mutations do nothing. Useful for tests. +runFileSystemNoOp :: Eff (FileSystem : es) a -> Eff es a +runFileSystemNoOp = interpret_ $ \case + ReadFileBs _ -> pure mempty + ReadFileLbsFrom _ _ -> pure mempty + DoesFileExist _ -> pure False + DoesPathExist _ -> pure False + ListDirectory _ -> pure [] + CreateDirectoryIfMissing _ _ -> pure () + RemoveFile _ -> pure () + CanonicalizePath path -> pure path + GetCurrentDirectory -> pure "." + GetXdgRuntimeDir -> pure "/tmp" + + +-- | Run `FileSystem` effect backed by a `State` effect with a `Map`. The keys +-- of the `Map` are treated as file names. Only the `dirname` of files are +-- counted as existing directories. +runFileSystemState + :: (State (Map FilePath ByteString) :> es) + => Eff (FileSystem : es) a -> Eff es a +runFileSystemState = interpret_ \case + ReadFileBs fp -> + maybe (throwIO $ userError "No such file") pure + =<< gets (M.lookup fp) + ReadFileLbsFrom fp (COff offset) -> do + contents <- + maybe (throwIO $ userError "No such file") pure + =<< gets (M.lookup fp) + pure + . toLazy + . BS.drop (fromIntegral offset) + $ contents + DoesFileExist fp -> gets $ M.member fp + DoesPathExist fp -> gets $ any (\p -> fp `isPrefixOf` p && fp /= p) . M.keys + ListDirectory fp -> gets $ filter (\p -> fp `isPrefixOf` p && fp /= p) . M.keys + CreateDirectoryIfMissing _ _ -> pure () + RemoveFile fp -> modify $ M.delete fp + CanonicalizePath fp -> pure fp + GetCurrentDirectory -> pure "/" + GetXdgRuntimeDir -> pure "/tmp" diff --git a/src/Atelier/Effects/FileWatcher.hs b/src/Atelier/Effects/FileWatcher.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Effects/FileWatcher.hs @@ -0,0 +1,247 @@ +-- | Effect and smart constructors for watching file system paths. +-- +-- == Overview +-- +-- Build a list of 'Watch' values describing what to observe, then pass them +-- to 'watchFilePaths'. The effect registers the OS-level watchers needed to +-- cover the list (deduplication by path prefix) and fires the callback at most +-- once per raw filesystem event for a path. +-- +-- == Examples +-- +-- Watch a source directory for Haskell files, ignoring build artefacts: +-- +-- @ +-- watchFilePaths [dirExt "src" ".hs" \`excluding\` containing "dist-newstyle"] callback +-- @ +-- +-- Watch source and test directories together: +-- +-- @ +-- watchFilePaths (map (\`dirExt\` ".hs") ["src", "test"]) callback +-- @ +-- +-- Watch cabal-related files anywhere under a project root: +-- +-- @ +-- watchFilePaths [dirWhere projectRoot isCabalFile] callback +-- where +-- isCabalFile f = takeExtension f == ".cabal" +-- || takeFileName f \`elem\` ["cabal.project", "package.yaml"] +-- @ +-- +-- Combine source and cabal watches with a single callback that dispatches on +-- the path, with automatic debouncing: +-- +-- @ +-- watchFilePathsDebounced (sourceWatches ++ cabalWatches) (markDirty . changeKindFor) +-- @ +module Atelier.Effects.FileWatcher + ( -- * Watch specification + Watch + + -- ** Constructors + , dir + , dirExt + , dirWhere + + -- ** Combinators + , excluding + , containing + + -- * File events + , FileEvent (..) + , mergeFileEvent + + -- * Effect + , FileWatcher + , watchFilePaths + , watchFilePathsDebounced + + -- * Interpreters + , runFileWatcherIO + , runFileWatcherScripted + + -- * Internals (exported for testing) + , deduplicateDirs + , matchesAny + ) where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.STM (retry) +import Data.List (nub) +import Effectful (Effect, IOE) +import Effectful.Concurrent (Concurrent) +import Effectful.Concurrent.STM (atomically) +import Effectful.Dispatch.Dynamic (interpretWith, localSeqUnlift, localUnliftIO, reinterpret) +import Effectful.State.Static.Shared (evalState, get, put) +import Effectful.TH (makeEffect) +import System.Directory (makeAbsolute) +import System.FSNotify (eventPath, watchTree, withManager) +import System.FilePath (takeExtension) + +import Data.Text qualified as T +import System.FSNotify qualified as FSN + +import Atelier.Effects.Conc (concStrat) +import Atelier.Effects.Debounce (Debounce, debouncedWith) + + +-- | The kind of filesystem change that triggered a watch callback. +data FileEvent + = -- | A new file was created. + Added + | -- | An existing file was modified. + Modified + | -- | A file was deleted. + Removed + deriving stock (Eq, Show) + + +-- | Merge two 'FileEvent's for the same path within a debounce window. +-- +-- Rules (old, new) → result: +-- +-- * @(_, Removed)@ → @Removed@: deletion always wins. +-- * @(Removed, Added)@ → @Added@: explicit re-creation after deletion. +-- * @(Added, _)@ → @Added@: a create-then-write is still a creation. +-- * Otherwise → the newer event. +mergeFileEvent :: FileEvent -> FileEvent -> FileEvent +mergeFileEvent _ Removed = Removed +mergeFileEvent Removed Added = Added +mergeFileEvent Added _ = Added +mergeFileEvent _ event = event + + +-- | Specification of a directory to watch recursively, with a file predicate. +data Watch = Watch FilePath (FilePath -> Bool) + + +-- | Watch all files in a directory recursively. +dir :: FilePath -> Watch +dir p = Watch p (const True) + + +-- | Watch files matching a predicate in a directory recursively. +-- +-- @ +-- dirWhere "src" (\f -> takeExtension f == ".hs") +-- @ +dirWhere :: FilePath -> (FilePath -> Bool) -> Watch +dirWhere = Watch + + +-- | Watch files with a specific extension in a directory recursively. +-- +-- @ +-- dirExt "src" ".hs" +-- @ +dirExt :: FilePath -> Text -> Watch +dirExt p ext = dirWhere p (\f -> toText (takeExtension f) == ext) + + +-- | Narrow a 'Watch' to exclude files matching a predicate. +-- +-- @ +-- dirExt "src" ".hs" \`excluding\` containing "dist-newstyle" +-- @ +excluding :: Watch -> (FilePath -> Bool) -> Watch +excluding (Watch p predicate) excl = Watch p (\f -> predicate f && not (excl f)) + + +-- | Predicate: the file path contains the given fragment. +-- +-- Intended for use with 'excluding': +-- +-- @ +-- dir "src" \`excluding\` containing "dist-newstyle" +-- @ +containing :: Text -> FilePath -> Bool +containing fragment f = fragment `T.isInfixOf` toText f + + +data FileWatcher :: Effect where + -- | Watch the given directories for changes, calling the callback with + -- each matching file path and the kind of change that occurred. Registers + -- the minimal set of OS watchers needed to cover all entries (deduplication + -- by path prefix). The callback is invoked at most once per raw filesystem + -- event regardless of how many entries match. Never returns. + WatchFilePaths :: [Watch] -> (FilePath -> FileEvent -> m a) -> FileWatcher m Void + + +makeEffect ''FileWatcher + + +-- | Like 'watchFilePaths' but automatically debounces by path. +-- Rapid successive events for the same file coalesce into a single callback. +-- Uses a 100ms settle window. +watchFilePathsDebounced + :: (Debounce FilePath :> es, FileWatcher :> es) + => [Watch] + -> (FilePath -> FileEvent -> Eff es ()) + -> Eff es Void +watchFilePathsDebounced watches callback = + watchFilePaths watches \path event -> + debouncedWith 100 mergeFileEvent path event (callback path) + + +-- | Production interpreter backed by fsnotify. +runFileWatcherIO :: (IOE :> es) => Eff (FileWatcher : es) a -> Eff es a +runFileWatcherIO eff = interpretWith eff \env -> \case + WatchFilePaths watches callback -> + localUnliftIO env concStrat \unliftIO -> do + absWatches <- forM watches \(Watch p predicate) -> + (\absP -> Watch absP predicate) <$> makeAbsolute p + withManager \mgr -> do + let dedupedDirs = deduplicateDirs [p | Watch p _ <- absWatches] + for_ dedupedDirs \d -> + watchTree mgr d (matchesAny absWatches . eventPath) \fsEvent -> + void $ unliftIO $ callback (eventPath fsEvent) (toFileEvent fsEvent) + forever $ threadDelay 1_000_000 + + +-- | Scripted interpreter for testing. +-- Delivers all scripted events to the callback in order, then blocks +-- indefinitely — matching the blocking semantics of 'runFileWatcherIO'. +-- The 'Watch' specification is ignored; the caller controls what events are fed in. +runFileWatcherScripted :: (Concurrent :> es) => [(FilePath, FileEvent)] -> Eff (FileWatcher : es) a -> Eff es a +runFileWatcherScripted events = reinterpret (evalState events) \env -> \case + WatchFilePaths _ callback -> + localSeqUnlift env \unlift -> do + events' <- get + put [] + for_ events' \(path, fileEvent) -> unlift $ callback path fileEvent + atomically retry + + +-- Helpers + +toFileEvent :: FSN.Event -> FileEvent +toFileEvent = \case + FSN.Added {} -> Added + FSN.Modified {} -> Modified + FSN.ModifiedAttributes {} -> Modified + FSN.CloseWrite {} -> Modified + FSN.Removed {} -> Removed + FSN.WatchedDirectoryRemoved {} -> Removed + FSN.Unknown {} -> Modified + + +-- | Remove dirs that are proper subdirectories of another dir in the list. +deduplicateDirs :: [FilePath] -> [FilePath] +deduplicateDirs dirs = filter notRedundant (nub dirs) + where + notRedundant d = not $ any (\d' -> d' /= d && isStrictAncestor d' d) dirs + + +-- | @isStrictAncestor parent child@ is true iff @parent@ is a proper ancestor +-- of @child@ in the filesystem hierarchy. +isStrictAncestor :: FilePath -> FilePath -> Bool +isStrictAncestor parent child = (parent <> "/") `isPrefixOf` child + + +-- | Check whether a file path matches at least one 'Watch' entry. +matchesAny :: [Watch] -> FilePath -> Bool +matchesAny watches path = any matches watches + where + matches (Watch d predicate) = (d == path || isStrictAncestor d path) && predicate path diff --git a/src/Atelier/Effects/Input.hs b/src/Atelier/Effects/Input.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Effects/Input.hs @@ -0,0 +1,47 @@ +-- | An effect for requesting a value from the environment on each call. +-- +-- Unlike 'Effectful.Reader.Static.Reader', 'Input' makes no assumption that the +-- value is stable across the computation — each 'input' may observe a different +-- value. See the 'Input' type below for the full comparison. +module Atelier.Effects.Input + ( Input + , input + , runInputEff + , runInputConst + ) where + +import Effectful (Effect) +import Effectful.Dispatch.Dynamic (interpret_) +import Effectful.TH (makeEffect) + + +-- | Request a value from the effect system. +-- +-- This effect does not carry any +-- semantics as to how the value is created, whether it is cached, or whether +-- you get a different value for each call. It is similar to +-- 'Effectful.Reader.Static.Reader' in that it is about requesting a value, but +-- 'Reader' carries the implicit assumption that its value remains static for +-- the duration of the encapsulated computation, while 'Input' carries no such +-- assumption. +-- +-- If the value you wish to request from the effect system will remain +-- unchanged for the duration of the computation, use 'Effectful.Reader.Static' +-- or 'Effectful.Reader.Local' instead. +data Input i :: Effect where + Input :: Input i m i + + +makeEffect ''Input + + +-- | Runs the passed effectful action every time 'input' is invoked. +runInputEff :: Eff es i -> Eff (Input i : es) a -> Eff es a +runInputEff mk = interpret_ \Input -> mk + + +-- | Provides the same value for every invocation of the 'input' operation. +-- This is equivalent to using 'Effectful.Reader.Static' or +-- 'Effectful.Reader.Local', but is available here for testing. +runInputConst :: i -> Eff (Input i : es) a -> Eff es a +runInputConst = runInputEff . pure diff --git a/src/Atelier/Effects/Internal/Coroutine.hs b/src/Atelier/Effects/Internal/Coroutine.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Effects/Internal/Coroutine.hs @@ -0,0 +1,225 @@ +-- | Internal: the shared implementation of the 'Yield' and 'Await' coroutine +-- effects. +-- +-- Both effects, along with their operations and interpreters, are defined here; +-- "Atelier.Effects.Yield" and "Atelier.Effects.Await" re-export curated subsets +-- for public use. Exposed chiefly for testing — prefer the public modules. +module Atelier.Effects.Internal.Coroutine + ( -- * Yield + Yield (..) + + -- ** Operations + , yield + , inFoldable + , yieldEvents + , cycleToYield + + -- ** Interpreters + , forEach + , yieldToList + , yieldToReverseList + , withYieldToList + , ignoreYield + , enumerate + , enumerateFrom + , map + , mapMaybe + , catMaybes + + -- * Await + , Await (..) + + -- ** Operations + , await + + -- ** Interpreters + , eachAwait + + -- * Shared + + -- ** Operations + , takeAwait + + -- ** Interpreters + , awaitYield + ) where + +import Effectful (Effect, UnliftStrategy (..), inject, raiseWith) +import Effectful.Dispatch.Dynamic (interpretWith_, interpret_, reinterpretWith_, reinterpret_) +import Effectful.State.Static.Shared (evalState, get, modify, runState, state) +import Effectful.TH (makeEffect) +import Prelude hiding (catMaybes, map, mapMaybe) + +import Atelier.Effects.Chan (Chan) +import Atelier.Effects.Conc (Conc) +import Atelier.Effects.Publishing (Sub) + +import Atelier.Effects.Chan qualified as Chan +import Atelier.Effects.Conc qualified as Conc +import Atelier.Effects.Publishing qualified as Sub + + +-- * Yield + + +-- | Yield values to the effect system. The producing side of the +-- 'Yield'/'Await' pair. Analogous to 'Writer' and 'Output' effects. +data Yield a :: Effect where + Yield :: a -> Yield a m () + + +makeEffect ''Yield + + +-- ** Yield operations + + +-- | 'Yield' all elements of a foldable. +inFoldable :: forall a t es. (Foldable t, Yield a :> es) => t a -> Eff es () +inFoldable = + foldl' + ( \prev x -> do + prev + yield x + ) + (pure ()) + + +-- | 'Yield' all elements of a foldable, cycling it 'forever'. +cycleToYield :: forall a f es. (Foldable f, Yield a :> es) => f a -> Eff es () +cycleToYield = forever . inFoldable + + +-- | 'Yield' all events captured from a 'Sub' effect. +yieldEvents :: forall a es. (Conc :> es, Sub a :> es, Yield a :> es) => Eff es () +yieldEvents = Conc.scoped do + Conc.fork_ $ Sub.listen_ yield + pure () + + +-- ** Yield interpreters + + +-- | Perform an action for each value of a 'Yield' stream. +forEach :: (a -> Eff es b) -> Eff (Yield a : es) r -> Eff es r +forEach f = interpret_ \(Yield x) -> void $ f x + + +-- | Collect all 'Yield'ed values into a list. +yieldToList :: Eff (Yield a : es) r -> Eff es (r, [a]) +yieldToList = fmap (second reverse) . yieldToReverseList + + +-- | Collect all 'Yield'ed values into a list. This function is more optimal to +-- use than 'yieldToList' if the reversed order is acceptable. +yieldToReverseList :: Eff (Yield a : es) r -> Eff es (r, [a]) +yieldToReverseList = reinterpret_ (runState []) \(Yield x) -> modify (x :) + + +-- | Allows a computation to 'Yield' values before performing a function over +-- the 'yield'ed values as a list. +withYieldToList :: Eff (Yield a : es) ([a] -> r) -> Eff es r +withYieldToList act = evalState [] do + f <- interpretWith_ (inject act) \(Yield x) -> modify (x :) + xs <- get + pure $ f $ reverse xs + + +-- | Ignore all 'Yield'ed values, discarding them. +ignoreYield :: Eff (Yield a : es) r -> Eff es r +ignoreYield = interpret_ \(Yield _) -> pure () + + +-- | Pair each 'Yield'ed value with its index in the sequence of yielded +-- values. +enumerate :: Eff (Yield a : es) r -> Eff (Yield (Int, a) : es) r +enumerate = enumerateFrom 0 + + +-- | Pair each 'Yield'ed value with its index in the sequence of yielded +-- values, starting from `initial`. +enumerateFrom :: Int -> Eff (Yield a : es) r -> Eff (Yield (Int, a) : es) r +enumerateFrom initial act = raiseWith SeqUnlift \unlift -> + reinterpretWith_ (evalState initial) act \(Yield x) -> do + i <- state \s -> (s, s + 1) + inject $ unlift $ yield (i, x) + + +-- | Map a 'Yield' stream of values into a different 'Yield' stream of values. +-- The consumed stream will not be visible to downstream computations, and the +-- produced stream will not be visible to upstream computations. +map :: (a -> b) -> Eff (Yield a : es) r -> Eff (Yield b : es) r +map f act = raiseWith SeqUnlift \unlift -> + interpretWith_ act \(Yield x) -> unlift $ yield $ f x + + +-- | Map a 'Yield' stream of values. Values returned as 'Just' will be +-- included in the resulting 'Yield' stream. Values returned as 'Nothing' will +-- be discarded. +mapMaybe :: (a -> Maybe b) -> Eff (Yield a : es) r -> Eff (Yield b : es) r +mapMaybe f act = + raiseWith SeqUnlift \unlift -> interpretWith_ act \(Yield x) -> + case f x of + Just y -> unlift $ yield y + Nothing -> pure () + + +-- | Eliminate 'Nothing's from a 'Yield' stream, resulting in a 'Yield' stream +-- with all the 'Just' values. +catMaybes :: Eff (Yield (Maybe a) : es) r -> Eff (Yield a : es) r +catMaybes act = raiseWith SeqUnlift \unlift -> interpretWith_ act \case + Yield (Just x) -> unlift $ yield x + Yield Nothing -> pure () + + +-- * Await + + +-- | Request a value from the effect system. The consuming side of the +-- 'Yield'/'Await' pair. Analogous to 'Reader' and 'Input'. +data Await a :: Effect where + Await :: Await a m a + + +makeEffect ''Await + + +-- ** Await operations + + +-- | Take 'n' values from an 'Await' effect and re-'yield' them to a new +-- 'Yield' event. +-- +-- This operation is of dubious value given how Effectful's effect system +-- works, but it is included here for brevity's sake. +takeAwait :: (Await a :> es, Yield a :> es) => Int -> Eff es () +takeAwait 0 = pure () +takeAwait c = do + await >>= yield + takeAwait (c - 1) + + +-- ** Await interpreters + + +-- | Answers each `Await` with the passed action's result. +eachAwait :: forall a es r. Eff es a -> Eff (Await a : es) r -> Eff es r +eachAwait mk = interpret_ \Await -> mk + + +-- | Supplies the `Await` effect of one computation with the `Yield` effect of +-- another. +awaitYield + :: forall a es r + . (Chan :> es, Conc :> es) + => Eff (Yield a : es) r + -> Eff (Await a : es) r + -> Eff es r +awaitYield yields awaits = Conc.scoped do + (inChan, outChan) <- Chan.newChan @a + let yielder = interpretWith_ yields \(Yield x) -> Chan.writeChan inChan x + awaiter = interpretWith_ awaits \Await -> Chan.readChan outChan + -- Ensure the awaiter runs first. + awaitThread <- Conc.fork awaiter + yieldThread <- Conc.fork yielder + either id id <$> Conc.race (Conc.await awaitThread) (Conc.await yieldThread) diff --git a/src/Atelier/Effects/Iterator.hs b/src/Atelier/Effects/Iterator.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Effects/Iterator.hs @@ -0,0 +1,69 @@ +-- | A pull-based iterator over a (possibly infinite) stream of values. +-- +-- Where the 'Yield' effect pushes values to a consumer, an 'Iterator' is pulled +-- one value at a time with 'next'. 'fromEvents' adapts a 'Sub' event source into +-- an iterator with a buffered, race-free subscription, and a stream can be +-- narrowed with 'filter' and 'changes'. +module Atelier.Effects.Iterator + ( Iterator + , next + , fromEvents + , filter + , changes + ) where + +import Effectful.Concurrent (Concurrent) +import Prelude hiding (filter) + +import Atelier.Effects.Chan (Chan) +import Atelier.Effects.Conc (Conc) +import Atelier.Effects.Publishing (Sub) + +import Atelier.Effects.Chan qualified as Chan +import Atelier.Effects.Conc qualified as Conc +import Atelier.Effects.Publishing qualified as Sub + + +-- | A pull-based iterator of (potentially infinite) values. +newtype Iterator es a = Iterator + { next :: Eff es a + -- ^ Pull the next value from the iterator, performing whatever effects that + -- requires. + } + deriving (Functor) via (Eff es) + + +-- | Run a continuation with a buffered iterator of 'Sub' events. The iterator +-- subscribes before the continuation runs, so no events are missed: we use +-- 'Sub.forkListener_', which forks the listener and blocks until it has +-- actually subscribed before returning. Without that barrier the subscription +-- races a publisher started inside @use@, which under scheduler pressure can +-- drop early events and wedge 'next' forever. The listener thread is scoped to +-- the continuation and is killed when it returns. +fromEvents + :: forall event es a + . (Chan :> es, Conc :> es, Concurrent :> es, Sub event :> es) + => (Iterator es event -> Eff es a) + -> Eff es a +fromEvents use = Conc.scoped do + (inChan, outChan) <- Chan.newChan + Sub.forkListener_ (Chan.writeChan inChan) + use $ Iterator (Chan.readChan outChan) + + +-- | Iterate only over values that pass a predicate. +filter :: (a -> Bool) -> Iterator es a -> Iterator es a +filter p (Iterator n) = Iterator loop + where + loop = do + x <- n + if p x then pure x else loop + + +-- | Iterate only values that differ from the previous one. +changes :: (Eq a) => a -> Iterator es a -> Iterator es a +changes initial iterator = Iterator (loop initial) + where + loop prev = do + x <- next (filter (/= prev) iterator) + pure x diff --git a/src/Atelier/Effects/Log.hs b/src/Atelier/Effects/Log.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Effects/Log.hs @@ -0,0 +1,245 @@ +-- | Log effect with hierarchical namespace support. +-- +-- Provides structured logging with composable namespaces for better organization. +-- +-- == Basic Usage +-- +-- @ +-- myComponent :: (Log :> es) => Eff es () +-- myComponent = do +-- info "Starting component" +-- -- Logs: [INFO] [MyModule.myComponent#42] Starting component +-- @ +-- +-- == Using Namespaces +-- +-- @ +-- processData :: (Log :> es) => Eff es () +-- processData = withNamespace "processor" $ do +-- info "Processing started" +-- -- Logs: [INFO] [processor] [MyModule.processData#10] Processing started +-- +-- withNamespace "validation" $ do +-- info "Validating input" +-- -- Logs: [INFO] [processor.validation] [MyModule.processData#13] Validating input +-- @ +module Atelier.Effects.Log + ( -- * Effect + Log + , Message (..) + , Config (..) + , Severity (..) + , log + , info + , warn + , debug + , err + , withNamespace + + -- * Interpreters + , runLog + , runLogNoOp + , runLogToHandle + , runLogWriter + ) where + +import Data.Aeson (FromJSON (..)) +import Data.Default (Default (..)) +import Data.List (lookup) +import Effectful (Effect, IOE) +import Effectful.Dispatch.Dynamic (localSeqUnlift, reinterpret, reinterpretWith) +import Effectful.Reader.Static (Reader, ask, local, runReader) +import Effectful.TH (makeEffect) +import Effectful.Writer.Static.Shared (Writer, tell) +import System.IO (Handle, hFlush, stdout) + +import Data.ByteString.Char8 qualified as B8 + +import Atelier.Effects.Env (Env, getEnvironment) +import Atelier.Types.JsonReadShow (JsonReadShow (..)) +import Atelier.Types.QuietSnake (QuietSnake (..)) + + +-- | Effect for structured logging with hierarchical namespaces. +data Log :: Effect where + -- | Emit a fully-formed log 'Message'. + LogMsg :: Message -> Log m () + -- | Run an action with an extra namespace segment appended to the current + -- one. + WithNamespace :: Namespace -> m a -> Log m a + -- | Get the namespace in effect for the current action. + GetNamespace :: Log m Namespace + + +-- | A single log record. +data Message = Message + { namespace :: Namespace + -- ^ The hierarchical namespace the message was logged under. + , text :: Text + -- ^ The human-readable message body. + , severity :: Severity + -- ^ The severity level of the message. + , stack :: CallStack + -- ^ The call site, captured via 'HasCallStack'. + } + + +newtype Namespace = Namespace Text + deriving stock (Eq, Show) + deriving newtype (IsString) + + +instance Semigroup Namespace where + Namespace "" <> Namespace b = Namespace b + Namespace a <> Namespace "" = Namespace a + Namespace a <> Namespace b = Namespace (a <> "." <> b) + + +-- | Logging configuration. +data Config = Config + { minimumSeverity :: Severity + -- ^ Messages below this severity are discarded. + } + deriving stock (Eq, Generic, Show) + deriving (FromJSON) via QuietSnake Config + + +-- | Log severity levels, ordered from least to most severe. +data Severity + = -- | Verbose diagnostic detail. + DEBUG + | -- | Normal operational information. + INFO + | -- | Something unexpected, but recoverable. + WARN + | -- | A failure that needs attention. + ERROR + deriving stock (Bounded, Enum, Eq, Ord, Read, Show) + deriving (FromJSON) via (JsonReadShow Severity) + + +instance Default Config where + def = + Config + { minimumSeverity = minBound + } + + +makeEffect ''Log + + +-- | Log a message at the given severity, capturing the current namespace and +-- call site. +log :: (HasCallStack, Log :> es) => Severity -> Text -> Eff es () +log severity text = do + namespace <- getNamespace + withFrozenCallStack + $ logMsg + Message + { stack = callStack + , namespace + , severity + , text + } + + +-- | Log a message at 'DEBUG' severity. +debug :: (HasCallStack, Log :> es) => Text -> Eff es () +debug = withFrozenCallStack $ log DEBUG + + +-- | Log a message at 'INFO' severity. +info :: (HasCallStack, Log :> es) => Text -> Eff es () +info = withFrozenCallStack $ log INFO + + +-- | Log a message at 'WARN' severity. +warn :: (HasCallStack, Log :> es) => Text -> Eff es () +warn = withFrozenCallStack $ log WARN + + +-- | Log a message at 'ERROR' severity. +err :: (HasCallStack, Log :> es) => Text -> Eff es () +err = withFrozenCallStack $ log ERROR + + +-- | Consumes `Log` effects, and discards the logged messages +runLogNoOp :: Eff (Log : es) a -> Eff es a +runLogNoOp = reinterpret (runReader (Namespace "")) $ \env -> \case + LogMsg _ -> pure () + WithNamespace ns act -> localSeqUnlift env $ \unlift -> + local (<> ns) $ unlift act + GetNamespace -> ask + + +-- | Interpret 'Log' by writing formatted messages to stdout. +-- +-- The minimum severity defaults to 'Config'\'s @minimumSeverity@, but can be +-- overridden at runtime by the @DEBUG@, @LOGGING@ or @LOG@ environment +-- variables (checked in that order). +runLog :: (Env :> es, IOE :> es, Reader Config :> es) => Eff (Log : es) a -> Eff es a +runLog action = do + config <- ask + env <- getEnvironment + let overrideLog = (>>= readMaybe) $ lookup "LOG" env + overrideLogging = (>>= readMaybe) $ lookup "LOGGING" env + overrideDebug = (>>= \x -> if x == "0" then Nothing else Just DEBUG) $ lookup "DEBUG" env + let severity = + fromMaybe config.minimumSeverity + $ overrideDebug <|> overrideLogging <|> overrideLog + + reinterpretWith (runReader (Namespace "")) action \lenv -> \case + LogMsg msg -> + liftIO $ when (msg.severity >= severity) do + -- NOTE: We use hPutStr here with an appended newline because + -- hPutStrLn is not atomic for ByteStrings longer than 1024 bytes. + -- Data.Text.IO.hPutStrLn is not atomic for even short Texts. + B8.hPutStr stdout + . encodeUtf8 + . (<> "\n") + . formatMessage + $ msg + hFlush stdout + WithNamespace ns act -> localSeqUnlift lenv $ \unlift -> + local (<> ns) $ unlift act + GetNamespace -> ask + + +-- | Like 'runLog' but writes to the given 'Handle' instead of stdout. +-- Useful for daemons that want to write logs to a file. +runLogToHandle :: (IOE :> es) => Handle -> Severity -> Eff (Log : es) a -> Eff es a +runLogToHandle handle minSeverity action = + reinterpretWith (runReader (Namespace "")) action \env -> \case + LogMsg msg -> + liftIO $ when (msg.severity >= minSeverity) do + B8.hPutStr handle . encodeUtf8 . (<> "\n") . formatMessage $ msg + hFlush handle + WithNamespace ns act -> localSeqUnlift env $ \unlift -> + local (<> ns) $ unlift act + GetNamespace -> ask + + +-- | Interpret 'Log' by collecting messages into a 'Writer', for tests. +runLogWriter :: (Writer [Message] :> es) => Eff (Log : es) a -> Eff es a +runLogWriter = reinterpret (runReader (Namespace "")) $ \env -> \case + LogMsg msg -> tell [msg] + WithNamespace ns act -> localSeqUnlift env $ \unlift -> + local (<> ns) $ unlift act + GetNamespace -> ask + + +formatMessage :: Message -> Text +formatMessage msg = + mconcat + [ square $ show msg.severity + , " " + , showNamespace msg.namespace + , msg.text + ] + where + showNamespace (Namespace "") = "" + showNamespace (Namespace ns) = square ns <> " " + + +square :: Text -> Text +square s = "[" <> s <> "]" diff --git a/src/Atelier/Effects/Monitoring/Metrics.hs b/src/Atelier/Effects/Monitoring/Metrics.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Effects/Monitoring/Metrics.hs @@ -0,0 +1,125 @@ +-- | Metrics effect for Prometheus metrics collection. +-- +-- Provides operations for tracking application metrics. +-- +-- == Basic Usage +-- +-- @ +-- myComponent :: (Metrics :> es) => Eff es () +-- myComponent = do +-- gaugeSet "hoard_connected_peers" 5.0 +-- counterInc "hoard_blocks_received_total" +-- @ +-- +-- == Available Metric Types +-- +-- * Gauges: Point-in-time values that can go up or down +-- * Counters: Monotonically increasing values +-- * Histograms: Distributions with buckets for measuring durations +module Atelier.Effects.Monitoring.Metrics + ( -- * Effect + Metrics + + -- * Gauge Operations + , gaugeSet + , gaugeInc + , gaugeDec + + -- * Counter Operations + , counterInc + , counterAdd + + -- * Histogram Operations + , histogramObserve + , withHistogramTiming + + -- * Export Operations + , exportMetrics + + -- * Interpreters + , runMetrics + , runMetricsNoOp + ) where + +import Data.Time.Clock (diffUTCTime) +import Effectful (Effect, IOE) +import Effectful.Dispatch.Dynamic (interpret, interpretWith, localSeqUnlift) +import Effectful.TH (makeEffect) + +import Prometheus qualified as Prom +import Prometheus.Metric.GHC qualified as GHC + +import Atelier.Effects.Clock (Clock, currentTime) +import Atelier.Effects.Monitoring.Tracing (Tracing, withSpan) + +import Atelier.Effects.Monitoring.Metrics.Registry qualified as Registry + + +-- | Metrics effect for tracking application metrics +data Metrics :: Effect where + -- | Set a named gauge to a specific value. + GaugeSet :: Text -> Double -> Metrics m () + -- | Increment a named gauge by 1. + GaugeInc :: Text -> Metrics m () + -- | Decrement a named gauge by 1. + GaugeDec :: Text -> Metrics m () + -- | Increment a named counter by 1. + CounterInc :: Text -> Metrics m () + -- | Add a value to a named counter. + CounterAdd :: Text -> Double -> Metrics m () + -- | Observe a value in a named histogram. + HistogramObserve :: Text -> Double -> Metrics m () + -- | Time an action and record its duration to a histogram metric + WithHistogramTiming :: Text -> m a -> Metrics m a + -- | Export all collected metrics in Prometheus text format. + ExportMetrics :: Metrics m Text + + +makeEffect ''Metrics + + +-- | Run the Metrics effect with prometheus-client +-- +-- Initializes the metric registry and registers GHC metrics automatically. +runMetrics + :: forall es a + . (Clock :> es, IOE :> es, Tracing :> es) + => Eff (Metrics : es) a + -> Eff es a +runMetrics action = do + -- Initialize metrics registry and register GHC metrics + + handles <- withSpan "metrics.setup" do + void $ liftIO $ Prom.register GHC.ghcMetrics + liftIO Registry.initMetricHandles + + interpretWith action \env -> \case + GaugeSet name value -> withSpan "metrics.gauge_set" $ liftIO $ Registry.setGauge handles name value + GaugeInc name -> withSpan "metrics.gauge_inc" $ liftIO $ Registry.incGauge handles name + GaugeDec name -> withSpan "metrics.gauge_dec" $ liftIO $ Registry.decGauge handles name + CounterInc name -> withSpan "metrics.counter_inc" $ liftIO $ Registry.incCounter handles name + CounterAdd name value -> withSpan "metrics.counter_add" $ liftIO $ Registry.addCounter handles name value + HistogramObserve name value -> withSpan "metrics.histogram_observe" $ liftIO $ Registry.observeHistogram handles name value + WithHistogramTiming metricName eff -> do + start <- currentTime + result <- localSeqUnlift env \unlift -> unlift eff + end <- currentTime + let duration = realToFrac $ diffUTCTime end start + withSpan "metrics.with_histogram_timing.histogram_observe" + $ liftIO + $ Registry.observeHistogram handles metricName duration + pure result + ExportMetrics -> withSpan "metrics.export_metrics" $ liftIO $ decodeUtf8 <$> Prom.exportMetricsAsText + + +-- | No-op interpreter that discards all metrics operations +runMetricsNoOp :: Eff (Metrics : es) a -> Eff es a +runMetricsNoOp = interpret \env -> \case + GaugeSet _ _ -> pure () + GaugeInc _ -> pure () + GaugeDec _ -> pure () + CounterInc _ -> pure () + CounterAdd _ _ -> pure () + HistogramObserve _ _ -> pure () + WithHistogramTiming _ eff -> localSeqUnlift env \unlift -> unlift eff + ExportMetrics -> pure "" diff --git a/src/Atelier/Effects/Monitoring/Metrics/Registry.hs b/src/Atelier/Effects/Monitoring/Metrics/Registry.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Effects/Monitoring/Metrics/Registry.hs @@ -0,0 +1,119 @@ +-- | Metric registry for managing Prometheus metrics. +-- +-- The actual implementation of the `runMetrics` handler. +module Atelier.Effects.Monitoring.Metrics.Registry + ( MetricHandles + , initMetricHandles + , setGauge + , incGauge + , decGauge + , incCounter + , addCounter + , observeHistogram + ) where + +import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef) + +import Data.Map.Strict qualified as Map +import Prometheus qualified as Prom + + +-- | Mutable handles to the registered Prometheus metrics, keyed by name and +-- created on first use. +data MetricHandles = MetricHandles + { gauges :: IORef (Map Text Prom.Gauge) + , counters :: IORef (Map Text Prom.Counter) + , histograms :: IORef (Map Text Prom.Histogram) + } + + +-- | Initialize empty metric handles +initMetricHandles :: IO MetricHandles +initMetricHandles = do + MetricHandles + <$> newIORef mempty + <*> newIORef mempty + <*> newIORef mempty + + +-- | Set a gauge to a specific value +setGauge :: MetricHandles -> Text -> Double -> IO () +setGauge handles name value = do + g <- getOrCreateGauge handles name + Prom.setGauge g value + + +-- | Increment a gauge by 1 +incGauge :: MetricHandles -> Text -> IO () +incGauge handles name = do + g <- getOrCreateGauge handles name + Prom.incGauge g + + +-- | Decrement a gauge by 1 +decGauge :: MetricHandles -> Text -> IO () +decGauge handles name = do + g <- getOrCreateGauge handles name + Prom.decGauge g + + +-- | Increment a counter by 1 +incCounter :: MetricHandles -> Text -> IO () +incCounter handles name = do + c <- getOrCreateCounter handles name + Prom.incCounter c + + +-- | Add a value to a counter +addCounter :: MetricHandles -> Text -> Double -> IO () +addCounter handles name value = do + c <- getOrCreateCounter handles name + void $ Prom.addCounter c value + + +-- | Observe a value in a histogram +observeHistogram :: MetricHandles -> Text -> Double -> IO () +observeHistogram handles name value = do + h <- getOrCreateHistogram handles name + Prom.observe h value + + +-- | Get or create a gauge metric +getOrCreateGauge :: MetricHandles -> Text -> IO Prom.Gauge +getOrCreateGauge handles name = do + gaugeMap <- readIORef handles.gauges + case Map.lookup name gaugeMap of + Just g -> pure g + Nothing -> do + g <- Prom.register $ Prom.gauge (Prom.Info name "") + atomicModifyIORef' handles.gauges $ \m -> + (Map.insert name g m, ()) + pure g + + +-- | Get or create a counter metric +getOrCreateCounter :: MetricHandles -> Text -> IO Prom.Counter +getOrCreateCounter handles name = do + counterMap <- readIORef handles.counters + case Map.lookup name counterMap of + Just c -> pure c + Nothing -> do + c <- Prom.register $ Prom.counter (Prom.Info name "") + atomicModifyIORef' handles.counters $ \m -> + (Map.insert name c m, ()) + pure c + + +-- | Get or create a histogram metric +getOrCreateHistogram :: MetricHandles -> Text -> IO Prom.Histogram +getOrCreateHistogram handles name = do + histogramMap <- readIORef handles.histograms + case Map.lookup name histogramMap of + Just h -> pure h + Nothing -> do + -- Default buckets for duration metrics: 1ms, 10ms, 100ms, 1s, 10s + let buckets = [0.001, 0.01, 0.1, 1.0, 10.0] + h <- Prom.register $ Prom.histogram (Prom.Info name "") buckets + atomicModifyIORef' handles.histograms $ \m -> + (Map.insert name h m, ()) + pure h diff --git a/src/Atelier/Effects/Monitoring/Metrics/Server.hs b/src/Atelier/Effects/Monitoring/Metrics/Server.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Effects/Monitoring/Metrics/Server.hs @@ -0,0 +1,50 @@ +-- | Effect for running the Prometheus metrics HTTP server. +-- +-- Wraps a Warp server that exposes the current metrics registry over HTTP, so +-- callers start it through the effect system rather than raw 'IO'. +module Atelier.Effects.Monitoring.Metrics.Server + ( -- * Effect + MetricsServer + + -- * Operations + , runMetricsServer + + -- * Interpreters + , runMetricsServerIO + ) where + +import Effectful (Effect, IOE) +import Effectful.Dispatch.Dynamic (interpret_) +import Effectful.TH (makeEffect) +import Network.HTTP.Types (status200) +import Network.Wai (Application, responseLBS) + +import Network.Wai.Handler.Warp qualified as Warp +import Prometheus qualified as Prom + + +-- | Running the Prometheus metrics HTTP server. +data MetricsServer :: Effect where + -- | Start an HTTP server that exposes Prometheus metrics at any path on the + -- given port. Blocks until the server stops, which normally only happens on + -- error; intended to be run in a background thread. + RunMetricsServer :: Int -> MetricsServer m () + + +makeEffect ''MetricsServer + + +-- | Interpret 'MetricsServer' by running a real Warp HTTP server. +runMetricsServerIO :: (IOE :> es) => Eff (MetricsServer : es) a -> Eff es a +runMetricsServerIO = interpret_ \case + RunMetricsServer port -> liftIO $ Warp.run port metricsApp + + +metricsApp :: Application +metricsApp _req respond = do + payload <- Prom.exportMetricsAsText + respond + $ responseLBS + status200 + [("Content-Type", "text/plain; version=0.0.4; charset=utf-8")] + payload diff --git a/src/Atelier/Effects/Monitoring/Tracing.hs b/src/Atelier/Effects/Monitoring/Tracing.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Effects/Monitoring/Tracing.hs @@ -0,0 +1,293 @@ +-- | Tracing effect for distributed tracing with OpenTelemetry. +-- +-- Provides operations for creating spans, adding attributes, and propagating trace context. +-- +-- == Basic Usage +-- +-- @ +-- myHandler :: (Tracing :> es) => Eff es () +-- myHandler = do +-- withSpan "api.create_user" $ do +-- addAttribute "user.id" "123" +-- -- ... do work ... +-- setStatus Ok +-- @ +module Atelier.Effects.Monitoring.Tracing + ( -- * Effect + Tracing (..) + + -- * Span Operations + , withSpan + , withSpanLinked + , withLinkPropagation + , addAttribute + , addEvent + , setStatus + , getSpanContext + , OT.ToAttribute (..) + , Attr (..) + , ToAttributeShow (..) + + -- * Interpreters + , runTracing + , runTracingFromConfig + , runTracingNoOp + + -- * Configuration + , TracingConfig (..) + + -- * Re-exports + , SpanStatus (..) + , SpanContext + ) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Default (Default (..)) +import Effectful (Effect, IOE, Limit (..), Persistence (..), UnliftStrategy (..)) +import Effectful.Dispatch.Dynamic (interposeWith, interpret, interpretWith, localSeqUnlift, localUnlift) +import Effectful.Exception (bracket, onException) +import Effectful.Reader.Static (Reader, ask) +import Effectful.TH (makeEffect) + +import Data.HashMap.Strict qualified as HashMap +import OpenTelemetry.Context qualified as Context +import OpenTelemetry.Context.ThreadLocal qualified as ThreadLocal +import OpenTelemetry.Trace qualified as OT +import OpenTelemetry.Trace.Core qualified as OT + +import Atelier.Effects.Timeout (Timeout, timeout) +import Atelier.Time (Second) +import Atelier.Types.QuietSnake (QuietSnake (..)) +import Atelier.Types.WithDefaults (WithDefaults (..)) + +import Atelier.Effects.Monitoring.Tracing.Provider qualified as Provider + + +-- | Tracing configuration for OpenTelemetry +data TracingConfig = TracingConfig + { enabled :: Bool + -- ^ Enable tracing + , serviceName :: Text + -- ^ Service name for traces + , otlpEndpoint :: Text + -- ^ OTLP endpoint (e.g., "http://localhost:4318") + } + deriving stock (Eq, Generic, Show) + deriving (ToJSON) via QuietSnake TracingConfig + deriving (FromJSON) via WithDefaults (QuietSnake TracingConfig) + + +instance Default TracingConfig where + def = + TracingConfig + { enabled = False + , serviceName = "hoard" + , otlpEndpoint = "http://localhost:4318" + } + + +-- | Span status for indicating success or failure +data SpanStatus + = -- | The operation completed successfully. + Ok + | -- | The operation failed, with an explanatory message. + Error Text + deriving stock (Eq, Show) + + +-- | Opaque span context for correlating traces with metrics +type SpanContext = OT.SpanContext + + +-- | Tracing effect for distributed tracing +data Tracing :: Effect where + -- | Execute an action within a named span (bracket-style, automatic cleanup) + WithSpan :: Text -> m a -> Tracing m a + -- | Execute an action within a named span with links to other span contexts + WithSpanLinked :: Text -> [SpanContext] -> m a -> Tracing m a + -- | Add an attribute to the current span + AddAttribute :: (OT.ToAttribute attr) => Text -> attr -> Tracing m () + -- | Add an event to the current span + AddEvent :: (OT.ToAttribute attr) => Text -> [(Text, attr)] -> Tracing m () + -- | Set the status of the current span + SetStatus :: SpanStatus -> Tracing m () + -- | Get the current span context (for exemplars) + GetSpanContext :: Tracing m (Maybe SpanContext) + -- | Get the current OpenTelemetry context (internal use) + GetCurrentContext :: Tracing m Context.Context + + +-- | Useful to create a heterogeneous list of attribute values. These two are equivalent: +-- +-- @ +-- addEvent "foo" [OT.toAttribute 1, OT.toAttribute "foo"] +-- addEvent "foo" [Attr 1, Attr "foo"] +-- @ +data Attr where + Attr :: (OT.ToAttribute a) => a -> Attr + + +instance OT.ToAttribute Attr where + toAttribute (Attr a) = OT.toAttribute a + + +-- | Wrapper that turns any 'Show'able value into an OpenTelemetry attribute via +-- its 'Show' instance. Derive an attribute instance @via 'ToAttributeShow' T@, +-- or wrap a value directly. +newtype ToAttributeShow a = ToAttributeShow + { getToAttributeShow :: a + } + + +instance (Show a) => OT.ToPrimitiveAttribute (ToAttributeShow a) where + toPrimitiveAttribute = OT.TextAttribute . show . getToAttributeShow + + +instance (Show a) => OT.ToAttribute (ToAttributeShow a) + + +makeEffect ''Tracing + + +-- | Run an action with automatic span link propagation for fire-and-forget forks. +-- +-- Any span created with no current parent (i.e., a root span) will automatically +-- receive a link to @parentCtx@. Nested spans inside those are unaffected — they +-- already have a parent and follow normal child semantics. +-- +-- This avoids the trace growth problem caused by parent-child propagation in +-- long-running loops: each loop iteration's work becomes its own trace, linked +-- back to the originating span rather than piling spans onto a single trace. +withLinkPropagation :: (Tracing :> es) => Maybe SpanContext -> Eff es a -> Eff es a +withLinkPropagation Nothing action = action +withLinkPropagation (Just parentSpanCtx) action = + interposeWith action $ \env -> \case + WithSpan name m -> do + currentCtx <- getCurrentContext + localUnlift env (ConcUnlift Persistent Unlimited) $ \unlift -> + case Context.lookupSpan currentCtx of + Nothing -> withSpanLinked name [parentSpanCtx] (unlift m) + Just _ -> withSpan name (unlift m) + WithSpanLinked name ctxs m -> + localUnlift env (ConcUnlift Persistent Unlimited) $ \unlift -> + withSpanLinked name ctxs (unlift m) + AddAttribute key val -> addAttribute key val + AddEvent name attrs -> addEvent name attrs + SetStatus status -> setStatus status + GetSpanContext -> getSpanContext + GetCurrentContext -> getCurrentContext + + +-- | Run the Tracing effect with OpenTelemetry +-- +-- Initializes the tracer provider and manages span lifecycle. +runTracing + :: (IOE :> es, Timeout :> es) + => Bool + -- ^ Tracing enabled flag + -> Text + -- ^ Service name + -> Text + -- ^ OTLP endpoint + -> Eff (Tracing : es) a + -> Eff es a +runTracing enabled serviceName otlpEndpoint action + | not enabled = runTracingNoOp action + | otherwise = + bracket + (liftIO $ Provider.initTracingState serviceName otlpEndpoint) + (\tracingState -> void $ timeout (3 :: Second) $ liftIO $ Provider.shutdownTracingState tracingState) + $ \tracingState -> interpretWith action $ \env -> \case + WithSpan spanName innerAction -> localSeqUnlift env $ \unlift -> do + currentCtx <- liftIO ThreadLocal.getContext + newSpan <- liftIO $ OT.createSpan tracingState.tracer currentCtx spanName OT.defaultSpanArguments + let newCtx = Context.insertSpan newSpan currentCtx + oldCtx <- liftIO $ ThreadLocal.attachContext newCtx + innerResult <- + unlift innerAction `onException` do + liftIO $ OT.setStatus newSpan (OT.Error "Exception occurred") + -- Restore the old context + liftIO $ void $ case oldCtx of + Just ctx -> ThreadLocal.attachContext ctx + Nothing -> ThreadLocal.detachContext + liftIO $ OT.endSpan newSpan Nothing + pure innerResult + WithSpanLinked spanName linkedContexts innerAction -> localSeqUnlift env $ \unlift -> do + currentCtx <- liftIO ThreadLocal.getContext + let spanArgs = + OT.defaultSpanArguments + { OT.links = map (\ctx -> OT.NewLink ctx mempty) linkedContexts + } + newSpan <- liftIO $ OT.createSpan tracingState.tracer currentCtx spanName spanArgs + let newCtx = Context.insertSpan newSpan currentCtx + oldCtx <- liftIO $ ThreadLocal.attachContext newCtx + innerResult <- + unlift innerAction `onException` do + liftIO $ OT.setStatus newSpan (OT.Error "Exception occurred") + + -- Restore the old context + liftIO $ void $ case oldCtx of + Just ctx -> ThreadLocal.attachContext ctx + Nothing -> ThreadLocal.detachContext + liftIO $ OT.endSpan newSpan Nothing + pure innerResult + AddAttribute key value -> do + currentCtx <- liftIO ThreadLocal.getContext + case Context.lookupSpan currentCtx of + Just currentSpan -> + liftIO $ OT.addAttribute currentSpan key (OT.toAttribute value) + Nothing -> + -- No active span, ignore + pure () + AddEvent eventName attributes -> do + currentCtx <- liftIO ThreadLocal.getContext + case Context.lookupSpan currentCtx of + Just currentSpan -> do + let attrMap = HashMap.fromList $ map (\(k, v) -> (k, OT.toAttribute v)) attributes + let event = OT.NewEvent eventName attrMap Nothing + liftIO $ OT.addEvent currentSpan event + Nothing -> + -- No active span, ignore + pure () + SetStatus status -> do + currentCtx <- liftIO ThreadLocal.getContext + case Context.lookupSpan currentCtx of + Just currentSpan -> + liftIO $ case status of + Ok -> OT.setStatus currentSpan OT.Ok + Error msg -> OT.setStatus currentSpan (OT.Error msg) + Nothing -> + -- No active span, ignore + pure () + GetSpanContext -> do + currentCtx <- liftIO ThreadLocal.getContext + case Context.lookupSpan currentCtx of + Just currentSpan -> do + spanCtx <- liftIO $ OT.getSpanContext currentSpan + pure $ Just spanCtx + Nothing -> pure Nothing + GetCurrentContext -> liftIO ThreadLocal.getContext + + +-- | Run the Tracing effect with config from Reader +-- +-- Convenience wrapper that reads TracingConfig from the Reader effect. +runTracingFromConfig + :: (IOE :> es, Reader TracingConfig :> es, Timeout :> es) + => Eff (Tracing : es) a + -> Eff es a +runTracingFromConfig action = do + TracingConfig {enabled, serviceName, otlpEndpoint} <- ask + runTracing enabled serviceName otlpEndpoint action + + +-- | No-op interpreter that discards all tracing operations +runTracingNoOp :: Eff (Tracing : es) a -> Eff es a +runTracingNoOp = interpret $ \env -> \case + WithSpan _ act -> localSeqUnlift env $ \unlift -> unlift act + WithSpanLinked _ _ act -> localSeqUnlift env $ \unlift -> unlift act + AddAttribute _ _ -> pure () + AddEvent _ _ -> pure () + SetStatus _ -> pure () + GetSpanContext -> pure Nothing + GetCurrentContext -> pure Context.empty diff --git a/src/Atelier/Effects/Monitoring/Tracing/Provider.hs b/src/Atelier/Effects/Monitoring/Tracing/Provider.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Effects/Monitoring/Tracing/Provider.hs @@ -0,0 +1,70 @@ +-- | Tracing provider for managing OpenTelemetry TracerProvider and span stack. +-- +-- The actual implementation backing the `runTracing` handler. +module Atelier.Effects.Monitoring.Tracing.Provider + ( TracingState (..) + , initTracingState + , shutdownTracingState + ) where + +import System.Environment (setEnv) + +import OpenTelemetry.Attributes qualified as OT +import OpenTelemetry.Trace qualified as OT + + +-- | Handles to the initialised OpenTelemetry tracer provider and a tracer +-- derived from it. +data TracingState = TracingState + { tracerProvider :: OT.TracerProvider + -- ^ The global tracer provider; flushed and shut down on teardown. + , tracer :: OT.Tracer + -- ^ The tracer used to create spans. + } + + +-- | Initialize tracing state using global tracer provider +-- +-- This uses initializeGlobalTracerProvider which reads configuration from +-- environment variables (OTEL_SERVICE_NAME, OTEL_EXPORTER_OTLP_ENDPOINT) +-- and properly sets up ID generation. +initTracingState + :: Text + -- ^ Service name + -> Text + -- ^ OTLP endpoint (e.g., "http://localhost:4318") + -> IO TracingState +initTracingState serviceName otlpEndpoint = do + -- Set environment variables for OpenTelemetry SDK + setEnv "OTEL_SERVICE_NAME" (toString serviceName) + setEnv "OTEL_EXPORTER_OTLP_ENDPOINT" (toString otlpEndpoint) + + -- Initialize the global tracer provider + -- This reads from environment variables and sets up proper ID generation + provider <- OT.initializeGlobalTracerProvider + + -- Create instrumentation library + let instrumentationLibrary = + OT.InstrumentationLibrary + serviceName -- Library name + "" -- Version (empty for now) + "" -- Schema URL (empty for now) + OT.emptyAttributes -- Attributes + + -- Get a tracer from the provider + let tracerInstance = OT.makeTracer provider instrumentationLibrary OT.tracerOptions + + pure + TracingState + { tracerProvider = provider + , tracer = tracerInstance + } + + +-- | Shutdown tracing state gracefully +-- +-- Flushes any remaining spans and cleans up resources. +shutdownTracingState :: TracingState -> IO () +shutdownTracingState tracingState = do + -- Force shutdown of the tracer provider to flush spans + OT.shutdownTracerProvider tracingState.tracerProvider diff --git a/src/Atelier/Effects/Posix/Daemons.hs b/src/Atelier/Effects/Posix/Daemons.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Effects/Posix/Daemons.hs @@ -0,0 +1,53 @@ +-- | An effect for managing detached daemon processes via PID files. +-- +-- 'daemonize' forks a program into the background, 'isRunning' checks a daemon's +-- PID file, and 'forceKillAndWait' terminates one. Backed by the @daemons@ +-- package. +module Atelier.Effects.Posix.Daemons + ( Daemons + , PidFile (..) + , daemonize + , isRunning + , forceKillAndWait + , runDaemons + ) where + +import Data.Default (def) +import Effectful (Effect, IOE, Limit (..), Persistence (..), UnliftStrategy (..)) +import Effectful.Dispatch.Dynamic (interpretWith, localUnliftIO) +import Effectful.Exception (trySync) +import Effectful.TH (makeEffect) + +import System.Posix.Daemon qualified as Daemons + + +-- | Effect for managing detached daemon processes. +data Daemons :: Effect where + -- | Daemonize the given program, ensuring it is cleanly separated from the + -- spawning process. + Daemonize :: PidFile -> m () -> Daemons m () + -- | Check whether a daemon is running for the provided PID file. + IsRunning :: PidFile -> Daemons m Bool + -- | Kill the daemon associated with the provided PID file using `SIGKILL`. + ForceKillAndWait :: PidFile -> Daemons m (Either SomeException ()) + + +-- | The path to a daemon's PID file, used to track and control it. +newtype PidFile = PidFile {getPidFile :: FilePath} + + +makeEffect ''Daemons + + +-- | Interpret 'Daemons' using the @daemons@ package. +runDaemons :: (IOE :> es) => Eff (Daemons : es) a -> Eff es a +runDaemons act = do + interpretWith act \env -> \case + Daemonize (PidFile pidFile) program -> + localUnliftIO env (ConcUnlift Persistent Unlimited) \unlift -> do + Daemons.runDetached (Just pidFile) def + $ unlift program + IsRunning (PidFile pidFile) -> + liftIO $ Daemons.isRunning pidFile + ForceKillAndWait (PidFile pidFile) -> + trySync $ liftIO $ Daemons.brutalKill pidFile diff --git a/src/Atelier/Effects/Posix/IO.hs b/src/Atelier/Effects/Posix/IO.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Effects/Posix/IO.hs @@ -0,0 +1,69 @@ +-- | +-- +-- GHC's 'System.IO.openFile' and 'System.IO.withFile' participate in an +-- advisory file-locking protocol built on @flock(2)@: +-- +-- * Write\/append mode acquires an exclusive lock (@LOCK_EX@). +-- * Read mode acquires a shared lock (@LOCK_SH@). +-- +-- Because these locks are advisory, processes that do not call @flock@ can +-- always read or write the file freely. GHC's own runtime, however, refuses +-- to open a file for reading while another GHC process holds an exclusive +-- lock on it — even if the underlying read would be perfectly safe - and +-- throws @resource busy (file is locked)@. +-- +-- This is a problem when a long-lived daemon holds a file open in append mode +-- and a short-lived client process wants to read that file. Using 'readFdAll', +-- the client opens the file via @open(2)@ without ever calling @flock@, +-- matching the behaviour of standard Unix tools like @cat@ and @tail@. +module Atelier.Effects.Posix.IO + ( readFdAll + , readFdFrom + ) where + +import Foreign.Marshal.Alloc (allocaBytes) +import Foreign.Ptr (castPtr) +import System.IO (SeekMode (..)) +import System.Posix.Types (Fd, FileOffset) + +import Data.ByteString qualified as BS +import Data.ByteString.Builder qualified as Builder +import Data.ByteString.Lazy qualified as LBS +import System.Posix.IO qualified as Posix + + +-- | Read the entire contents of a file descriptor into a lazy 'LBS.ByteString' +-- without acquiring any file lock. +-- +-- The file is read in chunks via @read(2)@ (@'Posix.fdReadBuf'@) until EOF. +-- The caller retains ownership of the 'Fd' and is responsible for closing it; +-- this function does not close the descriptor after reading. +-- +-- Typical use via 'Control.Exception.bracket': +-- +-- @ +-- result <- bracket +-- (Posix.openFd path Posix.ReadOnly Posix.defaultFileFlags) +-- Posix.closeFd +-- readFdAll +-- @ +readFdAll :: Fd -> IO LBS.ByteString +readFdAll fd = Builder.toLazyByteString <$> go mempty + where + chunkSize = 65536 :: Int + go acc = do + chunk <- allocaBytes chunkSize \ptr -> do + n <- Posix.fdReadBuf fd (castPtr ptr) (fromIntegral chunkSize) + BS.packCStringLen (castPtr ptr, fromIntegral n) + if BS.null chunk then + return acc + else + go (acc <> Builder.byteString chunk) + + +-- | Seek to @offset@ and read the remainder of a file descriptor into a lazy +-- 'LBS.ByteString' without acquiring any file lock. +readFdFrom :: FileOffset -> Fd -> IO LBS.ByteString +readFdFrom offset fd = do + _ <- Posix.fdSeek fd AbsoluteSeek offset + readFdAll fd diff --git a/src/Atelier/Effects/Process.hs b/src/Atelier/Effects/Process.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Effects/Process.hs @@ -0,0 +1,104 @@ +-- | Effect for spawning and interacting with external processes. +-- +-- Unifies @typed-process@ (configuration, lifecycle and stream capture) and +-- the one operation only @process@ provides (process-group interruption) +-- behind a single effect, so callers never depend on either package directly. +-- +-- Build a 'ProcessConfig' with the re-exported @typed-process@ DSL +-- ('proc', 'shell', 'setStdin', …), then run it with one of the operations +-- below. +module Atelier.Effects.Process + ( -- * Effect + Process + + -- * Building process configs (re-exported from @typed-process@) + , ProcessConfig + , RunningProcess + , proc + , shell + , setStdin + , setStdout + , setStderr + , setWorkingDir + , setCreateGroup + , createPipe + , getStdin + , getStdout + , getStderr + + -- * Operations + , readProcessStdout + , readProcessSafe + , startProcess + , stopProcess + , waitExitCode + , interruptProcessGroup + + -- * Interpreters + , runProcessIO + ) where + +import Effectful (Effect, IOE) +import Effectful.Dispatch.Dynamic (interpret_) +import Effectful.Exception (trySync) +import Effectful.TH (makeEffect) +import System.Exit (ExitCode (..)) +import System.Process (interruptProcessGroupOf) +import System.Process.Typed + ( ProcessConfig + , createPipe + , getStderr + , getStdin + , getStdout + , proc + , setCreateGroup + , setStderr + , setStdin + , setStdout + , setWorkingDir + , shell + ) + +import System.Process.Typed qualified as TP + + +-- | @typed-process@'s started-process type, re-exported under a non-clashing +-- name (the effect itself is called 'Process'). Parameterised by its stdin, +-- stdout and stderr stream types. +type RunningProcess = TP.Process + + +data Process :: Effect where + -- | Run a process to completion, returning its exit code and captured stdout. + ReadProcessStdout :: ProcessConfig i o e -> Process m (ExitCode, LByteString) + -- | Spawn a process and return its handle for further interaction. + StartProcess :: ProcessConfig i o e -> Process m (TP.Process i o e) + -- | Stop a process: close its streams, terminate it, and wait for it to exit. + StopProcess :: TP.Process i o e -> Process m () + -- | Block until the process exits and return its exit code. + WaitExitCode :: TP.Process i o e -> Process m ExitCode + -- | Send an interrupt (SIGINT) to the process's group. Requires the process + -- to have been started with @'setCreateGroup' True@. + InterruptProcessGroup :: TP.Process i o e -> Process m () + + +makeEffect ''Process + + +-- | Run @cmd@ with @args@ and return its stdout as 'Text', or 'Nothing' on any +-- error (non-zero exit, the executable not being found, etc.). +readProcessSafe :: (Process :> es) => FilePath -> [String] -> Eff es (Maybe Text) +readProcessSafe cmd args = do + result <- trySync $ readProcessStdout (proc cmd args) + pure $ case result of + Right (ExitSuccess, out) -> Just (decodeUtf8 out) + _ -> Nothing + + +runProcessIO :: (IOE :> es) => Eff (Process : es) a -> Eff es a +runProcessIO = interpret_ \case + ReadProcessStdout cfg -> liftIO $ TP.readProcessStdout cfg + StartProcess cfg -> liftIO $ TP.startProcess cfg + StopProcess p -> liftIO $ TP.stopProcess p + WaitExitCode p -> liftIO $ TP.waitExitCode p + InterruptProcessGroup p -> liftIO $ interruptProcessGroupOf (TP.unsafeProcessHandle p) diff --git a/src/Atelier/Effects/Publishing.hs b/src/Atelier/Effects/Publishing.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Effects/Publishing.hs @@ -0,0 +1,185 @@ +-- | A typed publish/subscribe effect pair. +-- +-- 'Pub' publishes events of a given type; 'Sub' subscribes and delivers each +-- published event to a listener. 'runPubSub' wires the two together over an +-- internal broadcast channel, propagating tracing context from publisher to +-- listener; 'runPubWriter' instead records published events to a 'Writer', for +-- tests. +-- +-- Subscriptions are established asynchronously, so a listener you intend to +-- publish to should be started with 'forkListener' or 'forkListener_', which +-- block until the subscription is live and therefore cannot miss early events. +module Atelier.Effects.Publishing + ( Pub + , Sub + , listen + , listen_ + , listenWith + , listenWith_ + , listenOnce + , listenOnce_ + , forkListener + , forkListener_ + , publish + , runPubSub + , runPubWriter + ) +where + +import Data.Time (UTCTime) +import Effectful (Effect) +import Effectful.Concurrent.STM + ( Concurrent + , atomically + , newEmptyTMVar + , putTMVar + , takeTMVar + ) +import Effectful.Dispatch.Dynamic (interpretWith, interpretWith_, interpret_, localSeqUnlift) +import Effectful.Error.Static (runErrorNoCallStack, throwError) +import Effectful.TH (makeEffect) +import Effectful.Writer.Static.Shared (Writer, tell) + +import Text.Show qualified as S + +import Atelier.Effects.Chan (Chan) +import Atelier.Effects.Clock (Clock) +import Atelier.Effects.Conc (Conc, fork_) +import Atelier.Effects.Monitoring.Tracing (SpanContext, Tracing) + +import Atelier.Effects.Chan qualified as Chan +import Atelier.Effects.Clock qualified as Clock +import Atelier.Effects.Monitoring.Tracing qualified as Tracing + + +-- | Effect for publishing events of type @event@. +data Pub (event :: Type) :: Effect where + -- | Publish an event to all current subscribers. + Publish :: event -> Pub event m () + + +-- | Effect for subscribing to events of type @event@. +data Sub (event :: Type) :: Effect where + -- | Subscribe, then run @onSubscribed@ once the subscription is established + -- — after the internal channel has been duplicated and before any event is + -- delivered — and thereafter deliver every published event to the listener, + -- forever. The @onSubscribed@ hook lets a caller synchronize on "subscribed" + -- so a concurrently-started publisher cannot race ahead of the subscription + -- and have its events missed. Most callers want 'listen' (no hook); a caller + -- that forks the listener and then publishes must wait on this hook first. + ListenWith :: m () -> (UTCTime -> event -> m ()) -> Sub event m Void + + +makeEffect ''Pub +makeEffect ''Sub + + +-- | Subscribe and deliver every published event to the listener, forever. +-- Defined in terms of 'listenWith' with a no-op subscribed hook. +listen :: (Sub event :> es) => (UTCTime -> event -> Eff es ()) -> Eff es Void +listen = listenWith (pure ()) + + +-- | Like 'listen', but the listener ignores the event timestamp. +listen_ :: (Sub event :> es) => (event -> Eff es ()) -> Eff es Void +listen_ listener = listen $ \_timestamp event -> listener event + + +-- | Like 'listen_', but runs @onSubscribed@ once the subscription is +-- established and before any event is delivered. See 'ListenWith'. +listenWith_ :: (Sub event :> es) => Eff es () -> (event -> Eff es ()) -> Eff es Void +listenWith_ onSubscribed listener = listenWith onSubscribed $ \_timestamp event -> listener event + + +-- | Fork a background listener and block until it has actually subscribed, +-- then return. The listener runs until the enclosing 'Conc' scope closes. +-- +-- This is the safe way to start a listener you intend to publish to: a plain +-- @'fork_' . 'listen'@ followed by a 'publish' races the subscription (which +-- happens asynchronously in the forked thread) and, under scheduler pressure, +-- can drop early events and wedge the listener forever. 'forkListener' closes +-- that window by waiting on the subscribed hook before returning. +forkListener + :: forall event es + . (Conc :> es, Concurrent :> es, Sub event :> es) + => (UTCTime -> event -> Eff es ()) + -> Eff es () +forkListener listener = do + subscribed <- atomically newEmptyTMVar + fork_ $ listenWith (atomically (putTMVar subscribed ())) listener + atomically (takeTMVar subscribed) + + +-- | Like 'forkListener', but the listener ignores the timestamp. +forkListener_ + :: forall event es + . (Conc :> es, Concurrent :> es, Sub event :> es) + => (event -> Eff es ()) + -> Eff es () +forkListener_ listener = forkListener @event (\_timestamp event -> listener event) + + +-- | Wait for a single event and then return said event. +listenOnce :: forall event es. (Sub event :> es) => Eff es (UTCTime, event) +listenOnce = do + res <- runErrorNoCallStack + $ listen + $ \timestamp event -> throwError $ OnceEx (timestamp, event) + case res of + Left (OnceEx x) -> pure x + Right v -> absurd v + + +-- | Same as 'listenOnce', but discards the timestamp. +listenOnce_ :: (Sub event :> es) => Eff es event +listenOnce_ = snd <$> listenOnce + + +data OnceEx ev = OnceEx ev +instance Show (OnceEx ev) where show _ = "OnceEx" + + +-- | Internal wrapper for events with trace context +data TracedEvent event = TracedEvent + { event :: event + , timestamp :: UTCTime + , publisherSpanContext :: Maybe SpanContext + } + + +-- | Runs Pub and Sub effects with an internal channel for a specific event type. +-- Automatically captures span context from the publisher and creates linked spans in listeners. +runPubSub + :: forall event es a + . ( Chan :> es + , Clock :> es + , Tracing :> es + ) + => Eff (Pub event : Sub event : es) a -> Eff es a +runPubSub action = do + (inChan, _) <- Chan.newChan @(TracedEvent event) + + let handlePub eff = interpretWith_ eff \case + Publish event -> do + timestamp <- Clock.currentTime + -- Capture the current span context from the publisher + publisherSpanContext <- Tracing.getSpanContext + Chan.writeChan inChan TracedEvent {event, timestamp, publisherSpanContext} + + handleSub eff = interpretWith eff \env -> \case + ListenWith onSubscribed listener -> localSeqUnlift env \unlift -> do + chan <- Chan.dupChan inChan + unlift onSubscribed + forever do + TracedEvent {event, timestamp, publisherSpanContext} <- Chan.readChan chan + Tracing.withLinkPropagation publisherSpanContext $ unlift $ listener timestamp event + + handleSub . handlePub $ action + + +-- | Handler that uses a provided Writer effect instead of actually publishing. +-- Useful for testing and inspecting what events were published. +runPubWriter :: forall event es a. (Writer [event] :> es) => Eff (Pub event : es) a -> Eff es a +runPubWriter = + interpret_ \case + Publish event -> tell [event] diff --git a/src/Atelier/Effects/Tally.hs b/src/Atelier/Effects/Tally.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Effects/Tally.hs @@ -0,0 +1,90 @@ +-- | Tally tracking effect for counting occurrences per key +-- +-- Tracks the total number of occurrences per key, delegating storage and +-- eviction to a 'Cache' interpreter. +-- +-- The effect is polymorphic over both the key type and the status type returned +-- by a caller-supplied classifier function. This allows callers to define their +-- own thresholds and result types rather than relying on a single hard limit. +-- +-- == Basic Usage +-- +-- @ +-- checkDuplicate :: (Tally DuplicateKey :> es) => DuplicateKey -> Config -> Eff es () +-- checkDuplicate key cfg = +-- withTallyCheck key classify $ \case +-- Nothing -> pure () +-- Just Minor -> warnAboutPeer +-- Just Critical -> banPeer +-- where +-- classify c +-- | c > cfg.criticalThreshold = Just Critical +-- | c > cfg.warningThreshold = Just Minor +-- | otherwise = Nothing +-- @ +module Atelier.Effects.Tally + ( -- * Effect + Tally + , withTallyCheck + + -- * Re-exports + , module Atelier.Effects.Cache.Config + + -- * Interpreters + , runTally + , runTallyConst + ) where + +import Effectful (Effect) +import Effectful.Concurrent (Concurrent) +import Effectful.Dispatch.Dynamic (interpret, localSeqUnlift, reinterpret) +import Effectful.Reader.Static (Reader) +import Effectful.TH (makeEffect) + +import Atelier.Effects.Cache (cacheModify, runCacheTtl) +import Atelier.Effects.Cache.Config +import Atelier.Effects.Clock (Clock) +import Atelier.Effects.Conc (Conc) +import Atelier.Effects.Delay (Delay) +import Atelier.Effects.Log (Log) + + +-- | Tally tracking effect parameterized by key type +data Tally key :: Effect where + -- | Increment the hit count for a key and run an action based on a classifier. + -- + -- The classifier receives the new count and produces a status value of any + -- type the caller chooses. The continuation then receives that status. + WithTallyCheck + :: (Hashable key, Ord key) + => key -> (Int -> status) -> (status -> m a) -> Tally key m a + + +makeEffect ''Tally + + +-- | Run the Tally effect, using a TTL-evicting cache as the backing store +runTally + :: forall key es a + . ( Clock :> es + , Conc :> es + , Concurrent :> es + , Delay :> es + , Hashable key + , Log :> es + , Reader Config :> es + ) + => Eff (Tally key : es) a + -> Eff es a +runTally = reinterpret (runCacheTtl @key @Int) $ \env -> \case + WithTallyCheck key classify continuation -> localSeqUnlift env $ \unlift -> do + count <- cacheModify key (maybe 1 (+ 1)) + unlift $ continuation (classify count) + + +-- | Interpret 'Tally' with a fixed count for every key, ignoring real +-- tallying. The classifier is always handed @c@, making the outcome +-- deterministic for tests. +runTallyConst :: Int -> Eff (Tally key : es) a -> Eff es a +runTallyConst c = interpret \env -> \case + WithTallyCheck _ classify f -> localSeqUnlift env \unlift -> unlift $ f (classify c) diff --git a/src/Atelier/Effects/Timeout.hs b/src/Atelier/Effects/Timeout.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Effects/Timeout.hs @@ -0,0 +1,52 @@ +-- | An effect for bounding a computation by a wall-clock deadline. +-- +-- 'timeout' runs an action, returning 'Nothing' if it does not finish within +-- the given 'TimeUnit' duration; 'timeout_' is the variant that discards the +-- result. When the deadline passes the action is cancelled with an asynchronous +-- exception. +-- +-- @ +-- result <- timeout (5 :: Second) fetchRemote +-- case result of +-- Just value -> use value +-- Nothing -> logWarn \"fetch timed out\" +-- @ +module Atelier.Effects.Timeout + ( Timeout + , timeout + , timeout_ + , runTimeout + ) where + +import Effectful (Effect, IOE, Limit (..), Persistence (..), UnliftStrategy (..)) +import Effectful.Dispatch.Dynamic (interpret, localUnliftIO) +import Effectful.TH (makeEffect) + +import System.Timeout qualified as IO + +import Atelier.Time (TimeUnit (..)) + + +-- | Effect for bounding a computation by a wall-clock deadline. +data Timeout :: Effect where + -- | Run an action, returning 'Just' its result if it completes within the + -- duration, or 'Nothing' if the deadline passes first. + Timeout :: (TimeUnit t) => t -> m a -> Timeout m (Maybe a) + + +makeEffect ''Timeout + + +-- | Like 'timeout', but for times where you do not need the result. If you +-- need to distinguish whether the action ran to completion, or whether it +-- timed out, you should use 'timeout'. +timeout_ :: (TimeUnit t, Timeout :> es) => t -> Eff es a -> Eff es () +timeout_ t m = const () <$> timeout t m + + +-- | Interpret 'Timeout' using 'System.Timeout.timeout'. +runTimeout :: (HasCallStack, IOE :> es) => Eff (Timeout : es) a -> Eff es a +runTimeout = interpret \env -> \case + Timeout delay action -> + localUnliftIO env (ConcUnlift Persistent (Limited 1)) \unlift -> + IO.timeout (fromIntegral $ toMicroseconds delay) $ unlift action diff --git a/src/Atelier/Effects/UUID.hs b/src/Atelier/Effects/UUID.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Effects/UUID.hs @@ -0,0 +1,37 @@ +-- | An effect for generating UUIDs. +-- +-- 'runGenUUID' produces fresh random (version 4) UUIDs; 'runGenUUIDConst' +-- returns a fixed UUID every time, for deterministic tests. The 'UUID' type is +-- re-exported from @uuid@. +module Atelier.Effects.UUID + ( GenUUID + , UUID + , gen + , runGenUUID + , runGenUUIDConst + ) where + +import Data.UUID (UUID) +import Data.UUID.V4 (nextRandom) +import Effectful (Effect, IOE) +import Effectful.Dispatch.Dynamic (interpret_) +import Effectful.TH (makeEffect) + + +-- | Effect for generating UUIDs. +data GenUUID :: Effect where + -- | Generate a UUID. + Gen :: GenUUID m UUID + + +makeEffect ''GenUUID + + +-- | Interpret 'GenUUID' by generating fresh random (version 4) UUIDs. +runGenUUID :: (IOE :> es) => Eff (GenUUID : es) a -> Eff es a +runGenUUID = interpret_ \Gen -> liftIO nextRandom + + +-- | Interpret 'GenUUID' so 'gen' always returns the given fixed UUID, for tests. +runGenUUIDConst :: UUID -> Eff (GenUUID : es) a -> Eff es a +runGenUUIDConst uuid = interpret_ \Gen -> pure uuid diff --git a/src/Atelier/Effects/Yield.hs b/src/Atelier/Effects/Yield.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Effects/Yield.hs @@ -0,0 +1,70 @@ +-- | The producing half of a 'Yield'\/'Await' coroutine pair. +-- +-- A 'Yield' computation emits values one at a time, analogous to the +-- @Writer@\/@Output@ effects. The interpreters here collect the stream +-- ('yieldToList', 'withYieldToList'), drive it ('forEach'), or transform it +-- ('map', 'mapMaybe', 'filter', 'changes', 'enumerate'). The effect itself lives +-- in "Atelier.Effects.Internal.Coroutine" and is re-exported here. +module Atelier.Effects.Yield + ( -- * Effect + Yield + + -- * Operations + , yield + , inFoldable + , yieldEvents + , cycleToYield + + -- * Interpreters + , forEach + , yieldToList + , yieldToReverseList + , withYieldToList + , ignoreYield + , enumerate + , enumerateFrom + , map + , mapMaybe + , catMaybes + , changes + , filter + ) where + +import Effectful.Dispatch.Dynamic (impose_, interpose_) +import Effectful.State.Static.Shared (evalState, get) +import Prelude hiding (catMaybes, filter, map, mapMaybe) + +import Atelier.Effects.Internal.Coroutine + ( Yield (..) + , catMaybes + , cycleToYield + , enumerate + , enumerateFrom + , forEach + , ignoreYield + , inFoldable + , map + , mapMaybe + , withYieldToList + , yield + , yieldEvents + , yieldToList + , yieldToReverseList + ) + + +-- | Forward only the 'yield'ed values that satisfy a predicate, dropping the +-- rest from the stream. +filter :: (a -> Bool) -> Eff (Yield a : es) r -> Eff (Yield a : es) r +filter p = interpose_ \(Yield x) -> + when (p x) do + yield x + + +-- | Re-yield values that differ from a reference value (supplied as the first +-- argument). +changes :: forall a es r. (Eq a) => a -> Eff (Yield a : es) r -> Eff (Yield a : es) r +changes initial = impose_ (evalState initial) \(Yield x) -> do + curr <- get + when (curr /= x) do + yield x diff --git a/src/Atelier/Exception.hs b/src/Atelier/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Exception.hs @@ -0,0 +1,41 @@ +-- | Helpers for telling synchronous exceptions apart from asynchronous ones. +-- +-- Synchronous exceptions are genuine failures worth catching, logging, or +-- retrying; asynchronous ones (thread cancellation, @SIGINT@) usually signal an +-- intentional shutdown and should be allowed to propagate. The @*SyncIO@ +-- helpers catch only the former and re-throw the latter. +module Atelier.Exception + ( isGracefulShutdown + , trySyncIO + , catchSyncIO + , isSyncException + ) where + +import Effectful.Exception (SomeAsyncException, isSyncException) + +import Control.Exception qualified as E + + +-- | Determine if an exception represents a graceful shutdown (any async exception). +-- +-- Async exceptions indicate intentional cancellation (e.g., Ki's ScopeClosing, +-- or UserInterrupt from SIGINT), as opposed to real errors that warrant logging +-- or retry logic. +isGracefulShutdown :: SomeException -> Bool +isGracefulShutdown = isJust . fromException @SomeAsyncException + + +-- | Like `Control.Exception.try`, but will only catch synchronous exceptions. +trySyncIO :: IO a -> IO (Either SomeException a) +trySyncIO f = withFrozenCallStack catchSyncIO (fmap Right f) (pure . Left) + + +-- | Like @Control.Exception.catch@, but only synchronous exceptions reach the +-- handler; asynchronous exceptions are re-thrown unchanged. +catchSyncIO :: (HasCallStack) => IO a -> (SomeException -> IO a) -> IO a +catchSyncIO f g = + f `E.catch` \e -> + if isSyncException e then + g e + else + E.throwIO e diff --git a/src/Atelier/Time.hs b/src/Atelier/Time.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Time.hs @@ -0,0 +1,86 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Strongly-typed time units and conversions. +-- +-- Re-exports the duration types from "Data.Time.Units" — so a single import +-- covers 'Microsecond', 'Millisecond', 'Second', 'Minute' and 'Hour' — and adds +-- conversion helpers plus JSON instances for those types. Each unit serialises +-- as an integer count of itself: a 'Second' as a whole number of seconds, a +-- 'Millisecond' as milliseconds, and so on. +-- +-- Note: the 'FromJSON' and 'ToJSON' instances for the time-unit types are +-- orphans, defined here because neither @aeson@ nor @time-units@ provides them. +-- +-- @ +-- nominalDiffTime 1.5 :: Millisecond -- 1.5s rounded to 1500ms +-- convertUnit (5 :: Minute) :: Second -- 300 +-- toMicroseconds (2 :: Second) -- 2000000 +-- @ +module Atelier.Time + ( -- * Time units + TimeUnit + , Microsecond + , Millisecond + , Second + , Minute + , Hour + + -- * Conversions + , nominalDiffTime + , fromMicroseconds + , toMicroseconds + , convertUnit + ) where + +import Data.Aeson (FromJSON (..), ToJSON (..)) +import Data.Time (NominalDiffTime) +import Data.Time.Units (Hour, Microsecond, Millisecond, Minute, Second, TimeUnit, convertUnit, fromMicroseconds, toMicroseconds) + + +-- | Convert a 'NominalDiffTime' to any 'TimeUnit', rounding to the nearest +-- whole unit (the conversion goes through microsecond precision). +nominalDiffTime :: (TimeUnit t) => NominalDiffTime -> t +nominalDiffTime = fromMicroseconds . round @Double . (* 1_000_000) . realToFrac + + +-- Orphan instances for JSON deserialization of time unit types. +-- All time units in Data.Time.Units wrap Integer, so we parse as Integer. + +instance FromJSON Microsecond where + parseJSON = fmap fromInteger . parseJSON + + +instance FromJSON Millisecond where + parseJSON = fmap fromInteger . parseJSON + + +instance FromJSON Second where + parseJSON = fmap fromInteger . parseJSON + + +instance FromJSON Minute where + parseJSON = fmap fromInteger . parseJSON + + +instance FromJSON Hour where + parseJSON = fmap fromInteger . parseJSON + + +instance ToJSON Microsecond where + toJSON us = toJSON (toMicroseconds us) + + +instance ToJSON Millisecond where + toJSON ms = toJSON (toMicroseconds ms `div` 1000) + + +instance ToJSON Second where + toJSON s = toJSON (toMicroseconds s `div` 1_000_000) + + +instance ToJSON Minute where + toJSON m = toJSON (toMicroseconds m `div` 60_000_000) + + +instance ToJSON Hour where + toJSON h = toJSON (toMicroseconds h `div` 3_600_000_000) diff --git a/src/Atelier/Types/Base64.hs b/src/Atelier/Types/Base64.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Types/Base64.hs @@ -0,0 +1,32 @@ +-- | A 'ByteString' that serialises to and from JSON as a Base64-encoded string. +-- +-- Use it directly as a field type, or derive the JSON instances for a +-- @ByteString@ newtype via it, to carry binary data through JSON without +-- tripping over non-UTF-8 bytes: +-- +-- @ +-- newtype Token = Token ByteString +-- deriving (ToJSON, FromJSON) via Base64 +-- @ +module Atelier.Types.Base64 + ( Base64 (..) + ) where + +import Data.Aeson (FromJSON (..), ToJSON (..), withText) + +import Data.ByteString.Base64 qualified as Base64 + + +-- | A 'ByteString' whose JSON representation is Base64-encoded text. +newtype Base64 = Base64 {getBase64 :: ByteString} + + +instance ToJSON Base64 where + toJSON = toJSON . decodeUtf8 @Text . Base64.encode . getBase64 + + +instance FromJSON Base64 where + parseJSON = withText "Base64" $ \t -> + case Base64.decode (encodeUtf8 t) of + Left err -> fail err + Right b -> pure (Base64 b) diff --git a/src/Atelier/Types/HttpApiDataReadShow.hs b/src/Atelier/Types/HttpApiDataReadShow.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Types/HttpApiDataReadShow.hs @@ -0,0 +1,32 @@ +-- | Derive 'FromHttpApiData' and 'ToHttpApiData' for a type from its 'Read' and +-- 'Show' instances. +-- +-- Handy for values that appear in URL path segments or query strings and whose +-- textual form is exactly their 'Show' output, such as small enums: +-- +-- @ +-- data Mode = Fast | Slow +-- deriving stock (Read, Show) +-- deriving (FromHttpApiData, ToHttpApiData) via (HttpApiDataReadShow Mode) +-- @ +-- +-- The encoding is the bare 'Show' output, so @Fast@ travels on the wire as the +-- segment @\/mode\/Fast@ or the query parameter @?mode=Slow@, and is read back +-- with 'Read'. Values whose 'Show' output contains characters that need +-- percent-encoding (spaces, @\/@, @&@) are best avoided here. +module Atelier.Types.HttpApiDataReadShow (HttpApiDataReadShow (..)) where + +import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..)) + + +-- | Carrier for deriving HTTP-API-data instances via 'Read' and 'Show'. +newtype HttpApiDataReadShow a + = HttpApiDataReadShow {getHttpApiDataReadShow :: a} + + +instance (Read a) => FromHttpApiData (HttpApiDataReadShow a) where + parseUrlPiece = bimap toText HttpApiDataReadShow . readEither . toString + + +instance (Show a) => ToHttpApiData (HttpApiDataReadShow a) where + toUrlPiece = show . getHttpApiDataReadShow diff --git a/src/Atelier/Types/JsonReadShow.hs b/src/Atelier/Types/JsonReadShow.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Types/JsonReadShow.hs @@ -0,0 +1,39 @@ +-- | Derive 'FromJSON' and 'ToJSON' for a type from its 'Read' and 'Show' +-- instances, encoding each value as a JSON string. +-- +-- A value is stored as its 'Show' output and parsed back with 'readMaybe'. On +-- failure the error message names the type (via 'Typeable'), e.g. +-- @Failed to read Mode@. +-- +-- @ +-- data Mode = Fast | Slow +-- deriving stock (Read, Show) +-- deriving (FromJSON, ToJSON) via (JsonReadShow Mode) +-- @ +-- +-- Here @Fast@ serialises to the JSON string @\"Fast\"@. +module Atelier.Types.JsonReadShow (JsonReadShow (..)) where + +import Data.Aeson (FromJSON (..), ToJSON (..), Value (..), withText) +import Data.Typeable (typeRep) + + +-- | Carrier for deriving JSON instances via 'Read' and 'Show'. +newtype JsonReadShow a = JsonReadShow {getJsonReadShow :: a} + + +instance forall a. (Read a, Typeable a) => FromJSON (JsonReadShow a) where + parseJSON = + let + typeName = show $ typeRep $ Proxy @a + in + withText typeName + $ maybe + (fail $ "Failed to read " <> typeName) + (pure . JsonReadShow) + . readMaybe + . toString + + +instance (Show a) => ToJSON (JsonReadShow a) where + toJSON = String . show . getJsonReadShow diff --git a/src/Atelier/Types/QuietSnake.hs b/src/Atelier/Types/QuietSnake.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Types/QuietSnake.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE UndecidableInstances #-} + +-- | Derive 'FromJSON' and 'ToJSON' for a record so its Haskell field names map +-- to @quiet_snake_case@ JSON keys. +-- +-- \"Quiet\" snake case lowercases and underscore-separates words without an +-- extra leading underscore, so the field @maxRetries@ becomes the JSON key +-- @max_retries@. Derive via this wrapper to keep idiomatic Haskell field names +-- while exposing snake-case JSON: +-- +-- @ +-- data Settings = Settings { maxRetries :: Int, dryRun :: Bool } +-- deriving stock (Generic) +-- deriving (FromJSON, ToJSON) via (QuietSnake Settings) +-- @ +module Atelier.Types.QuietSnake + ( QuietSnake (..) + ) where + +import Data.Aeson (FromJSON (..), GFromJSON, GToJSON, Options, ToJSON (..), Zero, genericParseJSON, genericToJSON) +import Data.Aeson.Types (defaultOptions, fieldLabelModifier) +import Data.Default (Default (..)) +import GHC.Generics (Rep) +import Text.Casing (quietSnake) + + +-- | Carrier for deriving @quiet_snake_case@ JSON instances generically. +newtype QuietSnake a = QuietSnake {getQuietSnake :: a} + + +instance (Default a) => Default (QuietSnake a) where + def = QuietSnake def + + +instance (GFromJSON Zero (Rep a), Generic a) => FromJSON (QuietSnake a) where + parseJSON = fmap QuietSnake . genericParseJSON opts + + +instance (GToJSON Zero (Rep a), Generic a) => ToJSON (QuietSnake a) where + toJSON = genericToJSON opts . getQuietSnake + + +opts :: Options +opts = defaultOptions {fieldLabelModifier = quietSnake} diff --git a/src/Atelier/Types/Semaphore.hs b/src/Atelier/Types/Semaphore.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Types/Semaphore.hs @@ -0,0 +1,59 @@ +-- | If you need a semaphore that works in 'STM', use +-- 'Atelier.Types.Semaphore.STM'. +module Atelier.Types.Semaphore + ( Semaphore + , new + , newSet + , wait + , signal + , unset + , set + , peek + , withSemaphore + ) where + +import Effectful.Concurrent.STM (Concurrent, atomically) + +import Atelier.Types.Semaphore.STM (Semaphore, withSemaphore) + +import Atelier.Types.Semaphore.STM qualified as STM + + +-- | Creates a new, unset semaphore. Waiting on this semaphore immediately will +-- block. +new :: (Concurrent :> es) => Eff es Semaphore +new = atomically STM.new + + +-- | Creates a new, set semaphore. Signalling on this semaphore immediately +-- will block. +newSet :: (Concurrent :> es) => Eff es Semaphore +newSet = atomically STM.newSet + + +-- | Wait for a semaphore to be set. Blocks and waits for the semaphore to be +-- set if it is not already set. +wait :: (Concurrent :> es) => Semaphore -> Eff es () +wait = atomically . STM.wait + + +-- | Ensures a semaphore is unset. Returns @True@ if the semaphore was set. +unset :: (Concurrent :> es) => Semaphore -> Eff es Bool +unset = atomically . STM.unset + + +-- | Set a semaphore. Blocks and waits if the semaphore is already set. +signal :: (Concurrent :> es) => Semaphore -> Eff es () +signal = atomically . STM.signal + + +-- | Ensures a semaphore is set. Returns @True@ if the semaphore was not +-- already set. +set :: (Concurrent :> es) => Semaphore -> Eff es Bool +set = atomically . STM.set + + +-- | Check if a semaphore is set, without changing its state. Returns @True@ if +-- the semaphore is set, @False@ otherwise. +peek :: (Concurrent :> es) => Semaphore -> Eff es Bool +peek = atomically . STM.peek diff --git a/src/Atelier/Types/Semaphore/STM.hs b/src/Atelier/Types/Semaphore/STM.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Types/Semaphore/STM.hs @@ -0,0 +1,87 @@ +-- | STM variant of 'Atelier.Types.Semaphore'. +module Atelier.Types.Semaphore.STM + ( Semaphore + , new + , newSet + , wait + , signal + , unset + , set + , peek + , withSemaphore + ) where + +import Effectful.Concurrent.STM + ( Concurrent + , STM + , TMVar + , atomically + , isEmptyTMVar + , newEmptyTMVar + , newTMVar + , putTMVar + , takeTMVar + , tryPutTMVar + , tryTakeTMVar + ) +import Effectful.Exception (bracket_) + + +-- | A flag for threads to either wait to be set, or signal to other processes +-- to continue. A synchronization primitive. +-- +-- Using 'wait' on an unset semaphore blocks. +-- Using 'signal' on a set semaphore blocks. +-- All other operations do not block. +-- +-- Using 'wait' on a semaphore makes it unset once the wait resolves. +-- Using 'signal' on a semaphore makes it set once the signal resolves. +newtype Semaphore = Semaphore (TMVar ()) + + +-- | Creates a new, unset semaphore. Waiting on this semaphore immediately will +-- block. +new :: STM Semaphore +new = Semaphore <$> newEmptyTMVar + + +-- | Creates a new, set semaphore. Signalling on this semaphore immediately +-- will block. +newSet :: STM Semaphore +newSet = Semaphore <$> newTMVar () + + +-- | Wait for a semaphore to be set. Blocks and waits for the semaphore to be +-- set if it is not already set. +wait :: Semaphore -> STM () +wait (Semaphore ref) = takeTMVar ref + + +-- | Ensures a semaphore is unset. Returns @True@ if the semaphore was set. +unset :: Semaphore -> STM Bool +unset (Semaphore ref) = isJust <$> tryTakeTMVar ref + + +-- | Set a semaphore. Blocks and waits if the semaphore is already set. +signal :: Semaphore -> STM () +signal (Semaphore ref) = putTMVar ref () + + +-- | Ensures a semaphore is set. Returns @True@ if the semaphore was not +-- already set. +set :: Semaphore -> STM Bool +set (Semaphore ref) = tryPutTMVar ref () + + +-- | Check if a semaphore is set, without changing its state. Returns @True@ if +-- the semaphore is set, @False@ otherwise. +peek :: Semaphore -> STM Bool +peek (Semaphore ref) = not <$> isEmptyTMVar ref + + +-- | Waits for exclusive access to the semaphore before running a computation, +-- ensuring it is set before starting, and that it is signalled afterwards. +-- If another thread signals or sets the semaphore in the meantime, the caller +-- will _not_ be blocked when attempting to signal the semaphore afterwards. +withSemaphore :: (Concurrent :> es) => Semaphore -> Eff es a -> Eff es a +withSemaphore ref = bracket_ (atomically $ wait ref) (atomically $ set ref) diff --git a/src/Atelier/Types/WithDefaults.hs b/src/Atelier/Types/WithDefaults.hs new file mode 100644 --- /dev/null +++ b/src/Atelier/Types/WithDefaults.hs @@ -0,0 +1,39 @@ +-- | Merge a type's 'Default' value into incoming JSON before parsing, so fields +-- absent from the input fall back to their defaults instead of failing. +-- +-- Derive 'FromJSON' via this wrapper when partial JSON should be completed from +-- a 'Default' instance. Missing non-'Maybe' fields then take their default +-- value rather than causing a parse error: +-- +-- @ +-- data Config = Config { retries :: Int, verbose :: Bool } +-- deriving stock (Generic) +-- deriving (FromJSON) via (WithDefaults Config) +-- +-- instance Default Config where +-- def = Config { retries = 3, verbose = False } +-- @ +-- +-- Parsing @{\"verbose\": true}@ then yields @Config { retries = 3, verbose = True }@. +module Atelier.Types.WithDefaults + ( WithDefaults (..) + ) where + +import Data.Aeson (FromJSON (..), ToJSON (..), Value (..)) +import Data.Default (Default (..)) + +import Data.Aeson.KeyMap qualified as KM + + +-- | Carrier that fills missing JSON fields from a type's 'Default' instance +-- before parsing. +newtype WithDefaults a = WithDefaults {getWithDefaults :: a} + + +instance (Default a, FromJSON a, ToJSON a) => FromJSON (WithDefaults a) where + parseJSON v = WithDefaults <$> parseJSON merged + where + merged = mergeLeft (toJSON (def :: a)) v + + mergeLeft (Object l) (Object r) = Object $ KM.unionWith mergeLeft l r + mergeLeft _ r = r diff --git a/test/Driver.hs b/test/Driver.hs new file mode 100644 --- /dev/null +++ b/test/Driver.hs @@ -0,0 +1,2 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover #-} + diff --git a/test/Unit/Atelier/ConfigSpec.hs b/test/Unit/Atelier/ConfigSpec.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Atelier/ConfigSpec.hs @@ -0,0 +1,100 @@ +module Unit.Atelier.ConfigSpec (spec_Config) where + +import Data.Aeson (FromJSON, ToJSON) +import Data.Default (Default (..)) +import GHC.Generics (Generically (..)) +import Test.Hspec (Spec, describe, it, shouldBe) + +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KM + +import Atelier.Config (LoadedConfig (..), extractNestedConfig) +import Atelier.Types.QuietSnake (QuietSnake (..)) +import Atelier.Types.WithDefaults (WithDefaults (..)) + + +spec_Config :: Spec +spec_Config = do + describe "extractNestedConfig" testExtractNestedConfig + + +testExtractNestedConfig :: Spec +testExtractNestedConfig = do + it "should use default value for non-object Values" do + let actual = extractNestedConfig @"foo" $ LoadedConfig $ Aeson.String "foo" + actual `shouldBe` Val "default" + + it "should fetch top-level property" do + let actual = + extractNestedConfig @"foo" + $ LoadedConfig + $ Aeson.Object + $ KM.singleton "foo" + $ Aeson.Object + $ KM.singleton "value" + $ Aeson.String "actual" + actual `shouldBe` Val "actual" + + it "should return default for a missing key" do + let actual = + extractNestedConfig @"missing" + $ LoadedConfig + $ Aeson.Object KM.empty + actual `shouldBe` Val "default" + + it "should fetch a nested property via dot notation" do + let actual = + extractNestedConfig @"foo.bar" + $ LoadedConfig + $ Aeson.Object + $ KM.singleton "foo" + $ Aeson.Object + $ KM.singleton "bar" + $ Aeson.Object + $ KM.singleton "value" + $ Aeson.String "nested" + actual `shouldBe` Val "nested" + + it "should return default for a missing intermediate segment" do + let actual = + extractNestedConfig @"foo.bar" + $ LoadedConfig + $ Aeson.Object KM.empty + actual `shouldBe` Val "default" + + it "should return default for a missing leaf segment" do + let actual = + extractNestedConfig @"foo.bar" + $ LoadedConfig + $ Aeson.Object + $ KM.singleton "foo" + $ Aeson.Object KM.empty + actual `shouldBe` Val "default" + + it "should return default when an intermediate value is not an object" do + let actual = + extractNestedConfig @"foo.bar" + $ LoadedConfig + $ Aeson.Object + $ KM.singleton "foo" + $ Aeson.String "not-an-object" + actual `shouldBe` Val "default" + + it "should return default when the leaf value fails to decode" do + let actual = + extractNestedConfig @"foo" + $ LoadedConfig + $ Aeson.Object + $ KM.singleton "foo" + $ Aeson.String "not-an-object" + actual `shouldBe` Val "default" + + +data Val = Val {value :: Text} + deriving stock (Eq, Generic, Show) + deriving (ToJSON) via Generically Val + deriving (FromJSON) via WithDefaults (QuietSnake Val) + + +instance Default Val where + def = Val "default" diff --git a/test/Unit/Atelier/Effects/AwaitSpec.hs b/test/Unit/Atelier/Effects/AwaitSpec.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Atelier/Effects/AwaitSpec.hs @@ -0,0 +1,98 @@ +module Unit.Atelier.Effects.AwaitSpec (spec_Await) where + +import Effectful (runEff, runPureEff) +import Effectful.Concurrent (runConcurrent) +import Effectful.State.Static.Shared (evalState, state) +import Effectful.Writer.Static.Shared (runWriter, tell) +import Test.Hspec (Spec, describe, it, shouldBe) + +import Effectful.Concurrent.STM qualified as STM + +import Atelier.Effects.Chan (runChan) +import Atelier.Effects.Conc (runConc) + +import Atelier.Effects.Await qualified as Await +import Atelier.Effects.Yield qualified as Yield + + +spec_Await :: Spec +spec_Await = do + describe "eachAwait" testEachAwait + describe "takeAwait" testTakeAwait + describe "awaitYield" testAwaitYield + + +testEachAwait :: Spec +testEachAwait = do + it "answers each await with the given action's result" do + let xs = + runPureEff + . evalState @Int 0 + . Await.eachAwait (state \s -> (s, s + 1)) + $ replicateM 4 Await.await + xs `shouldBe` [0, 1, 2, 3] + + +testTakeAwait :: Spec +testTakeAwait = do + it "yields exactly N values from the await stream" do + let (_, xs) = + runPureEff + . evalState @Int 0 + . Yield.yieldToList + . Await.eachAwait @Int (state \s -> (s, s + 1)) + $ Await.takeAwait 3 + xs `shouldBe` [0, 1, 2] + + describe "when N is zero" $ it "yields nothing" do + let (_, xs) = + runPureEff + . Yield.yieldToList + . Await.eachAwait @Int (pure 7) + $ Await.takeAwait 0 + xs `shouldBe` [] + + +testAwaitYield :: Spec +testAwaitYield = do + it "pipes yielded values into the await stream" do + (_, result) <- + runTest + $ Await.awaitYield (Yield.inFoldable @Int [1, 2, 3] >> blockForever) + $ replicateM 3 Await.await >>= tell + + result `shouldBe` [1, 2, 3] + + it "returns the result of the awaiting computation" do + -- The yielder blocks after yielding so the awaiter reliably wins the + -- termination race and its 'tell' is observed; otherwise the yielder can + -- finish first and cancel the awaiter before it writes (flaky under load). + (_, result) <- + runTest + $ Await.awaitYield @Int (Yield.yield 99 >> blockForever) + $ fmap (* 2) Await.await >>= tell . one + result `shouldBe` [198] + + describe "when the awaiter finishes before the yielder" + $ it "terminates with the awaiter's result" do + (result, _) <- + runTest . runConcurrent $ do + Await.awaitYield @Int + (Yield.inFoldable [1 .. 100] >> blockForever) + Await.await + result `shouldBe` 1 + + describe "when the yielder finishes before the awaiter" + $ it "terminates with the yielder's result" do + (result :: Int, _) <- + runTest + $ Await.awaitYield @Int (Yield.yield 1 >> pure 2) + $ Await.await >> Await.await >> pure 1 + result `shouldBe` 2 + where + runTest = runEff . runConcurrent . runConc . runChan . runWriter + -- Block the current (forked) computation indefinitely; used to keep a yielder + -- alive so the awaiter wins the awaitYield termination race. The explicit + -- signature keeps it polymorphic across the differing effect stacks below. + blockForever :: (STM.Concurrent :> es) => Eff es a + blockForever = STM.atomically STM.retry diff --git a/test/Unit/Atelier/Effects/Cache/SingleflightSpec.hs b/test/Unit/Atelier/Effects/Cache/SingleflightSpec.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Atelier/Effects/Cache/SingleflightSpec.hs @@ -0,0 +1,240 @@ +module Unit.Atelier.Effects.Cache.SingleflightSpec (spec_Singleflight) where + +import Effectful (IOE, runEff) +import Effectful.Concurrent (Concurrent, runConcurrent) +import Effectful.Exception (catch, throwIO) +import Effectful.State.Static.Shared (State, modify, runState) +import Test.Hspec (Spec, describe, it, shouldBe, shouldThrow) + +import Atelier.Effects.Cache.Singleflight (Singleflight, runSingleflight, updateCache, withCache) +import Atelier.Effects.Conc (Conc, runConc) +import Atelier.Effects.Delay (Delay, runDelay) +import Atelier.Effects.Monitoring.Tracing (Tracing, runTracingNoOp) +import Atelier.Time (Millisecond) +import Atelier.Types.Semaphore (Semaphore) + +import Atelier.Effects.Conc qualified as Conc +import Atelier.Effects.Delay qualified as Delay +import Atelier.Types.Semaphore qualified as Sem + + +-- | Test exception type +data TestException = TestException Text + deriving stock (Eq, Show) + deriving anyclass (Exception) + + +-- | Run a Singleflight test with execution counter +runSingleflightTest + :: Eff [Singleflight Int Int, State Int, Delay, Tracing, Conc, Concurrent, IOE] a + -> IO (a, Int) +runSingleflightTest action = + runEff + . runConcurrent + . runConc + . runTracingNoOp + . runDelay + . runState @Int 0 + . runSingleflight @Int @Int + $ action + + +-- | A computation that increments the execution counter and returns a value +compute :: (State Int :> es) => Int -> Eff es Int +compute value = do + modify @Int (+ 1) + pure value + + +-- | A slow computation that increments the counter +slowCompute :: (Concurrent :> es, State Int :> es) => Semaphore -> Int -> Eff es Int +slowCompute sem value = do + Sem.wait sem + modify @Int (+ 1) + pure value + + +spec_Singleflight :: Spec +spec_Singleflight = do + describe "Basic Behaviors" $ do + describe "First request executes computation" $ do + it "executes the computation on first request" $ do + (result, execCount) <- runSingleflightTest $ do + withCache 1 (compute 42) + result `shouldBe` 42 + execCount `shouldBe` 1 + + describe "Cached value returned on second request" $ do + it "returns cached value without re-executing" $ do + (result, execCount) <- runSingleflightTest $ do + r1 <- withCache 1 (compute 42) + r2 <- withCache 1 (compute 42) + pure (r1, r2) + result `shouldBe` (42, 42) + execCount `shouldBe` 1 + + it "returns cached value across multiple sequential requests" $ do + (results, execCount) <- runSingleflightTest $ do + r1 <- withCache 1 (compute 42) + r2 <- withCache 1 (compute 42) + r3 <- withCache 1 (compute 42) + pure [r1, r2, r3] + results `shouldBe` [42, 42, 42] + execCount `shouldBe` 1 + + describe "Concurrent requests are deduplicated" $ do + it "executes computation once for concurrent requests" $ do + (results, execCount) <- runSingleflightTest $ do + -- Launch 10 concurrent requests for the same key + asyncs <- replicateM 10 do + sem <- Sem.new + async <- Conc.fork $ withCache 1 (slowCompute sem 42) + pure (sem, async) + traverse_ Sem.set $ fst <$> asyncs + traverse Conc.await $ snd <$> asyncs + all (== 42) results `shouldBe` True + length results `shouldBe` 10 + execCount `shouldBe` 1 + + it "all concurrent waiters receive the same result" $ do + (results, execCount) <- runSingleflightTest $ do + sem <- Sem.new + -- Launch concurrent requests with different delays + a1 <- Conc.fork $ withCache 1 (slowCompute sem 99) + Delay.wait (1 :: Millisecond) -- Ensure first request starts + a2 <- Conc.fork $ withCache 1 (compute 99) + a3 <- Conc.fork $ withCache 1 (compute 99) + Sem.signal sem -- Let first request continue + r1 <- Conc.await a1 + r2 <- Conc.await a2 + r3 <- Conc.await a3 + pure [r1, r2, r3] + results `shouldBe` [99, 99, 99] + execCount `shouldBe` 1 + + describe "Different keys execute independently" $ do + it "executes separate computations for different keys" $ do + (results, execCount) <- runSingleflightTest $ do + r1 <- withCache 1 (compute 10) + r2 <- withCache 2 (compute 20) + r3 <- withCache 3 (compute 30) + pure [r1, r2, r3] + results `shouldBe` [10, 20, 30] + execCount `shouldBe` 3 + + it "different keys can run concurrently" $ do + (results, execCount) <- runSingleflightTest $ do + sem <- Sem.newSet + a1 <- Conc.fork $ withCache 1 (slowCompute sem 10) + a2 <- Conc.fork $ withCache 2 (slowCompute sem 20) + a3 <- Conc.fork $ withCache 3 (slowCompute sem 30) + replicateM_ 3 $ Sem.signal sem + r1 <- Conc.await a1 + r2 <- Conc.await a2 + r3 <- Conc.await a3 + pure [r1, r2, r3] + all (\r -> r `elem` [10, 20, 30]) results `shouldBe` True + execCount `shouldBe` 3 + + describe "UpdateCache pre-populates the cache" $ do + it "returns pre-populated value without executing computation" $ do + (result, execCount) <- runSingleflightTest $ do + updateCache [(1, 99)] + withCache 1 (compute 42) + result `shouldBe` 99 + execCount `shouldBe` 0 + + it "pre-populated values are returned by subsequent requests" $ do + (results, execCount) <- runSingleflightTest $ do + updateCache [(1, 99)] + r1 <- withCache 1 (compute 42) + r2 <- withCache 1 (compute 42) + pure [r1, r2] + results `shouldBe` [99, 99] + execCount `shouldBe` 0 + + describe "UpdateCache handles multiple entries" $ do + it "correctly handles multiple key-value pairs" $ do + (results, execCount) <- runSingleflightTest $ do + updateCache [(1, 10), (2, 20), (3, 30)] + r1 <- withCache 1 (compute 99) + r2 <- withCache 2 (compute 99) + r3 <- withCache 3 (compute 99) + pure [r1, r2, r3] + results `shouldBe` [10, 20, 30] + execCount `shouldBe` 0 + + describe "All concurrent waiters receive the result" $ do + it "broadcasts result to all waiting requests" $ do + (results, execCount) <- runSingleflightTest $ do + -- Start one slow computation and many fast waiters + asyncs <- replicateM 20 do + sem <- Sem.new + async <- Conc.fork $ withCache 1 (slowCompute sem 777) + pure (sem, async) + traverse_ Sem.signal $ fst <$> asyncs + traverse Conc.await $ snd <$> asyncs + all (== 777) results `shouldBe` True + length results `shouldBe` 20 + execCount `shouldBe` 1 + + describe "Edge Cases" $ do + describe "Computation throws exception" $ do + it "propagates exception to the first caller" $ do + let action = runSingleflightTest $ do + withCache @Int @Int 1 (throwIO $ TestException "boom") + action `shouldThrow` (\(TestException msg) -> msg == "boom") + + it "exception does not get cached" $ do + (result, execCount) <- runSingleflightTest $ do + -- First request throws + _ <- + (withCache @Int @Int 1 (throwIO $ TestException "boom")) + `catch` \(_ :: TestException) -> pure 0 + -- Second request should re-execute + withCache 1 (compute 42) + result `shouldBe` 42 + execCount `shouldBe` 1 + + it "propagates exception to all concurrent waiters" $ do + let action = runSingleflightTest $ do + sem <- Sem.new + a1 <- Conc.fork $ withCache @Int @Int 1 (slowCompute sem 42 >> throwIO (TestException "concurrent-boom")) + Delay.wait (1 :: Millisecond) + a2 <- Conc.fork $ withCache @Int @Int 1 (compute 99) + Sem.signal sem + _ <- Conc.await a1 + Conc.await a2 + action `shouldThrow` (\(TestException msg) -> msg == "concurrent-boom") + + describe "UpdateCache on in-flight computation" $ do + it "overrides result of in-flight computation" $ do + (result, execCount) <- runSingleflightTest $ do + sem <- Sem.new + -- Start slow computation + a1 <- Conc.fork $ withCache 1 (slowCompute sem 42) + Delay.wait (1 :: Millisecond) -- Let it start + -- Update cache while computation is running + updateCache [(1, 999)] + -- Both should get the updated value + Sem.signal sem + Conc.await a1 + result `shouldBe` 999 + execCount `shouldBe` 1 + + it "waiting requests receive updated value" $ do + (results, execCount) <- runSingleflightTest $ do + sem <- Sem.new + -- Start slow computation and waiters + a1 <- Conc.fork $ withCache 1 (slowCompute sem 42) + Delay.wait (1 :: Millisecond) + a2 <- Conc.fork $ withCache 1 (compute 42) + Delay.wait (1 :: Millisecond) + -- Update while they're all waiting/running + updateCache [(1, 888)] + Sem.signal sem + r1 <- Conc.await a1 + r2 <- Conc.await a2 + pure [r1, r2] + all (== 888) results `shouldBe` True + execCount `shouldBe` 1 diff --git a/test/Unit/Atelier/Effects/CacheSpec.hs b/test/Unit/Atelier/Effects/CacheSpec.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Atelier/Effects/CacheSpec.hs @@ -0,0 +1,200 @@ +module Unit.Atelier.Effects.CacheSpec (spec_Cache) where + +import Data.Time (UTCTime (..), addUTCTime, fromGregorian) +import Data.Time.Clock (NominalDiffTime) +import Effectful (runEff) +import Effectful.Concurrent (runConcurrent) +import Effectful.Reader.Static (runReader) +import Effectful.State.Static.Shared (evalState, modify) +import Hedgehog (forAll, (===)) +import Test.Hspec (Spec, describe, it, shouldBe) +import Test.Hspec.Hedgehog (hedgehog) + +import Effectful.Concurrent.STM qualified as STM +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range + +import Atelier.Effects.Cache (Config (..), cacheDelete, cacheInsert, cacheLookup, cacheModify, runCacheTtlWithWait) +import Atelier.Effects.Clock (runClockState) +import Atelier.Effects.Conc (runConc) +import Atelier.Effects.Delay (runDelay) +import Atelier.Effects.Log (runLogNoOp) + + +spec_Cache :: Spec +spec_Cache = do + describe "Basic Operations" do + it "lookup on absent key returns Nothing" do + result <- runCacheTest $ cacheLookup 1 + result `shouldBe` Nothing + + it "lookup after insert returns Just value" do + result <- runCacheTest do + cacheInsert 1 42 + cacheLookup 1 + result `shouldBe` Just 42 + + it "lookup after delete returns Nothing" do + result <- runCacheTest $ do + cacheInsert 1 42 + cacheDelete 1 + cacheLookup 1 + result `shouldBe` Nothing + + it "insert twice updates value" do + result <- runCacheTest $ do + cacheInsert 1 42 + cacheInsert 1 99 + cacheLookup 1 + result `shouldBe` Just 99 + + it "delete on absent key is a no-op" do + result <- runCacheTest $ do + cacheDelete 1 + cacheLookup 1 + result `shouldBe` Nothing + + describe "Modify" do + it "modify on absent key uses Nothing branch" do + result <- runCacheTest $ cacheModify @Int @Int 1 (maybe 0 (+ 1)) + result `shouldBe` 0 + + it "modify on present key uses Just branch" do + result <- runCacheTest $ do + cacheInsert 1 10 + cacheModify 1 (maybe 0 (+ 1)) + result `shouldBe` 11 + + it "modify returns the new value" do + result <- runCacheTest $ do + _ <- cacheModify 1 (maybe 5 (+ 5)) + cacheModify 1 (maybe 5 (+ 5)) + result `shouldBe` 10 + + describe "TTL Eviction" do + it "entry is present before TTL expires" do + result <- runBase . runCacheTestWithWait (STM.atomically STM.retry) $ do + cacheInsert 1 42 + cacheLookup 1 + result `shouldBe` Just 42 + + it "entry is evicted after cleanup thread fires past TTL" do + result <- runBase do + trigger <- STM.atomically STM.newEmptyTMVar + done <- STM.atomically STM.newEmptyTMVar + runCacheTestWithWait (cleanupBarrier done trigger) do + awaitReady done + cacheInsert 1 42 + v1 <- cacheLookup 1 + modify (addUTCTime (ttl + 1)) + stepCleanup trigger done -- run one cleanup, block until it finishes + v2 <- cacheLookup 1 + pure (v1, v2) + result `shouldBe` (Just 42, Nothing) + + it "entry within TTL survives cleanup" do + result <- runBase do + trigger <- STM.atomically STM.newEmptyTMVar + done <- STM.atomically STM.newEmptyTMVar + runCacheTestWithWait (cleanupBarrier done trigger) do + awaitReady done + cacheInsert 1 42 + modify (addUTCTime (ttl - 1)) + stepCleanup trigger done + cacheLookup 1 + result `shouldBe` Just 42 + + it "re-inserted entry retains original TTL window" do + result <- runBase do + trigger <- STM.atomically STM.newEmptyTMVar + done <- STM.atomically STM.newEmptyTMVar + runCacheTestWithWait (cleanupBarrier done trigger) do + awaitReady done + cacheInsert 1 42 + v1 <- cacheLookup 1 + + -- re-insert before TTL expires: updates value but preserves createdAt = t0 + modify (addUTCTime (ttl - 1)) + stepCleanup trigger done + cacheInsert 1 99 + v2 <- cacheLookup 1 + + -- advance clock past original TTL + modify (addUTCTime 2) + stepCleanup trigger done + v3 <- cacheLookup 1 + + pure (v1, v2, v3) + -- createdAt was preserved from the first insert, so the entry is expired and evicted + result `shouldBe` (Just 42, Just 99, Nothing) + + describe "Properties" do + it "insert then lookup roundtrips value" $ hedgehog do + v <- forAll $ Gen.int (Range.linear 0 1000) + result <- liftIO $ runCacheTest $ do + cacheInsert 1 v + cacheLookup 1 + result === Just v + + it "distinct keys have independent values" $ hedgehog do + m <- forAll $ Gen.int (Range.linear 1 20) + n <- forAll $ Gen.int (Range.linear 1 20) + (a, b) <- liftIO $ runCacheTest $ do + cacheInsert 1 m + cacheInsert 2 n + va <- cacheLookup 1 + vb <- cacheLookup 2 + pure (va, vb) + a === Just m + b === Just n + + it "interleaved key access is independent" $ hedgehog do + keys <- forAll $ Gen.list (Range.linear 1 50) Gen.bool + -- count inserts per key by interleaving + counts <- liftIO $ runCacheTest $ do + let step True = cacheModify @Int 1 (maybe 1 (+ 1)) + step False = cacheModify @Int 2 (maybe 1 (+ 1)) + traverse step keys + let key1Counts = [c | (k, c) <- zip keys counts, k] + key2Counts = [c | (k, c) <- zip keys counts, not k] + key1Counts === [1 .. length key1Counts] + key2Counts === [1 .. length key2Counts] + + it "concurrent inserts to different keys don't interfere" $ hedgehog do + n <- forAll $ Gen.int (Range.linear 1 20) + results <- liftIO $ runCacheTest $ do + for_ [1 .. n] \i -> cacheInsert i i + traverse (\i -> cacheLookup i) [1 .. n] + results === map (Just . id) [1 .. n] + + it "modify is atomic under concurrency" $ hedgehog do + n <- forAll $ Gen.int (Range.linear 1 50) + finalVal <- liftIO $ runCacheTest $ do + for_ [1 .. n] \_ -> cacheModify 1 (maybe 1 (+ 1)) + cacheLookup 1 + finalVal === Just n + where + runBase = runEff . runConcurrent + runCacheTest = runBase . runCacheTestWithWait (STM.atomically STM.retry) + runCacheTestWithWait wait = + runLogNoOp + . runConc + . runDelay + . evalState epoch + . runClockState + . runReader (Config {entryTtl = ttl, cleanupInterval = 3600}) + . runCacheTtlWithWait @Int @Int wait + epoch = UTCTime (fromGregorian 1970 1 1) 0 + ttl = 3600 :: NominalDiffTime + + -- Deterministic control over the background cleanup thread, replacing + -- real-time 'Delay.wait' guesses with a handshake. The thread runs its + -- injected wait ('cleanupBarrier') once per loop: it acknowledges that the + -- previous cycle finished (via 'done'), then blocks for the next trigger. + -- 'stepCleanup' triggers one cycle and blocks until that cycle's eviction has + -- completed, so look-ups afterwards observe a settled state. + cleanupBarrier done trigger = + STM.atomically (STM.putTMVar done ()) >> STM.atomically (STM.takeTMVar trigger) + awaitReady done = STM.atomically (STM.takeTMVar done) + stepCleanup trigger done = + STM.atomically (STM.putTMVar trigger ()) >> STM.atomically (STM.takeTMVar done) diff --git a/test/Unit/Atelier/Effects/ChanSpec.hs b/test/Unit/Atelier/Effects/ChanSpec.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Atelier/Effects/ChanSpec.hs @@ -0,0 +1,85 @@ +module Unit.Atelier.Effects.ChanSpec (spec_Chan) where + +import Effectful (IOE, runEff) +import Effectful.Timeout (Timeout, runTimeout) +import Hedgehog (forAll, (===)) +import Test.Hspec (Spec, describe, it, shouldBe) +import Test.Hspec.Hedgehog (hedgehog) + +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range + +import Atelier.Effects.Chan (Chan, dupChan, newChan, readChan, readChanBatched, runChan, writeChan) +import Atelier.Time (Millisecond, Second) + + +spec_Chan :: Spec +spec_Chan = do + describe "Basic Operations" do + it "writeChan then readChan roundtrips a value" do + result <- runChanTest $ do + (inChan, outChan) <- newChan + writeChan inChan (42 :: Int) + readChan outChan + result `shouldBe` 42 + + it "preserves FIFO order" $ hedgehog do + xs <- forAll $ Gen.list (Range.linear 0 50) (Gen.int Range.linearBounded) + result <- liftIO $ runChanTest $ do + (inChan, outChan) <- newChan + traverse_ (writeChan inChan) xs + replicateM (length xs) (readChan outChan) + result === xs + + it "dupChan creates an independent reader that receives the same messages" do + result <- runChanTest $ do + (inChan, outChan1) <- newChan + outChan2 <- dupChan inChan + writeChan inChan (42 :: Int) + v1 <- readChan outChan1 + v2 <- readChan outChan2 + pure (v1, v2) + result `shouldBe` (42, 42) + + describe "readChanBatched" do + describe "when items fill the batch before timeout" do + it "returns a full batch" do + result <- runChanTest $ do + (inChan, outChan) <- newChan + traverse_ (writeChan inChan) [1, 2, 3 :: Int] + readChanBatched (1 :: Second) 3 outChan + result `shouldBe` (1 :| [2, 3]) + + it "caps at batchSize even when more items are available" $ hedgehog do + batchSize <- forAll $ Gen.int (Range.linear 1 20) + extra <- forAll $ Gen.int (Range.linear 1 10) + let n = batchSize + extra + result <- liftIO $ runChanTest $ do + (inChan, outChan) <- newChan + traverse_ (writeChan inChan) [1 .. n] + readChanBatched (1 :: Second) batchSize outChan + length result === batchSize + + describe "when timeout fires before batch is full" do + it "returns a singleton when only one item is in the channel" do + result <- runChanTest $ do + (inChan, outChan) <- newChan + writeChan inChan (1 :: Int) + readChanBatched (1 :: Millisecond) 5 outChan + result `shouldBe` (1 :| []) + + it "returns a partial batch" do + result <- runChanTest $ do + (inChan, outChan) <- newChan + writeChan inChan (1 :: Int) + writeChan inChan 2 + readChanBatched (1 :: Millisecond) 5 outChan + result `shouldBe` (1 :| [2]) + + +-------------------------------------------------------------------------------- +-- Test Helpers +-------------------------------------------------------------------------------- + +runChanTest :: Eff '[Chan, Timeout, IOE] a -> IO a +runChanTest = runEff . runTimeout . runChan diff --git a/test/Unit/Atelier/Effects/Conc/TeardownStressSpec.hs b/test/Unit/Atelier/Effects/Conc/TeardownStressSpec.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Atelier/Effects/Conc/TeardownStressSpec.hs @@ -0,0 +1,123 @@ +-- | Focused stress tests for 'Conc.scoped' teardown. +-- +-- The full test suite occasionally deadlocks under heavy scheduler pressure +-- (CPU oversubscription). Earlier A/B experiments ruled out the channel +-- primitive: converting the Iterator/Publishing path from unagi to STM did not +-- change the hang rate, which points at the one layer common to every victim — +-- Ki structured-concurrency teardown in the 'Conc' effect ('runConc' / +-- 'Conc.scoped' killing and awaiting forked threads at scope close). +-- +-- These tests hammer that teardown in a tight loop so a low-probability +-- lost-wakeup becomes near-certain under load, isolating it from Pub/Sub, +-- Iterator, channels, and everything else. Iteration count is tunable via +-- @ATELIER_CONC_STRESS_N@ (crank it up under @yes@-load to reproduce). Each +-- test is wrapped in a 'timeout' so a real teardown hang fails loudly instead +-- of wedging the run. +module Unit.Atelier.Effects.Conc.TeardownStressSpec (spec_ConcTeardownStress) where + +import Control.Concurrent (threadDelay) +import Control.Exception (evaluate) +import Effectful (IOE, runEff) +import Effectful.Concurrent (Concurrent, runConcurrent) +import Effectful.Concurrent.STM (atomically, retry) +import System.Environment (lookupEnv) +import System.Timeout (timeout) +import Test.Hspec (Spec, describe, it, runIO, shouldBe) + +import Atelier.Effects.Chan (Chan, runChan) +import Atelier.Effects.Clock (Clock, runClock) +import Atelier.Effects.Conc (Conc, fork, fork_, runConc, scoped) +import Atelier.Effects.Monitoring.Tracing (Tracing, runTracingNoOp) +import Atelier.Effects.Publishing (Pub, Sub, publish, runPubSub) + +import Atelier.Effects.Iterator qualified as Iter + + +spec_ConcTeardownStress :: Spec +spec_ConcTeardownStress = do + iterations <- runIO (fromMaybe defaultIterations . (>>= readMaybe) <$> lookupEnv "ATELIER_CONC_STRESS_N") + timeoutSecs <- runIO (fromMaybe defaultTimeoutSecs . (>>= readMaybe) <$> lookupEnv "ATELIER_CONC_STRESS_TIMEOUT_S") + runSpin <- runIO (isJust <$> lookupEnv "ATELIER_CONC_SPIN") + + publishDelayUs <- runIO (fromMaybe defaultPublishDelayUs . (>>= readMaybe) <$> lookupEnv "ATELIER_CONC_STRESS_DELAY_US") + + let testTimeoutMicros = timeoutSecs * 1_000_000 + + describe "Conc.scoped teardown stress" do + it "reaps an STM-blocked fork_ across many scopes" do + completed <- + timeout testTimeoutMicros + $ runConcTest + $ replicateM_ iterations + $ scoped (void (fork_ blockForever)) + completed `shouldBe` Just () + + it "reaps a two-child scope (one parked, one transient) across many scopes" do + completed <- + timeout testTimeoutMicros + $ runConcTest + $ replicateM_ iterations + $ scoped do + _ <- fork (liftIO (threadDelay 5)) + void (fork_ blockForever) + completed `shouldBe` Just () + + -- Faithful repro of the actual full-suite victim: the 'fromEvents' Iterator + -- pattern over its real effect stack, looped. The producer's 10us delay is + -- the ONLY thing giving the forked listener time to subscribe before the + -- first publish; under load that race can drop early events and wedge the + -- consumer's 'Iter.next' (it reads exactly as many as were published, so any + -- dropped event blocks forever). Also exercises the deep-stack + -- 'Conc.scoped' unlift/teardown that the bare tests above strip away. + describe "fromEvents Iterator pattern stress (full stack)" do + it "drives the producer/listener fromEvents scope across many iterations" do + completed <- + timeout testTimeoutMicros + $ runIterTest + $ replicateM_ iterations + $ Iter.fromEvents @Int \iter -> do + _ <- fork do + liftIO (threadDelay publishDelayUs) + traverse_ publish [1, 2, 3 :: Int] + _ <- replicateM 3 (Iter.next iter) + pure () + completed `shouldBe` Just () + + -- A non-allocating fork_ is UN-KILLABLE under -O: -fomit-yields strips the + -- loop's safe point, so the async exception Ki throws at scope close — and + -- the one 'timeout' would throw — can never be delivered. It would wedge an + -- optimized build permanently and burn a core. Hence opt-in, and only safe + -- on a -O0 build (where the boxed-Int loop still allocates and stays + -- killable). This is the discriminating probe for the omit-yields theory. + when runSpin + $ describe "Conc.scoped teardown of a NON-ALLOCATING fork_ (ATELIER_CONC_SPIN=1; -O0 only)" do + it "reaps a non-allocating spin at scope exit" do + completed <- + timeout testTimeoutMicros + $ runConcTest + $ scoped (void (fork_ nonAllocatingSpin)) + completed `shouldBe` Just () + where + defaultIterations = 300 :: Int + defaultTimeoutSecs = 15 :: Int + defaultPublishDelayUs = 10 :: Int + + blockForever :: (Concurrent :> es) => Eff es Void + blockForever = atomically retry + + -- Boxed-Int loop: allocates (killable) at -O0, worker-wraps to a + -- non-allocating Int# loop (un-killable) at -O. + nonAllocatingSpin :: (IOE :> es) => Eff es Void + nonAllocatingSpin = liftIO (evaluate (spin 0)) + where + spin :: Int -> Void + spin !n = spin (n + 1) + + +runConcTest :: Eff '[Conc, Concurrent, IOE] a -> IO a +runConcTest = runEff . runConcurrent . runConc + + +-- | Mirrors 'IteratorSpec.runTest' — the full effect stack the real victim runs on. +runIterTest :: Eff '[Pub Int, Sub Int, Chan, Clock, Tracing, Conc, Concurrent, IOE] a -> IO a +runIterTest = runEff . runConcurrent . runConc . runTracingNoOp . runClock . runChan . runPubSub @Int diff --git a/test/Unit/Atelier/Effects/Conc/TracedSpec.hs b/test/Unit/Atelier/Effects/Conc/TracedSpec.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Atelier/Effects/Conc/TracedSpec.hs @@ -0,0 +1,131 @@ +module Unit.Atelier.Effects.Conc.TracedSpec (spec_ConcTraced) where + +import Control.Concurrent (newEmptyMVar, putMVar, takeMVar, threadDelay) +import Data.IORef +import Effectful (IOE, runEff) +import Effectful.Concurrent (runConcurrent) +import Effectful.Dispatch.Dynamic (interpret, localUnlift) +import OpenTelemetry.Common (TraceFlags (..)) +import OpenTelemetry.Internal.Trace.Id (SpanId (..), TraceId (..)) +import OpenTelemetry.Trace.TraceState (TraceState (..)) +import Test.Hspec (Spec, describe, it, shouldReturn, shouldSatisfy) + +import OpenTelemetry.Context qualified as Context +import OpenTelemetry.Context.ThreadLocal qualified as ThreadLocal +import OpenTelemetry.Trace.Core qualified as OT + +import Atelier.Effects.Conc (await, concStrat, fork, fork_) +import Atelier.Effects.Conc.Traced (runConc) +import Atelier.Effects.Monitoring.Tracing (SpanContext, Tracing (..), withLinkPropagation, withSpan) + + +spec_ConcTraced :: Spec +spec_ConcTraced = do + describe "withLinkPropagation" $ do + it "passes through when no parent context" $ do + ops <- newIORef [] + runEff . runTracingCapture ops + $ withLinkPropagation Nothing + $ withSpan "foo" + $ pure () + readIORef ops `shouldReturn` [PlainSpan "foo"] + + it "converts root span to linked span when parent context given" $ do + ops <- newIORef [] + runEff . runTracingCapture ops + $ withLinkPropagation (Just fakeSpanCtx) + $ withSpan "foo" + $ pure () + readIORef ops `shouldReturn` [LinkedSpan "foo"] + + it "does not convert nested spans (they already have a parent)" $ do + ops <- newIORef [] + runEff . runTracingCapture ops + $ withSpan "outer" + $ withLinkPropagation (Just fakeSpanCtx) + $ withSpan "inner" + $ pure () + readIORef ops `shouldReturn` [PlainSpan "outer", PlainSpan "inner"] + + describe "withConcTracingLinks" $ do + it "does not link when forking outside any span" $ do + ops <- newIORef [] + runEff . runConcurrent . runTracingCapture ops . runConc $ do + t <- fork $ withSpan "child" $ pure () + await t + readIORef ops `shouldReturn` [PlainSpan "child"] + + it "links forked thread's root span to the parent span" $ do + ops <- newIORef [] + runEff . runConcurrent . runTracingCapture ops . runConc $ do + withSpan "parent" $ do + t <- fork $ withSpan "child" $ pure () + await t + readIORef ops `shouldReturn` [PlainSpan "parent", LinkedSpan "child"] + + it "links fork_ thread's root span to the parent span" $ do + ops <- newIORef [] + spanRecorded <- newEmptyMVar + runEff . runConcurrent . runTracingCapture ops . runConc $ do + withSpan "parent" $ do + fork_ $ do + withSpan "bg" $ pure () + liftIO $ putMVar spanRecorded () + liftIO $ forever $ threadDelay maxBound + liftIO $ takeMVar spanRecorded + readIORef ops >>= (`shouldSatisfy` elem (LinkedSpan "bg")) + + +-------------------------------------------------------------------------------- +-- Test Infrastructure +-------------------------------------------------------------------------------- + +data SpanOp + = PlainSpan Text + | LinkedSpan Text + deriving stock (Eq, Show) + + +-- | A fake but valid span context for testing. +fakeSpanCtx :: SpanContext +fakeSpanCtx = + OT.SpanContext + (TraceFlags 0x01) + False + (TraceId "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\1") + (SpanId "\0\0\0\0\0\0\0\1") + (TraceState []) + + +-- | Test interpreter that records 'PlainSpan' vs 'LinkedSpan' operations. +-- +-- Uses real thread-local storage for context tracking so that forked threads +-- correctly start with an empty context (as they would in production), allowing +-- 'withLinkPropagation' to distinguish root spans from nested ones. +runTracingCapture + :: (IOE :> es) + => IORef [SpanOp] + -> Eff (Tracing : es) a + -> Eff es a +runTracingCapture log = interpret $ \env -> \case + WithSpan name act -> do + liftIO $ modifyIORef' log (<> [PlainSpan name]) + currentCtx <- liftIO ThreadLocal.getContext + let newCtx = Context.insertSpan (OT.wrapSpanContext fakeSpanCtx) currentCtx + oldCtx <- liftIO $ ThreadLocal.attachContext newCtx + result <- localUnlift env concStrat $ \unlift -> unlift act + liftIO $ void $ case oldCtx of + Just ctx -> ThreadLocal.attachContext ctx + Nothing -> ThreadLocal.detachContext + pure result + WithSpanLinked name _ act -> do + liftIO $ modifyIORef' log (<> [LinkedSpan name]) + localUnlift env concStrat $ \unlift -> unlift act + GetSpanContext -> do + ctx <- liftIO ThreadLocal.getContext + liftIO $ traverse OT.getSpanContext (Context.lookupSpan ctx) + GetCurrentContext -> + liftIO ThreadLocal.getContext + AddAttribute _ _ -> pure () + AddEvent _ _ -> pure () + SetStatus _ -> pure () diff --git a/test/Unit/Atelier/Effects/ConcSpec.hs b/test/Unit/Atelier/Effects/ConcSpec.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Atelier/Effects/ConcSpec.hs @@ -0,0 +1,125 @@ +module Unit.Atelier.Effects.ConcSpec (spec_Conc) where + +import Control.Exception (ErrorCall (..), throwIO) +import Effectful (IOE, runEff) +import Effectful.Concurrent (Concurrent, runConcurrent) +import Effectful.Concurrent.STM (atomically, modifyTVar', newTVarIO, readTVar, retry) +import Hedgehog (forAll, (===)) +import Test.Hspec (Spec, anyException, context, describe, it, shouldBe, shouldSatisfy, shouldThrow) +import Test.Hspec.Hedgehog (hedgehog) + +import Data.IORef qualified as IORef +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range + +import Atelier.Effects.Conc (Conc, await, awaitAll, fork, forkTry, fork_, runConc, scoped) +import Atelier.Effects.Delay (Delay, runDelay) +import Atelier.Time (Millisecond) + +import Atelier.Effects.Delay qualified as Delay + + +spec_Conc :: Spec +spec_Conc = do + describe "Thread cleanup" do + context "without scoped" do + it "demonstrates thread lifetime" $ runTest do + -- This test shows threads live for the duration of their scope + counter <- newTVarIO (0 :: Int) + + -- Thread we fork here will live until the root scope (in + -- 'runTest') exits. + fork_ $ forever $ atomically $ modifyTVar' counter (+ 1) + + let waitFor n = atomically do + v <- readTVar counter + if v >= n then pure v else retry + + countAfter <- waitFor 1 + finalCount <- waitFor (countAfter + 1) + + liftIO $ finalCount `shouldSatisfy` (> countAfter) + + context "with scoped" do + it "kills nested threads when scope exits" $ runTest do + counter <- newTVarIO (0 :: Int) + + let waitFor n = atomically do + v <- readTVar counter + if v >= n then pure v else retry + + -- Create nested scope that will clean up its threads + scoped do + fork_ $ forever $ atomically $ modifyTVar' counter (+ 1) + -- Ensure the thread has incremented at least once + _ <- waitFor 1 + pure () + -- Inner scope exits here - thread should be KILLED + + -- Capture count after scope exit + countAfter <- atomically $ readTVar counter + + -- Give any leaked thread a brief window to advance the counter + Delay.wait (1 :: Millisecond) + + -- Count should NOT increase after scope exit + finalCount <- atomically $ readTVar counter + + liftIO $ finalCount `shouldBe` countAfter + + describe "fork and await" do + it "returns the result of the forked computation" do + result <- runTestSimple $ do + t <- fork $ pure (42 :: Int) + await t + result `shouldBe` 42 + + it "executes the forked action" do + result <- runTestSimple $ do + ref <- liftIO $ IORef.newIORef False + t <- fork $ liftIO $ IORef.writeIORef ref True + await t + liftIO $ IORef.readIORef ref + result `shouldBe` True + + describe "awaitAll" do + it "waits for all forked threads to complete" $ hedgehog do + n <- forAll $ Gen.int (Range.linear 1 20) + result <- liftIO $ runTestSimple $ do + ref <- liftIO $ IORef.newIORef (0 :: Int) + replicateM_ n $ fork $ liftIO $ IORef.atomicModifyIORef' ref (\x -> (x + 1, ())) + awaitAll + liftIO $ IORef.readIORef ref + result === n + + describe "forkTry" do + it "returns Right for a successful computation" do + result <- runTestSimple $ do + t <- forkTry @ErrorCall $ pure (42 :: Int) + await t + result `shouldBe` Right 42 + + it "returns Left when the forked thread throws" do + result <- runTestSimple $ do + t <- forkTry @ErrorCall $ liftIO $ throwIO $ ErrorCall "boom" + await t + (result :: Either ErrorCall Int) `shouldSatisfy` isLeft + + describe "exception propagation" do + it "uncaught exception in forked thread propagates to the scope" do + let action = runTestSimple $ do + _ <- fork $ liftIO $ throwIO $ ErrorCall "boom" + awaitAll + action `shouldThrow` anyException + + +-------------------------------------------------------------------------------- +-- Test Helpers +-------------------------------------------------------------------------------- + +runTest :: Eff '[Delay, Conc, Concurrent, IOE] a -> IO a +runTest = runEff . runConcurrent . runConc . runDelay + + +runTestSimple :: Eff '[Conc, Concurrent, IOE] a -> IO a +runTestSimple = runEff . runConcurrent . runConc diff --git a/test/Unit/Atelier/Effects/ConsoleSpec.hs b/test/Unit/Atelier/Effects/ConsoleSpec.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Atelier/Effects/ConsoleSpec.hs @@ -0,0 +1,40 @@ +module Unit.Atelier.Effects.ConsoleSpec (spec_Console) where + +import Effectful (runPureEff) +import Test.Hspec (Spec, describe, it, shouldBe) + +import Atelier.Effects.Console (runConsoleToList) + +import Atelier.Effects.Console qualified as Console + + +spec_Console :: Spec +spec_Console = do + describe "runConsoleToList" $ do + describe "when nothing is logged" $ it "returns an empty list" $ do + let (_, msgs) = runPureEff $ runConsoleToList $ pure () + msgs `shouldBe` [] + + describe "when logging once" $ it "collects a single traced message" $ do + let (_, msgs) = runPureEff $ runConsoleToList $ Console.putStr "hello" + msgs `shouldBe` ["hello"] + + it "collects multiple logged messages in order" $ do + let (_, msgs) = + runPureEff . runConsoleToList $ do + Console.putStr "first" + Console.putStr "second" + Console.putStr "third" + msgs `shouldBe` ["first", "second", "third"] + + it "returns the result alongside the traced messages" $ do + let (result, msgs) = + runPureEff . runConsoleToList $ do + Console.putStr "side effect" + pure (42 :: Int) + result `shouldBe` 42 + msgs `shouldBe` ["side effect"] + + it "traceLn appends a newline to the message" $ do + let (_, msgs) = runPureEff $ runConsoleToList $ Console.putStrLn "line" + msgs `shouldBe` ["line\n"] diff --git a/test/Unit/Atelier/Effects/DebounceSpec.hs b/test/Unit/Atelier/Effects/DebounceSpec.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Atelier/Effects/DebounceSpec.hs @@ -0,0 +1,253 @@ +module Unit.Atelier.Effects.DebounceSpec (spec_Debounce) where + +import Data.Dynamic (fromDynamic, toDyn) +import Effectful (runEff) +import Effectful.Concurrent (runConcurrent) +import Test.Hspec + +import Data.IORef qualified as IORef +import Effectful.Concurrent.STM qualified as STM +import StmContainers.Map qualified as Map + +import Atelier.Effects.Conc (runConc) +import Atelier.Effects.Debounce + ( Entry (..) + , debounced + , debouncedWith + , ensureCallback + , ensureEntry + , runDebounce + ) +import Atelier.Effects.Delay (runDelay) +import Atelier.Time (Millisecond) + +import Atelier.Effects.Conc qualified as Conc +import Atelier.Effects.Console qualified as Console +import Atelier.Effects.Delay qualified as Delay + + +spec_Debounce :: Spec +spec_Debounce = do + describe "runDebounce" testRunDebounce + describe "ensureEntry" testEnsureEntry + describe "ensureCallback" testEnsureCallback + + +testEnsureEntry :: Spec +testEnsureEntry = do + describe "new key" do + it "gets generation 0" do + state <- runSTM Map.new + entry <- runSTM $ mkEntry 1 42 state (+) + entry.generation `shouldBe` 0 + + it "stores value as arg" do + state <- runSTM Map.new + entry <- runSTM $ mkEntry 1 42 state (+) + (entry.arg >>= fromDynamic) `shouldBe` Just @Int 42 + + describe "existing key" do + it "increments generation" do + state <- runSTM Map.new + _ <- runSTM $ mkEntry 1 2 state (+) + entry <- runSTM $ mkEntry 1 3 state (+) + entry.generation `shouldBe` 1 + + it "applies merge function to old and new value" do + state <- runSTM Map.new + _ <- runSTM $ mkEntry 1 5 state (+) + entry <- runSTM $ mkEntry 1 10 state (+) + (entry.arg >>= fromDynamic) `shouldBe` Just @Int 15 + + describe "multiple updates" do + it "accumulates generation" do + state <- runSTM Map.new + _ <- runSTM $ mkEntry 1 1 state (+) + _ <- runSTM $ mkEntry 1 2 state (+) + entry <- runSTM $ mkEntry 1 3 state (+) + entry.generation `shouldBe` 2 + + it "applies merge cumulatively" do + state <- runSTM Map.new + _ <- runSTM $ mkEntry 1 1 state (+) + _ <- runSTM $ mkEntry 1 2 state (+) + entry <- runSTM $ mkEntry 1 3 state (+) + (entry.arg >>= fromDynamic) `shouldBe` Just @Int 6 + + describe "independent keys" do + it "do not interfere with each other" do + state <- runSTM Map.new + entryA <- runSTM $ mkEntry 1 10 state (+) + entryB <- runSTM $ mkEntry 2 20 state (+) + (entryA.arg >>= fromDynamic) `shouldBe` Just @Int 10 + (entryB.arg >>= fromDynamic) `shouldBe` Just @Int 20 + entryA.generation `shouldBe` 0 + entryB.generation `shouldBe` 0 + where + mkEntry = ensureEntry @Int @Int + runSTM action = runEff . runConcurrent $ STM.atomically action + + +testEnsureCallback :: Spec +testEnsureCallback = do + it "fires callback when entry's generation still matches" do + actual <- runCallbackTest do + state <- STM.atomically Map.new + STM.atomically $ Map.insert (entry 0) (1 :: Int) state + ref <- liftIO $ IORef.newIORef @Int 0 + t <- + Conc.fork + $ ensureCallback @Int @Int 1 state 1 0 + $ liftIO . IORef.writeIORef ref + Conc.await t + liftIO $ IORef.readIORef ref + actual `shouldBe` 10 + it "skips callback when generation has been bumped" do + runCallbackTest do + state <- STM.atomically Map.new + -- A newer event has already bumped generation to 1 + STM.atomically $ Map.insert (entry 1) (1 :: Int) state + -- This fork was scheduled for generation 0; it should skip + ensureCallback @Int @Int 1 state 1 0 \_ -> + liftIO $ False `shouldBe` True + it "skips callback when entry has been removed" do + runCallbackTest do + state <- STM.atomically Map.new + ensureCallback @Int @Int 1 state 1 0 \_ -> + liftIO $ False `shouldBe` True + where + runCallbackTest = + runEff + . runConcurrent + . Console.runConsole + . Delay.runDelay + . runConc + entry generation = + Entry + { generation + , arg = Just $ toDyn @Int 10 + } + + +-- These specs exercise real-timer debouncing across forked threads. Rather than +-- sleeping a fixed duration and hoping the settle fired (which races scheduling +-- under load), each callback signals a 'TMVar' and the test blocks until it +-- fires. Multi-burst tests sequence by waiting for each burst's fire, so bursts +-- cannot merge regardless of timing. A short grace after the fire guards against +-- a spurious second fire. +testRunDebounce :: Spec +testRunDebounce = do + describe "debounced" do + describe "when invoked once" $ it "fires once" do + n <- runTest do + (count, fired) <- newCounter + debounced 50 () (bump count fired) + awaitFire fired + Delay.wait @Millisecond 80 + readCount count + n `shouldBe` 1 + + describe "when invoked multiple times" $ it "fires once" do + n <- runTest do + (count, fired) <- newCounter + debounced 50 () (bump count fired) + debounced 50 () (bump count fired) + debounced 50 () (bump count fired) + awaitFire fired + Delay.wait @Millisecond 80 + readCount count + n `shouldBe` 1 + + describe "when invoked multiple times with a delay between" $ it "fires once per burst" do + n <- runTest do + (count, fired) <- newCounter + debounced 50 () (bump count fired) + debounced 50 () (bump count fired) + awaitFire fired -- burst 1 settled and cleared the entry + debounced 50 () (bump count fired) + debounced 50 () (bump count fired) + awaitFire fired -- burst 2 is therefore independent + readCount count + n `shouldBe` 2 + + describe "when invoked many times" $ it "should not crash" do + n <- runTest do + (count, fired) <- newCounter + replicateM_ 10_000 $ debounced 50 () (bump count fired) + awaitFire fired + Delay.wait @Millisecond 80 + readCount count + n `shouldBe` 1 + + describe "debouncedWith" do + describe "when invoked once" $ it "fires callback with the provided arg" do + got <- runTest do + result <- STM.atomically STM.newEmptyTMVar + debouncedWith 50 (+) () (42 :: Int) (signal result) + awaitValue result + got `shouldBe` Just 42 + + describe "when invoked multiple times rapidly" do + it "fires once" do + n <- runTest do + (count, fired) <- newCounter + let cb _ = bump count fired + debouncedWith 50 (+) () (1 :: Int) cb + debouncedWith 50 (+) () (2 :: Int) cb + debouncedWith 50 (+) () (3 :: Int) cb + awaitFire fired + Delay.wait @Millisecond 80 + readCount count + n `shouldBe` 1 + + it "fires callback with merged arg" do + got <- runTest do + result <- STM.atomically STM.newEmptyTMVar + let cb = signal result + debouncedWith 50 (+) () (1 :: Int) cb + debouncedWith 50 (+) () (2 :: Int) cb + debouncedWith 50 (+) () (3 :: Int) cb + awaitValue result + got `shouldBe` Just 6 + + describe "when invoked multiple times with a delay between" $ it "fires once per burst with merged arg" do + xs <- runTest do + fired <- STM.atomically STM.newEmptyTMVar + ref <- STM.atomically (STM.newTVar @[Int] []) + let cb v = STM.atomically (STM.modifyTVar' ref (<> [v]) >> void (STM.tryPutTMVar fired ())) + debouncedWith 50 (+) () (1 :: Int) cb + debouncedWith 50 (+) () (2 :: Int) cb + awaitFire fired -- burst 1 fired (1+2=3); entry cleared + debouncedWith 50 (+) () (10 :: Int) cb + debouncedWith 50 (+) () (20 :: Int) cb + awaitFire fired -- burst 2 fired (10+20=30) + STM.atomically (STM.readTVar ref) + xs `shouldBe` [3, 30] + where + runTest = + runEff + . runConcurrent + . runConc + . runDelay + . runDebounce + + -- A fire counter paired with a TMVar signalling that a fire happened. + newCounter = do + count <- STM.atomically (STM.newTVar @Int 0) + fired <- STM.atomically STM.newEmptyTMVar + pure (count, fired) + bump count fired = STM.atomically do + STM.modifyTVar' count (+ 1) + void $ STM.tryPutTMVar fired () + readCount count = STM.atomically (STM.readTVar count) + signal result v = STM.atomically (STM.putTMVar result v) + + -- Block until a callback signals, bounded by a generous timeout so a real + -- regression fails loudly instead of hanging forever. + awaitFire fired = + awaitValue fired >>= \case + Just () -> pure () + Nothing -> liftIO $ expectationFailure "debounce callback did not fire within 5s" + awaitValue tmv = + either (const Nothing) Just + <$> Conc.race (Delay.wait @Millisecond 5000) (STM.atomically (STM.takeTMVar tmv)) diff --git a/test/Unit/Atelier/Effects/FileSystemSpec.hs b/test/Unit/Atelier/Effects/FileSystemSpec.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Atelier/Effects/FileSystemSpec.hs @@ -0,0 +1,138 @@ +module Unit.Atelier.Effects.FileSystemSpec (spec_FileSystem) where + +import Control.Exception (evaluate) +import Effectful (runPureEff) +import Effectful.State.Static.Shared (State, evalState) +import Test.Hspec (Spec, anyIOException, describe, it, shouldBe, shouldThrow) + +import Data.ByteString.Lazy qualified as LBS +import Data.Map.Strict qualified as M + +import Atelier.Effects.FileSystem + + +spec_FileSystem :: Spec +spec_FileSystem = describe "runFileSystemState" testFileSystemState + + +testFileSystemState :: Spec +testFileSystemState = do + describe "readFileBs" do + it "reads bytes of a file present in the state" do + run (M.singleton "/a" "hello") (readFileBs "/a") + `shouldBe` "hello" + + it "errors when the file is absent" do + evaluate (run M.empty (readFileBs "/missing")) + `shouldThrow` anyIOException + + describe "readFileLbs" do + it "reads the entire file as lazy bytes" do + run (M.singleton "/a" "hello") (readFileLbs "/a") + `shouldBe` ("hello" :: LBS.ByteString) + + it "errors when the file is absent" do + evaluate (run M.empty (readFileLbs "/missing")) + `shouldThrow` anyIOException + + describe "readFileLbsFrom" do + it "returns full content when offset is 0" do + run (M.singleton "/a" "hello") (readFileLbsFrom "/a" 0) + `shouldBe` ("hello" :: LBS.ByteString) + + it "skips the leading bytes up to the given offset" do + run (M.singleton "/a" "hello") (readFileLbsFrom "/a" 2) + `shouldBe` ("llo" :: LBS.ByteString) + + it "returns empty when offset equals the file length" do + run (M.singleton "/a" "hello") (readFileLbsFrom "/a" 5) + `shouldBe` ("" :: LBS.ByteString) + + it "errors when the file is absent" do + evaluate (run M.empty (readFileLbsFrom "/missing" 0)) + `shouldThrow` anyIOException + + describe "doesFileExist" do + it "returns True for a key present in the state" do + run (M.singleton "/a" "") (doesFileExist "/a") + `shouldBe` True + + it "returns False when the key is absent" do + run M.empty (doesFileExist "/a") + `shouldBe` False + + describe "doesPathExist" do + it "returns True when a key with the path as a string prefix exists" do + run (M.singleton "/dir/file" "") (doesPathExist "/dir") + `shouldBe` True + + it "returns False when no key shares the prefix" do + run M.empty (doesPathExist "/dir") + `shouldBe` False + + it "returns False for an exact-match key with no children" do + run (M.singleton "/dir" "") (doesPathExist "/dir") + `shouldBe` False + + describe "listDirectory" do + it "returns all keys that start with the given path" do + let fs = M.fromList [("/dir/a", ""), ("/dir/b", ""), ("/other/c", "")] + sort (run fs (listDirectory "/dir")) + `shouldBe` ["/dir/a", "/dir/b"] + + it "returns empty list when no keys share the prefix" do + run M.empty (listDirectory "/dir") + `shouldBe` [] + + it "excludes an exact-match key" do + let fs = M.fromList [("/dir", ""), ("/dir/a", "")] + run fs (listDirectory "/dir") + `shouldBe` ["/dir/a"] + + describe "removeFile" do + it "removes the file from the state" do + let result = run (M.singleton "/a" "x") do + removeFile "/a" + doesFileExist "/a" + result `shouldBe` False + + it "leaves other files unaffected" do + let result = run (M.fromList [("/a", "x"), ("/b", "y")]) do + removeFile "/a" + doesFileExist "/b" + result `shouldBe` True + + it "is a no-op when the file is absent" do + let result = run M.empty do + removeFile "/missing" + doesFileExist "/missing" + result `shouldBe` False + + describe "createDirectoryIfMissing" do + it "is a no-op — does not add any entries to the state" do + let result = run M.empty do + createDirectoryIfMissing True "/new/dir" + doesPathExist "/new/dir" + result `shouldBe` False + + describe "canonicalizePath" do + it "returns the path unchanged" do + run M.empty (canonicalizePath "/some/./path") + `shouldBe` "/some/./path" + + describe "getCurrentDirectory" do + it "returns /" do + run M.empty getCurrentDirectory + `shouldBe` "/" + + describe "getXdgRuntimeDir" do + it "returns /tmp" do + run M.empty getXdgRuntimeDir + `shouldBe` "/tmp" + + +run + :: Map FilePath ByteString + -> Eff '[FileSystem, State (Map FilePath ByteString)] a + -> a +run fs = runPureEff . evalState fs . runFileSystemState diff --git a/test/Unit/Atelier/Effects/FileWatcherSpec.hs b/test/Unit/Atelier/Effects/FileWatcherSpec.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Atelier/Effects/FileWatcherSpec.hs @@ -0,0 +1,170 @@ +module Unit.Atelier.Effects.FileWatcherSpec (spec_FileWatcher) where + +import Control.Concurrent (forkIO, killThread, newQSem, signalQSem, waitQSem) +import Data.IORef (modifyIORef, newIORef, readIORef) +import Data.List (isSuffixOf) +import Effectful (IOE, runEff) +import Effectful.Concurrent (Concurrent, runConcurrent) +import Hedgehog (Gen, PropertyT, forAll, (===)) +import Test.Hspec (Spec, describe, it, shouldBe) +import Test.Hspec.Hedgehog (hedgehog) + +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range + +import Atelier.Effects.FileWatcher (FileEvent (..), FileWatcher, Watch, deduplicateDirs, dir, dirWhere, matchesAny, runFileWatcherScripted, watchFilePaths) + + +spec_FileWatcher :: Spec +spec_FileWatcher = do + describe "deduplicateDirs" do + describe "properties" do + it "result is an antichain: no element is an ancestor of another" + $ hedgehog propAntichain + it "result covers all inputs: every input has an ancestor-or-equal in the result" + $ hedgehog propCoverage + it "is idempotent" + $ hedgehog propIdempotent + it "result is a subset of the input" + $ hedgehog propSubset + + describe "edge cases" do + it "returns empty list unchanged" do + deduplicateDirs [] `shouldBe` [] + + it "does not treat a dir as an ancestor of a similarly named dir" do + deduplicateDirs ["/src", "/srcover"] `shouldBe` ["/src", "/srcover"] + + describe "matchesAny" do + it "matches a file under a watched directory" do + matchesAny [dir "/proj/src"] "/proj/src/Foo.hs" + `shouldBe` True + + it "does not match a relative watch dir against an absolute event path" do + -- runFileWatcherIO must canonicalize Watch paths to absolute before + -- calling matchesAny, because fsnotify always reports absolute paths. + matchesAny [dir "src"] "/proj/src/Foo.hs" + `shouldBe` False + + it "applies the file predicate" do + matchesAny [dirWhere "/proj/src" (\f -> ".hs" `isSuffixOf` f)] "/proj/src/Foo.hs" + `shouldBe` True + matchesAny [dirWhere "/proj/src" (\f -> ".hs" `isSuffixOf` f)] "/proj/src/Foo.js" + `shouldBe` False + + describe "runFileWatcherScripted" testScripted + + +-------------------------------------------------------------------------------- +-- Scripted interpreter tests +-------------------------------------------------------------------------------- + +testScripted :: Spec +testScripted = do + describe "watchFilePaths" do + it "calls the callback with the scripted path" do + paths <- collectPaths ["/src/Foo.hs"] + paths `shouldBe` ["/src/Foo.hs"] + + it "calls the callback with each path in order" do + paths <- collectPaths ["/src/Foo.hs", "/src/Bar.hs"] + paths `shouldBe` ["/src/Foo.hs", "/src/Bar.hs"] + + it "ignores the watch specification" do + paths <- collectPathsWith [dir "/any"] ["/src/Foo.hs"] + paths `shouldBe` ["/src/Foo.hs"] + + it "passes the full path to the callback unchanged" do + let path = "/home/user/project/src/Some/Deep/Module.hs" + paths <- collectPaths [path] + paths `shouldBe` [path] + + +-------------------------------------------------------------------------------- +-- Helpers +-------------------------------------------------------------------------------- + +-- | Run the scripted interpreter, collecting all callback-delivered paths. +-- Uses a semaphore to wait for exactly N events before cancelling the watcher. +collectPaths :: [FilePath] -> IO [FilePath] +collectPaths = collectPathsWith [] + + +collectPathsWith :: [Watch] -> [FilePath] -> IO [FilePath] +collectPathsWith watches scripted = do + ref <- newIORef [] + sem <- newQSem 0 + tid <- forkIO $ void $ runScripted scripted $ watchFilePaths watches \filePath _fileEvent -> liftIO do + modifyIORef ref (<> [filePath]) + signalQSem sem + replicateM_ (length scripted) (waitQSem sem) + killThread tid + readIORef ref + + +runScripted :: [FilePath] -> Eff '[FileWatcher, Concurrent, IOE] a -> IO a +runScripted paths = runEff . runConcurrent . runFileWatcherScripted (map (,Modified) paths) + + +-------------------------------------------------------------------------------- +-- Properties +-------------------------------------------------------------------------------- + +propAntichain :: PropertyT IO () +propAntichain = do + dirs <- forAll genDirs + let result = deduplicateDirs dirs + let pairs = [(a, b) | a <- result, b <- result, a /= b] + all (\(a, b) -> not (isStrictAncestor a b)) pairs === True + + +propCoverage :: PropertyT IO () +propCoverage = do + dirs <- forAll genDirs + let result = deduplicateDirs dirs + all (isCoveredBy result) dirs === True + + +propIdempotent :: PropertyT IO () +propIdempotent = do + dirs <- forAll genDirs + deduplicateDirs (deduplicateDirs dirs) === deduplicateDirs dirs + + +propSubset :: PropertyT IO () +propSubset = do + dirs <- forAll genDirs + let result = deduplicateDirs dirs + all (`elem` dirs) result === True + + +-------------------------------------------------------------------------------- +-- Generators +-------------------------------------------------------------------------------- + +genDirs :: Gen [FilePath] +genDirs = Gen.list (Range.linear 0 10) genAbsDir + + +-- Generates absolute paths like /a/b/c using short segments to encourage +-- overlaps between generated paths. +genAbsDir :: Gen FilePath +genAbsDir = do + segments <- Gen.list (Range.linear 1 4) genSegment + pure $ "/" <> intercalate "/" segments + + +genSegment :: Gen String +genSegment = Gen.string (Range.linear 1 3) (Gen.element ['a', 'b', 'c', 'd']) + + +-------------------------------------------------------------------------------- +-- Helpers (mirror of FileWatcher internals) +-------------------------------------------------------------------------------- + +isStrictAncestor :: FilePath -> FilePath -> Bool +isStrictAncestor parent child = (parent <> "/") `isPrefixOf` child + + +isCoveredBy :: [FilePath] -> FilePath -> Bool +isCoveredBy result d = any (\r -> r == d || isStrictAncestor r d) result diff --git a/test/Unit/Atelier/Effects/IteratorSpec.hs b/test/Unit/Atelier/Effects/IteratorSpec.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Atelier/Effects/IteratorSpec.hs @@ -0,0 +1,118 @@ +module Unit.Atelier.Effects.IteratorSpec (spec_Iterator) where + +import Control.Concurrent (threadDelay) +import Effectful (IOE, runEff) +import Effectful.Concurrent (Concurrent, runConcurrent) +import Test.Hspec (Spec, describe, it, shouldBe) + +import Atelier.Effects.Chan (Chan, runChan) +import Atelier.Effects.Clock (Clock, runClock) +import Atelier.Effects.Conc (Conc, fork, runConc) +import Atelier.Effects.Monitoring.Tracing (Tracing, runTracingNoOp) +import Atelier.Effects.Publishing (Pub, Sub, publish, runPubSub) + +import Atelier.Effects.Iterator qualified as Iter + + +spec_Iterator :: Spec +spec_Iterator = do + describe "fromEvents" testFromEvents + describe "filter" testFilter + describe "changes" testChanges + + +testFromEvents :: Spec +testFromEvents = do + it "yields a published event" do + result <- runTest $ do + Iter.fromEvents @Int \iter -> do + _ <- fork do + liftIO $ threadDelay 10 + publish (42 :: Int) + Iter.next iter + result `shouldBe` 42 + + it "yields events in publication order" do + result <- runTest $ do + Iter.fromEvents @Int \iter -> do + _ <- fork do + liftIO $ threadDelay 10 + traverse_ publish [1, 2, 3] + replicateM 3 (Iter.next iter) + result `shouldBe` [1, 2, 3] + + it "buffers events so next can catch up" do + result <- runTest $ do + Iter.fromEvents @Int \iter -> do + _ <- fork do + liftIO $ threadDelay 10 + traverse_ publish [1, 2, 3] + liftIO $ threadDelay 5_000 + replicateM 3 (Iter.next iter) + result `shouldBe` [1, 2, 3] + + +testFilter :: Spec +testFilter = do + it "passes values that satisfy the predicate" do + result <- runTest $ do + Iter.fromEvents @Int \iter -> do + _ <- fork do + liftIO $ threadDelay 10 + traverse_ publish [1 .. 4] + Iter.next (Iter.filter even iter) + result `shouldBe` 2 + + it "skips values that do not satisfy the predicate" do + result <- runTest $ do + Iter.fromEvents @Int \iter -> do + _ <- fork do + liftIO $ threadDelay 10 + traverse_ publish [1 .. 6] + replicateM 3 (Iter.next (Iter.filter even iter)) + result `shouldBe` [2, 4, 6] + + +testChanges :: Spec +testChanges = do + it "skips values equal to the initial value" do + result <- runTest $ do + Iter.fromEvents @Int \iter -> do + _ <- fork do + liftIO $ threadDelay 10 + traverse_ publish [0, 0, 1] + Iter.next (Iter.changes 0 iter) + result `shouldBe` 1 + + it "yields values that differ from the initial value" do + result <- runTest $ do + Iter.fromEvents @Int \iter -> do + _ <- fork do + liftIO $ threadDelay 10 + traverse_ publish [1, 2, 3] + replicateM 3 (Iter.next (Iter.changes 0 iter)) + result `shouldBe` [1, 2, 3] + + it "skips initial values interspersed with non-initial values" do + result <- runTest $ do + Iter.fromEvents @Int \iter -> do + _ <- fork do + liftIO $ threadDelay 10 + traverse_ publish [0, 1, 0, 2, 0, 3] + replicateM 3 (Iter.next (Iter.changes 0 iter)) + result `shouldBe` [1, 2, 3] + + +-------------------------------------------------------------------------------- +-- Test Helpers +-------------------------------------------------------------------------------- + +runTest :: Eff '[Pub Int, Sub Int, Chan, Clock, Tracing, Conc, Concurrent, IOE] a -> IO a +runTest = + runEff + . runConcurrent + . runConc + . runTracingNoOp + . runClock + . runChan + . runPubSub @Int diff --git a/test/Unit/Atelier/Effects/LogSpec.hs b/test/Unit/Atelier/Effects/LogSpec.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Atelier/Effects/LogSpec.hs @@ -0,0 +1,87 @@ +module Unit.Atelier.Effects.LogSpec (spec_Log) where + +import Effectful (runPureEff) +import Effectful.Writer.Static.Shared (Writer, execWriter) +import Test.Hspec (Spec, describe, it, shouldBe) + +import Atelier.Effects.Log (Log, Message (..), info, runLogWriter, withNamespace) + + +runLogTest :: Eff [Log, Writer [Message]] a -> [Message] +runLogTest = + runPureEff + . execWriter @[Message] + . runLogWriter + + +spec_Log :: Spec +spec_Log = do + describe "Log with namespace" $ do + it "logs without namespace when not provided" $ do + let logs = + fmap (\m -> (m.namespace, m.text)) + . runLogTest + $ info "test message" + logs `shouldBe` [("", "test message")] + + it "prepends a namespace to the logged message" $ do + let logs = + fmap (\m -> (m.namespace, m.text)) + . runLogTest + . withNamespace "component" + $ info "test message" + logs `shouldBe` [("component", "test message")] + + describe "nested namespaces" $ do + it "appends a namespace to the current namespace" $ do + let logs = + fmap (\m -> (m.namespace, m.text)) + . runLogTest + . withNamespace "parent" + . withNamespace "child" + $ info "test message" + logs `shouldBe` [("parent.child", "test message")] + + it "handles multiple levels of nesting" $ do + let logs = + fmap (\m -> (m.namespace, m.text)) + . runLogTest + . withNamespace "level1" + . withNamespace "level2" + . withNamespace "level3" + $ info "test message" + logs `shouldBe` [("level1.level2.level3", "test message")] + + describe "namespace scoping" $ do + it "only applies namespace within its scope" $ do + let logs = + fmap (\m -> (m.namespace, m.text)) + . runPureEff + . execWriter @[Message] + . runLogWriter + $ do + info "before" + withNamespace "scoped" $ info "inside" + info "after" + logs + `shouldBe` [ ("", "before") + , ("scoped", "inside") + , ("", "after") + ] + + it "handles partially nested scopes" $ do + let logs = + fmap (\m -> (m.namespace, m.text)) + . runPureEff + . execWriter @[Message] + . runLogWriter + . withNamespace "outer" + $ do + info "outer msg" + withNamespace "inner" $ info "inner msg" + info "outer again" + logs + `shouldBe` [ ("outer", "outer msg") + , ("outer.inner", "inner msg") + , ("outer", "outer again") + ] diff --git a/test/Unit/Atelier/Effects/PublishingSpec.hs b/test/Unit/Atelier/Effects/PublishingSpec.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Atelier/Effects/PublishingSpec.hs @@ -0,0 +1,105 @@ +module Unit.Atelier.Effects.PublishingSpec (spec_Pub) where + +import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) +import Data.Time (UTCTime, getCurrentTime) +import Effectful (IOE, runEff, runPureEff) +import Effectful.Concurrent (Concurrent, runConcurrent) +import Effectful.Writer.Static.Shared (runWriter) +import Test.Hspec (Spec, context, describe, expectationFailure, it, shouldBe) + +import Atelier.Effects.Chan (Chan, runChan) +import Atelier.Effects.Clock (Clock, runClock, runClockConst) +import Atelier.Effects.Conc (Conc, runConc) +import Atelier.Effects.Monitoring.Tracing (Tracing, runTracingNoOp) +import Atelier.Effects.Publishing (Pub, Sub, forkListener, forkListener_, publish, runPubSub, runPubWriter) + + +data TestEvent = TestEvent Text + deriving stock (Eq, Show) + + +spec_Pub :: Spec +spec_Pub = do + describe "Writer implementation" $ do + context "no events published" do + it "doesn't record events" $ do + let ((), events) = runPureEff . runWriter . runPubWriter @TestEvent $ do + pure () + + length events `shouldBe` 0 + + context "events published" do + it "records events" $ do + let ((), events) = runPureEff . runWriter . runPubWriter @TestEvent $ do + publish $ TestEvent "payload" + pure () + + length events `shouldBe` 1 + case events of + [TestEvent payload] -> + payload `shouldBe` "payload" + xs -> + expectationFailure $ "Expected 1 TestEvent event, got: " <> show (length xs) + + describe "PubSub implementation" do + it "listener receives a published event" do + result <- runPubSubTest $ do + received <- liftIO newEmptyMVar + forkListener_ @TestEvent \event -> + liftIO $ putMVar received event + publish (TestEvent "hello") + liftIO $ takeMVar received + result `shouldBe` TestEvent "hello" + + it "event timestamp matches Clock at publish time" do + t0 <- getCurrentTime + result <- runPubSubTestWithClock t0 $ do + received <- liftIO newEmptyMVar + forkListener @TestEvent \ts _event -> + liftIO $ putMVar received ts + publish (TestEvent "hello") + liftIO $ takeMVar received + result `shouldBe` t0 + + it "multiple listeners each receive the published event" do + result <- runPubSubTest $ do + recv1 <- liftIO newEmptyMVar + recv2 <- liftIO newEmptyMVar + forkListener_ @TestEvent \event -> liftIO $ putMVar recv1 event + forkListener_ @TestEvent \event -> liftIO $ putMVar recv2 event + publish (TestEvent "hello") + e1 <- liftIO $ takeMVar recv1 + e2 <- liftIO $ takeMVar recv2 + pure (e1, e2) + result `shouldBe` (TestEvent "hello", TestEvent "hello") + + +-------------------------------------------------------------------------------- +-- Test Helpers +-------------------------------------------------------------------------------- + +runPubSubTest + :: Eff '[Pub TestEvent, Sub TestEvent, Chan, Clock, Tracing, Conc, Concurrent, IOE] a + -> IO a +runPubSubTest = + runEff + . runConcurrent + . runConc + . runTracingNoOp + . runClock + . runChan + . runPubSub @TestEvent + + +runPubSubTestWithClock + :: UTCTime + -> Eff '[Pub TestEvent, Sub TestEvent, Chan, Clock, Tracing, Conc, Concurrent, IOE] a + -> IO a +runPubSubTestWithClock t = + runEff + . runConcurrent + . runConc + . runTracingNoOp + . runClockConst t + . runChan + . runPubSub @TestEvent diff --git a/test/Unit/Atelier/Effects/TallySpec.hs b/test/Unit/Atelier/Effects/TallySpec.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Atelier/Effects/TallySpec.hs @@ -0,0 +1,109 @@ +module Unit.Atelier.Effects.TallySpec (spec_Tally) where + +import Effectful (IOE, runEff) +import Effectful.Concurrent (Concurrent, runConcurrent) +import Effectful.Reader.Static (Reader, runReader) +import Hedgehog (forAll, (===)) +import Test.Hspec (Spec, describe, it, shouldBe) +import Test.Hspec.Hedgehog (hedgehog) + +import Data.IORef qualified as IORef +import Data.Map.Strict qualified as Map +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range + +import Atelier.Effects.Clock (Clock, runClock) +import Atelier.Effects.Conc (Conc, runConc) +import Atelier.Effects.Delay (Delay, runDelay) +import Atelier.Effects.Log (Log, runLogNoOp) +import Atelier.Effects.Tally (Config (..), Tally, runTally, withTallyCheck) + + +spec_Tally :: Spec +spec_Tally = do + describe "Multiple Keys" do + it "works with integer keys" do + result <- runTallyTest $ checkCountsForKeys [1, 42, 999 :: Int] + result `shouldBe` Map.fromList [(1, 1), (42, 1), (999, 1)] + + describe "Custom Classifiers" do + it "identity classifier returns the raw hit count" do + result <- runTallyTest $ replicateM 4 (withTallyCheck @Int 1 id pure) + result `shouldBe` [1, 2, 3, 4 :: Int] + + it "multi-mark classifier yields correct mark for each hit" do + -- Two thresholds: warning at >2, critical at >4 + let classify c + | c > 4 = Just True -- critical + | c > 2 = Just False -- warning + | otherwise = Nothing -- ok + result <- runTallyTest $ replicateM 6 (withTallyCheck @Int 1 classify pure) + result `shouldBe` [Nothing, Nothing, Just False, Just False, Just True, Just True] + + it "classifier producing tuples gives both count and flag" do + let classify c = (c, c > 2) + result <- runTallyTest $ replicateM 4 (withTallyCheck @Int 1 classify pure) + result `shouldBe` [(1, False), (2, False), (3, True), (4, True)] + + describe "Action Execution" do + it "continuation with side effects executes correctly" do + result <- runTallyTest $ do + ref <- liftIO $ IORef.newIORef ([] :: [(Int, Bool)]) + replicateM_ 3 + $ withTallyCheck @Int 1 (\c -> (c, c > 2)) + $ \(count, exceeded) -> + liftIO $ IORef.modifyIORef' ref ((count, exceeded) :) + liftIO $ reverse <$> IORef.readIORef ref + result `shouldBe` [(1, False), (2, False), (3, True)] + + describe "Properties" do + it "kth call receives count k (count fidelity)" $ hedgehog $ do + n <- forAll $ Gen.int (Range.linear 1 100) + results <- liftIO $ runTallyTest $ replicateM n checkCount + results === [1 .. n] + + it "no lost updates under concurrency" $ hedgehog $ do + n <- forAll $ Gen.int (Range.linear 1 50) + finalCount <- liftIO $ runTallyTest $ do + replicateM_ n checkCount + checkCount + finalCount === n + 1 + + it "classifier output is passed through unchanged" $ hedgehog $ do + n <- forAll $ Gen.int (Range.linear 1 50) + offset <- forAll $ Gen.int (Range.linear 0 200) + results <- liftIO $ runTallyTest $ replicateM n (withTallyCheck @Int 1 (+ offset) pure) + results === map (+ offset) [1 .. n] + + +-------------------------------------------------------------------------------- +-- Test Helpers +-------------------------------------------------------------------------------- + +-- | Run a tally test +runTallyTest :: Eff '[Tally Int, Reader Config, Clock, Delay, Conc, Log, Concurrent, IOE] a -> IO a +runTallyTest action = + runEff + . runConcurrent + . runLogNoOp + . runConc + . runDelay + . runClock + . runReader (Config {entryTtl = 3600, cleanupInterval = 3600}) + . runTally @Int + $ action + + +-- | Increment the tally for the default test key and return the raw count +checkCount :: (Tally Int :> es) => Eff es Int +checkCount = withTallyCheck @Int 1 id pure + + +-- | Increment the tally for a specific key and return the raw count +checkCountForKey :: (Hashable key, Ord key, Tally key :> es) => key -> Eff es Int +checkCountForKey key = withTallyCheck key id pure + + +-- | Increment the tally for each key and return a map of key → count +checkCountsForKeys :: (Hashable key, Ord key, Tally key :> es) => [key] -> Eff es (Map key Int) +checkCountsForKeys keys = Map.fromList . zip keys <$> traverse checkCountForKey keys diff --git a/test/Unit/Atelier/Effects/YieldSpec.hs b/test/Unit/Atelier/Effects/YieldSpec.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Atelier/Effects/YieldSpec.hs @@ -0,0 +1,257 @@ +module Unit.Atelier.Effects.YieldSpec (spec_Yield) where + +import Effectful (runEff, runPureEff) +import Effectful.Concurrent (runConcurrent) +import Effectful.State.Static.Shared (execState, modify) +import Effectful.Writer.Static.Shared (execWriter, tell) +import Test.Hspec (Spec, describe, it, shouldBe, shouldMatchList) + +import Atelier.Effects.Chan (runChan) +import Atelier.Effects.Conc (runConc) + +import Atelier.Effects.Await qualified as Await +import Atelier.Effects.Yield qualified as Yield + + +spec_Yield :: Spec +spec_Yield = do + describe "yieldToList" testYieldToList + describe "yieldToReverseList" testYieldToReverseList + describe "forEach" testForEach + describe "ignoreYield" testIgnoreYield + describe "inFoldable" testInFoldable + describe "cycleToYield" testCycleToYield + describe "withYieldToList" testWithYieldToList + describe "enumerate" testEnumerate + describe "enumerateFrom" testEnumerateFrom + describe "map" testMap + describe "mapMaybe" testMapMaybe + describe "catMaybes" testCatMaybes + describe "filter" testFilter + describe "changes" testChanges + + +testYieldToList :: Spec +testYieldToList = do + it "collects yields in order" do + let ((), xs) = runPureEff $ Yield.yieldToList @Int do + Yield.yield 1 + Yield.yield 2 + Yield.yield 3 + xs `shouldMatchList` [1, 2, 3] + + it "returns empty list when nothing is yielded" do + let (_, xs) = runPureEff $ Yield.yieldToList @Int $ pure () + xs `shouldMatchList` [] + + it "also returns the result of the computation" do + let (r :: Text, xs) = runPureEff $ Yield.yieldToList do + Yield.yield (1 :: Int) + pure "result" + r `shouldBe` "result" + xs `shouldMatchList` [1] + + +testYieldToReverseList :: Spec +testYieldToReverseList = do + it "collects yields in reverse order" do + let ((), xs) = runPureEff $ Yield.yieldToReverseList @Int do + Yield.yield 1 + Yield.yield 2 + Yield.yield 3 + xs `shouldBe` [3, 2, 1] + + +testForEach :: Spec +testForEach = do + it "calls the action for each yielded value" do + let xs = runPureEff + $ execState @[Int] mempty + $ Yield.forEach (\x -> modify (x :)) do + Yield.yield 1 + Yield.yield 2 + Yield.yield 3 + xs `shouldBe` [3, 2, 1] + + it "can discard values" do + let xs = runPureEff $ Yield.forEach @Int (const $ pure ()) do + Yield.yield 1 + xs `shouldBe` () + + +testIgnoreYield :: Spec +testIgnoreYield = do + it "discards all yielded values" do + let x = runPureEff $ Yield.ignoreYield @Int do + Yield.yield 1 + Yield.yield 2 + x `shouldBe` () + + +testInFoldable :: Spec +testInFoldable = do + it "yields all elements of a list in order" do + let ((), xs) = runPureEff $ Yield.yieldToList $ Yield.inFoldable @Int [1, 2, 3] + xs `shouldBe` [1, 2, 3] + + it "yields nothing for an empty list" do + let ((), xs) = runPureEff $ Yield.yieldToList $ Yield.inFoldable @Int [] + xs `shouldBe` [] + + +testCycleToYield :: Spec +testCycleToYield = do + it "yields elements of a list repeatedly in order" do + xs <- + runTest + $ Await.awaitYield + (Yield.cycleToYield @Int [1, 2, 3]) + (replicateM_ 7 (Await.await >>= \x -> tell [x])) + xs `shouldBe` [1, 2, 3, 1, 2, 3, 1] + where + runTest = runEff . runConcurrent . runConc . runChan . execWriter + + +testWithYieldToList :: Spec +testWithYieldToList = do + it "passes the collected yields to the returned function" do + let result = runPureEff $ Yield.withYieldToList @Int do + Yield.yield 1 + Yield.yield 2 + Yield.yield 3 + pure length + result `shouldBe` 3 + + it "passes yields in order to the function" do + let result = runPureEff $ Yield.withYieldToList @Int do + Yield.yield 1 + Yield.yield 2 + Yield.yield 3 + pure id + result `shouldBe` [1, 2, 3] + + it "passes an empty list when nothing is yielded" do + let result = runPureEff $ Yield.withYieldToList @Int do + pure null + result `shouldBe` True + + +testEnumerate :: Spec +testEnumerate = do + it "pairs each value with its zero-based index" do + let ((), xs) = runPureEff $ Yield.yieldToList $ Yield.enumerate do + Yield.yield 'a' + Yield.yield 'b' + Yield.yield 'c' + xs `shouldBe` [(0, 'a'), (1, 'b'), (2, 'c')] + + +testEnumerateFrom :: Spec +testEnumerateFrom = do + it "pairs each value with its index starting from the given value" do + let ((), xs) = runPureEff $ Yield.yieldToList $ Yield.enumerateFrom 5 do + Yield.yield 'x' + Yield.yield 'y' + xs `shouldBe` [(5, 'x'), (6, 'y')] + + +testMap :: Spec +testMap = do + it "transforms each yielded value" do + let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.map @Int (* 2) do + Yield.yield 1 + Yield.yield 2 + Yield.yield 3 + xs `shouldBe` [2, 4, 6] + + it "preserves order" do + let (_, xs :: [Text]) = runPureEff $ Yield.yieldToList $ Yield.map show do + Yield.yield @Int 1 + Yield.yield 2 + xs `shouldBe` ["1", "2"] + + +testMapMaybe :: Spec +testMapMaybe = do + describe "when the function returns Just" $ it "yields transformed values" do + let ((), xs) = runPureEff $ Yield.yieldToList $ Yield.mapMaybe (\x -> if even x then Just (x * 10) else Nothing) do + Yield.yield @Int 1 + Yield.yield 2 + Yield.yield 3 + Yield.yield 4 + xs `shouldMatchList` [20, 40] + + describe "when the function always returns Nothing" $ it "yields nothing" do + let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.mapMaybe @Int @Int (const Nothing) do + Yield.yield 1 + xs `shouldMatchList` [] + + +testCatMaybes :: Spec +testCatMaybes = do + it "unwraps Just values and drops Nothings" do + let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.catMaybes do + Yield.yield (Just 1) + Yield.yield Nothing + Yield.yield (Just 2) + xs `shouldBe` [1 :: Int, 2] + + it "yields nothing when all values are Nothing" do + let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.catMaybes do + Yield.yield (Nothing :: Maybe Int) + Yield.yield Nothing + xs `shouldBe` [] + + +testFilter :: Spec +testFilter = do + it "passes values satisfying the predicate" do + let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.filter even do + Yield.yield 1 + Yield.yield 2 + Yield.yield 3 + Yield.yield 4 + xs `shouldBe` [2 :: Int, 4] + + it "drops all values when predicate is always false" do + let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.filter (const False) do + Yield.yield (1 :: Int) + xs `shouldBe` [] + + it "passes all values when predicate is always true" do + let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.filter (const True) do + Yield.yield 1 + Yield.yield 2 + xs `shouldBe` [1 :: Int, 2] + + +testChanges :: Spec +testChanges = do + it "suppresses yields equal to the initial value" do + let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.changes 0 do + Yield.yield 0 + Yield.yield 1 + xs `shouldBe` [1 :: Int] + + it "passes values that differ from the initial value" do + let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.changes 0 do + Yield.yield 1 + Yield.yield 2 + xs `shouldBe` [1 :: Int, 2] + + it "suppresses initial value interspersed with other values" do + let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.changes 0 do + Yield.yield 0 + Yield.yield 1 + Yield.yield 0 + Yield.yield 2 + Yield.yield 0 + Yield.yield 3 + xs `shouldBe` [1 :: Int, 2, 3] + + it "does not suppress non-initial values even if they repeat" do + let (_, xs) = runPureEff $ Yield.yieldToList $ Yield.changes 0 do + Yield.yield 1 + Yield.yield 1 + Yield.yield 2 + xs `shouldBe` [1 :: Int, 1, 2] diff --git a/test/Unit/Atelier/Types/Semaphore/STMSpec.hs b/test/Unit/Atelier/Types/Semaphore/STMSpec.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Atelier/Types/Semaphore/STMSpec.hs @@ -0,0 +1,126 @@ +module Unit.Atelier.Types.Semaphore.STMSpec (spec_Semaphore_STM) where + +import Effectful (runEff) +import Effectful.Concurrent (runConcurrent) +import Effectful.Concurrent.STM (atomically) +import Effectful.State.Static.Shared (evalState, get, put) +import Test.Hspec (Spec, describe, it, shouldBe) + +import Data.IORef qualified as IORef + +import Atelier.Effects.Conc qualified as Conc +import Atelier.Types.Semaphore.STM qualified as Sem + + +spec_Semaphore_STM :: Spec +spec_Semaphore_STM = do + describe "wait" $ it "should halt the computation" do + runEff . runConcurrent . Conc.runConc . evalState @Int 0 $ do + sem <- atomically Sem.new + + thread <- Conc.fork do + atomically $ Sem.wait sem + put 1 + + a1 <- get + liftIO $ a1 `shouldBe` 0 + + atomically $ Sem.signal sem + + Conc.await thread + + a2 <- get + liftIO $ a2 `shouldBe` 1 + + describe "signal" do + it "sets the semaphore" do + result <- runEff . runConcurrent . atomically $ do + sem <- Sem.new + Sem.signal sem + Sem.peek sem + result `shouldBe` True + + describe "clear" do + describe "when the semaphore was set" $ it "returns True" do + result <- runEff . runConcurrent . atomically $ do + sem <- Sem.newSet + Sem.unset sem + result `shouldBe` True + + describe "when the semaphore was not set" $ it "returns False" do + result <- runEff . runConcurrent . atomically $ do + sem <- Sem.new + Sem.unset sem + result `shouldBe` False + + it "leaves the semaphore clear" do + result <- runEff . runConcurrent . atomically $ do + sem <- Sem.newSet + _ <- Sem.unset sem + Sem.peek sem + result `shouldBe` False + + describe "reset" do + describe "when the semaphore was not set" $ it "returns True" do + result <- runEff . runConcurrent . atomically $ do + sem <- Sem.new + Sem.set sem + result `shouldBe` True + + describe "when the semaphore was already set" $ it "returns False" do + result <- runEff . runConcurrent . atomically $ do + sem <- Sem.newSet + Sem.set sem + result `shouldBe` False + + it "leaves the semaphore set" do + result <- runEff . runConcurrent . atomically $ do + sem <- Sem.new + _ <- Sem.set sem + Sem.peek sem + result `shouldBe` True + + describe "peek" do + describe "when the semaphore is set" $ it "returns True" do + result <- runEff . runConcurrent . atomically $ do + sem <- Sem.newSet + Sem.peek sem + result `shouldBe` True + + describe "when the semaphore is not set" $ it "returns False" do + result <- runEff . runConcurrent . atomically $ do + sem <- Sem.new + Sem.peek sem + result `shouldBe` False + + it "does not change the state of the semaphore" do + (before, after) <- runEff . runConcurrent . atomically $ do + sem <- Sem.newSet + before <- Sem.peek sem + after <- Sem.peek sem + pure (before, after) + (before, after) `shouldBe` (True, True) + + describe "withSemaphore" do + it "returns the result of the enclosed computation" do + result <- runEff . runConcurrent $ do + sem <- atomically Sem.newSet + Sem.withSemaphore sem $ pure (42 :: Int) + result `shouldBe` 42 + + it "signals the semaphore after the computation" do + result <- runEff . runConcurrent $ do + sem <- atomically Sem.newSet + Sem.withSemaphore sem $ pure () + atomically $ Sem.peek sem + result `shouldBe` True + + it "waits for the semaphore before running" do + result <- runEff . runConcurrent . Conc.runConc $ do + sem <- atomically Sem.new + ref <- liftIO $ IORef.newIORef False + _ <- Conc.fork $ do + liftIO $ IORef.writeIORef ref True + atomically $ Sem.signal sem + Sem.withSemaphore sem $ liftIO $ IORef.readIORef ref + result `shouldBe` True diff --git a/test/Unit/Atelier/Types/SemaphoreSpec.hs b/test/Unit/Atelier/Types/SemaphoreSpec.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Atelier/Types/SemaphoreSpec.hs @@ -0,0 +1,125 @@ +module Unit.Atelier.Types.SemaphoreSpec (spec_Semaphore) where + +import Effectful (runEff) +import Effectful.Concurrent (runConcurrent) +import Effectful.State.Static.Shared (evalState, get, put) +import Test.Hspec (Spec, describe, it, shouldBe) + +import Data.IORef qualified as IORef + +import Atelier.Effects.Conc qualified as Conc +import Atelier.Types.Semaphore qualified as Sem + + +spec_Semaphore :: Spec +spec_Semaphore = do + describe "wait" $ it "should halt the computation" do + runEff . runConcurrent . Conc.runConc . evalState @Int 0 $ do + sem <- Sem.new + + thread <- Conc.fork do + Sem.wait sem + put 1 + + a1 <- get + liftIO $ a1 `shouldBe` 0 + + Sem.signal sem + + Conc.await thread + + a2 <- get + liftIO $ a2 `shouldBe` 1 + + describe "signal" do + it "sets the semaphore" do + result <- runEff . runConcurrent $ do + sem <- Sem.new + Sem.signal sem + Sem.peek sem + result `shouldBe` True + + describe "clear" do + describe "when the semaphore was set" $ it "returns True" do + result <- runEff . runConcurrent $ do + sem <- Sem.newSet + Sem.unset sem + result `shouldBe` True + + describe "when the semaphore was not set" $ it "returns False" do + result <- runEff . runConcurrent $ do + sem <- Sem.new + Sem.unset sem + result `shouldBe` False + + it "leaves the semaphore clear" do + result <- runEff . runConcurrent $ do + sem <- Sem.newSet + _ <- Sem.unset sem + Sem.peek sem + result `shouldBe` False + + describe "reset" do + describe "when the semaphore was not set" $ it "returns True" do + result <- runEff . runConcurrent $ do + sem <- Sem.new + Sem.set sem + result `shouldBe` True + + describe "when the semaphore was already set" $ it "returns False" do + result <- runEff . runConcurrent $ do + sem <- Sem.newSet + Sem.set sem + result `shouldBe` False + + it "leaves the semaphore set" do + result <- runEff . runConcurrent $ do + sem <- Sem.new + _ <- Sem.set sem + Sem.peek sem + result `shouldBe` True + + describe "peek" do + describe "when the semaphore is set" $ it "returns True" do + result <- runEff . runConcurrent $ do + sem <- Sem.newSet + Sem.peek sem + result `shouldBe` True + + describe "when the semaphore is not set" $ it "returns False" do + result <- runEff . runConcurrent $ do + sem <- Sem.new + Sem.peek sem + result `shouldBe` False + + it "does not change the state of the semaphore" do + (before, after) <- runEff . runConcurrent $ do + sem <- Sem.newSet + before <- Sem.peek sem + after <- Sem.peek sem + pure (before, after) + (before, after) `shouldBe` (True, True) + + describe "withSemaphore" do + it "returns the result of the enclosed computation" do + result <- runEff . runConcurrent $ do + sem <- Sem.newSet + Sem.withSemaphore sem $ pure (42 :: Int) + result `shouldBe` 42 + + it "signals the semaphore after the computation" do + result <- runEff . runConcurrent $ do + sem <- Sem.newSet + Sem.withSemaphore sem $ pure () + Sem.peek sem + result `shouldBe` True + + it "waits for the semaphore before running" do + result <- runEff . runConcurrent . Conc.runConc $ do + sem <- Sem.new + ref <- liftIO $ IORef.newIORef False + _ <- Conc.fork $ do + liftIO $ IORef.writeIORef ref True + Sem.signal sem + Sem.withSemaphore sem $ liftIO $ IORef.readIORef ref + result `shouldBe` True diff --git a/test/Unit/Atelier/Types/WithDefaultsSpec.hs b/test/Unit/Atelier/Types/WithDefaultsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Unit/Atelier/Types/WithDefaultsSpec.hs @@ -0,0 +1,63 @@ +module Unit.Atelier.Types.WithDefaultsSpec (spec_WithDefaults) where + +import Data.Aeson (FromJSON, ToJSON, eitherDecode) +import Data.Default (Default (..)) +import Test.Hspec + +import Data.ByteString.Lazy qualified as LBS + +import Atelier.Types.QuietSnake (QuietSnake (..)) +import Atelier.Types.WithDefaults (WithDefaults (..)) + + +-- | A minimal fixture type with non-Maybe list fields to exercise WithDefaults. +data Fixture = Fixture + { requiredField :: Text + , items :: [Text] + , count :: Int + } + deriving stock (Eq, Generic, Show) + deriving (FromJSON, ToJSON) via QuietSnake Fixture + + +instance Default Fixture where + def = + Fixture + { requiredField = "default-value" + , items = ["default-item"] + , count = 0 + } + + +decodeWithDefaults :: LBS.ByteString -> Either String Fixture +decodeWithDefaults bs = getQuietSnake . getWithDefaults <$> eitherDecode @(WithDefaults (QuietSnake Fixture)) bs + + +spec_WithDefaults :: Spec +spec_WithDefaults = do + describe "WithDefaults" do + it "falls back to Default values for missing non-Maybe fields" do + let result = decodeWithDefaults "{}" + result `shouldBe` Right def + + it "uses provided values when all fields are present" do + let result = + decodeWithDefaults + "{\"required_field\": \"hello\", \"items\": [\"a\", \"b\"], \"count\": 42}" + result + `shouldBe` Right + Fixture + { requiredField = "hello" + , items = ["a", "b"] + , count = 42 + } + + it "partial object: provided fields override defaults, missing fall back" do + let result = decodeWithDefaults "{\"count\": 7}" + result + `shouldBe` Right + def {count = 7} + + it "explicitly provided empty list overrides the default list" do + let result = decodeWithDefaults "{\"items\": []}" + result `shouldBe` Right def {items = []}