acolyte-server (empty) → 0.1.0.0

raw patch · 21 files changed

+5728/−0 lines, 21 filesdep +acolyte-coredep +acolyte-serverdep +aeson

Dependencies added: acolyte-core, acolyte-server, aeson, base, bytestring, case-insensitive, containers, directory, hedgehog, http-core, http-types, process, spire, text

Files

• CHANGELOG.md +8/−0
• LICENSE +27/−0
• acolyte-server.cabal +154/−0
• src/Acolyte/Server.hs +168/−0
• src/Acolyte/Server/Combine.hs +199/−0
• src/Acolyte/Server/CombineEffects.hs +58/−0
• src/Acolyte/Server/Effects.hs +122/−0
• src/Acolyte/Server/Extract.hs +907/−0
• src/Acolyte/Server/Handler.hs +265/−0
• src/Acolyte/Server/MkApi.hs +314/−0
• src/Acolyte/Server/Named.hs +196/−0
• src/Acolyte/Server/Negotiate.hs +201/−0
• src/Acolyte/Server/Response.hs +118/−0
• src/Acolyte/Server/Router.hs +161/−0
• src/Acolyte/Server/Streaming.hs +175/−0
• src/Acolyte/Server/ToHandler.hs +70/−0
• src/Acolyte/Server/Validate.hs +83/−0
• src/Acolyte/Server/Wiring.hs +375/−0
• test/Main.hs +1782/−0
• test/Properties.hs +259/−0
• test/TypeErrors.hs +86/−0

@@ -0,0 +1,8 @@+# Revision history for acolyte-server++## 0.1.0.0 -- 2026-04-27++* Initial release. Interprets acolyte-core API types into a running+  HTTP server: handler binding, request extraction, response+  encoding, routing, and the compile-time completeness check.+  Produces a backend-agnostic spire Service.

@@ -0,0 +1,27 @@+Copyright (c) 2024-2026, Josh Burgess++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice,+   this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+   this list of conditions and the following disclaimer in the documentation+   and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its+   contributors may be used to endorse or promote products derived from this+   software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,154 @@+cabal-version:   3.0+name:            acolyte-server+version:         0.1.0.0+synopsis:        HTTP server interpretation for acolyte+category:        Web+description:+  Interprets acolyte-core API types into a running HTTP+  server. Provides handler binding, request extraction, response+  encoding, routing, and the compile-time completeness check.+  .+  Produces a spire Service. Backend-agnostic: combine with spire-wai+  to run on warp, or any other adapter.++license:         BSD-3-Clause+license-file:    LICENSE+author:          Josh Burgess+maintainer:      Josh Burgess <joshburgess.webdev@gmail.com>+homepage:        https://github.com/joshburgess/acolyte+bug-reports:     https://github.com/joshburgess/acolyte/issues+build-type:      Simple++extra-doc-files:+  CHANGELOG.md++flag dev-tests+  description:+    Build dev-only test suites that shell out to @cabal exec ghc@.+    These rely on the in-place package database from @cabal build@+    in the source workspace and cannot run from an installed+    package, so they are off by default.+  default: False+  manual: True++library+  exposed-modules:+    Acolyte.Server+    Acolyte.Server.Extract+    Acolyte.Server.Response+    Acolyte.Server.Handler+    Acolyte.Server.Router+    Acolyte.Server.Wiring+    Acolyte.Server.Effects+    Acolyte.Server.Combine+    Acolyte.Server.CombineEffects+    Acolyte.Server.Validate+    Acolyte.Server.ToHandler+    Acolyte.Server.MkApi+    Acolyte.Server.Negotiate+    Acolyte.Server.Named+    Acolyte.Server.Streaming++  build-depends:+      base                    >= 4.20 && < 5+    , acolyte-core            >= 0.1  && < 0.2+    , spire                   >= 0.1  && < 0.2+    , http-core               >= 0.1  && < 0.2+    , aeson                   >= 2.1  && < 2.3+    , bytestring              >= 0.11 && < 0.13+    , text                    >= 2.0  && < 2.2+    , http-types              >= 0.12 && < 0.13+    , containers              >= 0.6  && < 0.8+    , case-insensitive        >= 1.2  && < 1.3++  hs-source-dirs: src+  default-language: GHC2024+  default-extensions:+    DataKinds+    GADTs+    TypeFamilies+    TypeOperators+    OverloadedStrings+    AllowAmbiguousTypes+    UndecidableInstances+    ConstraintKinds+    StandaloneKindSignatures+    MultiParamTypeClasses+    FunctionalDependencies+    FlexibleInstances+    FlexibleContexts+    ScopedTypeVariables+    StrictData++  ghc-options: -Wall -funbox-strict-fields++test-suite spec+  type: exitcode-stdio-1.0+  main-is: Main.hs+  hs-source-dirs: test+  default-language: GHC2024+  default-extensions:+    DataKinds+    GADTs+    TypeFamilies+    TypeOperators+    OverloadedStrings+    AllowAmbiguousTypes+    UndecidableInstances+    ConstraintKinds+    ScopedTypeVariables+    StrictData++  ghc-options: -Wall -rtsopts "-with-rtsopts=-K1K"++  build-depends:+      base                    >= 4.20 && < 5+    , acolyte-server          >= 0.1  && < 0.2+    , acolyte-core            >= 0.1  && < 0.2+    , spire                   >= 0.1  && < 0.2+    , http-core               >= 0.1  && < 0.2+    , aeson                   >= 2.1  && < 2.3+    , bytestring              >= 0.11 && < 0.13+    , text                    >= 2.0  && < 2.2+    , http-types              >= 0.12 && < 0.13+    , case-insensitive        >= 1.2  && < 1.3++test-suite properties+  type: exitcode-stdio-1.0+  main-is: Properties.hs+  hs-source-dirs: test+  default-language: GHC2024+  default-extensions:+    DataKinds+    OverloadedStrings+    StrictData+  ghc-options: -Wall+  build-depends:+      base                    >= 4.20 && < 5+    , acolyte-server          >= 0.1  && < 0.2+    , acolyte-core            >= 0.1  && < 0.2+    , http-core               >= 0.1  && < 0.2+    , hedgehog                >= 1.4  && < 1.8+    , aeson                   >= 2.1  && < 2.3+    , bytestring              >= 0.11 && < 0.13+    , text                    >= 2.0  && < 2.2+    , http-types              >= 0.12 && < 0.13++test-suite typeerrors+  type: exitcode-stdio-1.0+  main-is: TypeErrors.hs+  hs-source-dirs: test+  default-language: GHC2024+  ghc-options: -Wall++  if !flag(dev-tests)+    buildable: False++  build-depends:+      base                    >= 4.20 && < 5+    , process                 >= 1.6  && < 1.8+    , directory               >= 1.3  && < 1.4++source-repository head+  type:     git+  location: https://github.com/joshburgess/acolyte.git

@@ -0,0 +1,168 @@+-- | @acolyte-server@ — HTTP server interpretation.+--+-- Interprets acolyte-core API types into a spire Service.+-- Combine with spire-wai to run on warp.+--+-- @+-- import Acolyte.Core+-- import Acolyte.Server+-- import Spire.Wai (runWarp)+--+-- type API = '[ Get '[ Lit "hello" ] Text ]+--+-- main :: IO ()+-- main = do+--   let svc = serve router+--   runWarp 3000 svc+-- @+module Acolyte.Server+  ( -- * Extractors+    FromRequestParts (..)+  , FromRequest (..)+  , PathCapture (..)+  , JsonBody (..)+  , ValidatedBody (..)+  , AppState (..)+  , RawBody (..)+  , ReqHeader (..)+  , Extension (..)+  , Optional (..)+  , ReqMethod (..)+  , QueryParam (..)+  , QueryParams (..)+  , OptionalParam (..)+  , HeaderMap (..)+  , BodyBytes (..)+  , StringBody (..)+  , Form (..)+  , FromForm (..)+  , RawForm (..)+  , Multipart (..)+  , FilePart (..)+  , parseFormUrlEncoded+  , parseMultipart+  , FullRequest (..)+  , RawQuery (..)+  , OriginalUri (..)+  , MatchedPath (..)+  , NestedPath (..)+  , ConnectInfo (..)+  , RawPathParams (..)+  , ParseCapture (..)+  , ServerError (..)+  , mkError++    -- * Responses+  , IntoResponse (..)+  , Json (..)+  , JsonError (..)+  , jsonError++    -- * Handler binding+  , BoundHandler (..)+  , HandlerFn+  , MatchResult (..)+  , HasEndpointInfo (..)+  , ReflectPath (..)+  , mkHandler0+  , mkHandler1Parts+  , mkHandler1Body+  , mkHandler2PartsBody++    -- * Ergonomic handler conversion+  , ToHandler (..)++    -- * Router (low-level)+  , Router+  , emptyRouter+  , addRoute+  , dispatch+  , serve+  , serveWithState+  , CaptureList (..)+  , injectCaptures++    -- * Automatic wiring (high-level)+  , mkServer+  , mkServerWith+  , WrappedHandler (..)+  , wrapHandler+  , handle+  , BuildServer (..)+  , BuildHandlers (..)++    -- * Ergonomic server construction (no wrapHandler needed)+  , mkApi+  , BuildApi (..)+  , toBoundHandler++    -- * Effectful server (typed middleware tracking)+  , EffectfulServer (..)+  , effectfulServer+  , effectfulApi+  , fromRouter+  , provide+  , run++    -- * Sub-API composition (for APIs > 25 endpoints)+  , combineServer2+  , combineServer3+  , combineServer4+  , combineServer5+  , combineServer6+  , combineServer7+  , combineServer8+  , subRouter++    -- * Combined effectful server (backward-compatible aliases)+  , CombinedServer+  , combinedFromRouter+  , provideEffect+  , runCombined++    -- * Named routes (record-based handler registration)+  , NamedApi (..)+  , mkNamedApi+  , effectfulNamedApi+    -- * Automatic record-based handler binding (requires Named wrappers)+  , BuildRecordApi (..)+  , mkRecordApi+  , effectfulRecordApi++    -- * Content negotiation+  , FormatEncoder (..)+  , NegotiatedResponse (..)+  , negotiate+  , parseAccept+  , matchFormat++    -- * Runtime validation+  , validationLayer+  , BuildRouteTable (..)++    -- * Streaming support+  , SSEvent (..)+  , sseEvent+  , sseData+  , ServerStreamHandler+  , ClientStreamHandler+  , BidiStreamHandler+  , sseResponse+  , sseResponseSync+  , sseChunk+  ) where++import Acolyte.Server.Extract+import Acolyte.Server.Response+import Acolyte.Server.Handler+import Acolyte.Server.Router+import Acolyte.Server.Wiring+import Acolyte.Server.Effects+import Acolyte.Server.Combine+import Acolyte.Server.CombineEffects+import Acolyte.Server.Validate+import Acolyte.Server.ToHandler+import Acolyte.Server.MkApi+import Acolyte.Server.Named+import Acolyte.Server.Negotiate+import Acolyte.Server.Streaming

@@ -0,0 +1,199 @@+-- | Sub-API composition: combine multiple smaller APIs into one server.+--+-- Each sub-API uses flat tuple instances (O(1) compile time). The+-- combined server merges all routes and preserves compile-time+-- completeness checking across all sub-APIs.+--+-- @+-- type UsersAPI    = '[Get UsersPath ..., Post UsersPath ...]+-- type ArticlesAPI = '[Get ArticlesPath ..., Delete ArticlePath ...]+--+-- -- Combined type for OpenAPI / client generation+-- type FullAPI = UsersAPI ++ ArticlesAPI+--+-- -- Build server with completeness check for BOTH sub-APIs+-- server = combineServer2 @UsersAPI @ArticlesAPI+--   usersHandlers+--   articleHandlers+-- @+module Acolyte.Server.Combine+  ( -- * Combining 2 sub-APIs+    combineServer2+    -- * Combining 3 sub-APIs+  , combineServer3+    -- * Combining 4 sub-APIs+  , combineServer4+    -- * Combining 5 sub-APIs+  , combineServer5+    -- * Combining 6 sub-APIs+  , combineServer6+    -- * Combining 7 sub-APIs+  , combineServer7+    -- * Combining 8 sub-APIs+  , combineServer8+    -- * Low-level: build sub-API router and merge+  , subRouter+  ) where++import Data.ByteString (ByteString)+import Data.Kind (Type)++import Spire.Service (Service)+import Http.Core (Request, Response)++import Acolyte.Core.API (Serves, type (++))+import Acolyte.Server.Handler (HasEndpointInfo)+import Acolyte.Server.Router (Router, emptyRouter, serve)+import Acolyte.Server.Wiring (BuildServer, buildRouter)+++-- | Build a router for a sub-API and merge into an existing router.+--+-- This is the building block. Each call is O(1) (flat tuple instance).+subRouter+  :: forall api handlers+   . (Serves api handlers, BuildServer api handlers)+  => handlers+  -> Router+  -> Router+subRouter handlers = buildRouter @api handlers+++-- | Combine 2 sub-APIs with compile-time completeness for both.+combineServer2+  :: forall api1 api2 h1 h2+   . ( Serves api1 h1, BuildServer api1 h1+     , Serves api2 h2, BuildServer api2 h2+     )+  => h1 -> h2+  -> Service IO (Request ByteString) (Response ByteString)+combineServer2 h1 h2 = serve+  $ subRouter @api2 h2+  $ subRouter @api1 h1+  $ emptyRouter+++-- | Combine 3 sub-APIs.+combineServer3+  :: forall api1 api2 api3 h1 h2 h3+   . ( Serves api1 h1, BuildServer api1 h1+     , Serves api2 h2, BuildServer api2 h2+     , Serves api3 h3, BuildServer api3 h3+     )+  => h1 -> h2 -> h3+  -> Service IO (Request ByteString) (Response ByteString)+combineServer3 h1 h2 h3 = serve+  $ subRouter @api3 h3+  $ subRouter @api2 h2+  $ subRouter @api1 h1+  $ emptyRouter+++-- | Combine 4 sub-APIs.+combineServer4+  :: forall api1 api2 api3 api4 h1 h2 h3 h4+   . ( Serves api1 h1, BuildServer api1 h1+     , Serves api2 h2, BuildServer api2 h2+     , Serves api3 h3, BuildServer api3 h3+     , Serves api4 h4, BuildServer api4 h4+     )+  => h1 -> h2 -> h3 -> h4+  -> Service IO (Request ByteString) (Response ByteString)+combineServer4 h1 h2 h3 h4 = serve+  $ subRouter @api4 h4+  $ subRouter @api3 h3+  $ subRouter @api2 h2+  $ subRouter @api1 h1+  $ emptyRouter+++-- | Combine 5 sub-APIs.+combineServer5+  :: forall api1 api2 api3 api4 api5 h1 h2 h3 h4 h5+   . ( Serves api1 h1, BuildServer api1 h1+     , Serves api2 h2, BuildServer api2 h2+     , Serves api3 h3, BuildServer api3 h3+     , Serves api4 h4, BuildServer api4 h4+     , Serves api5 h5, BuildServer api5 h5+     )+  => h1 -> h2 -> h3 -> h4 -> h5+  -> Service IO (Request ByteString) (Response ByteString)+combineServer5 h1 h2 h3 h4 h5 = serve+  $ subRouter @api5 h5+  $ subRouter @api4 h4+  $ subRouter @api3 h3+  $ subRouter @api2 h2+  $ subRouter @api1 h1+  $ emptyRouter+++-- | Combine 6 sub-APIs.+combineServer6+  :: forall api1 api2 api3 api4 api5 api6 h1 h2 h3 h4 h5 h6+   . ( Serves api1 h1, BuildServer api1 h1+     , Serves api2 h2, BuildServer api2 h2+     , Serves api3 h3, BuildServer api3 h3+     , Serves api4 h4, BuildServer api4 h4+     , Serves api5 h5, BuildServer api5 h5+     , Serves api6 h6, BuildServer api6 h6+     )+  => h1 -> h2 -> h3 -> h4 -> h5 -> h6+  -> Service IO (Request ByteString) (Response ByteString)+combineServer6 h1 h2 h3 h4 h5 h6 = serve+  $ subRouter @api6 h6+  $ subRouter @api5 h5+  $ subRouter @api4 h4+  $ subRouter @api3 h3+  $ subRouter @api2 h2+  $ subRouter @api1 h1+  $ emptyRouter+++-- | Combine 7 sub-APIs.+combineServer7+  :: forall api1 api2 api3 api4 api5 api6 api7 h1 h2 h3 h4 h5 h6 h7+   . ( Serves api1 h1, BuildServer api1 h1+     , Serves api2 h2, BuildServer api2 h2+     , Serves api3 h3, BuildServer api3 h3+     , Serves api4 h4, BuildServer api4 h4+     , Serves api5 h5, BuildServer api5 h5+     , Serves api6 h6, BuildServer api6 h6+     , Serves api7 h7, BuildServer api7 h7+     )+  => h1 -> h2 -> h3 -> h4 -> h5 -> h6 -> h7+  -> Service IO (Request ByteString) (Response ByteString)+combineServer7 h1 h2 h3 h4 h5 h6 h7 = serve+  $ subRouter @api7 h7+  $ subRouter @api6 h6+  $ subRouter @api5 h5+  $ subRouter @api4 h4+  $ subRouter @api3 h3+  $ subRouter @api2 h2+  $ subRouter @api1 h1+  $ emptyRouter+++-- | Combine 8 sub-APIs.+combineServer8+  :: forall api1 api2 api3 api4 api5 api6 api7 api8 h1 h2 h3 h4 h5 h6 h7 h8+   . ( Serves api1 h1, BuildServer api1 h1+     , Serves api2 h2, BuildServer api2 h2+     , Serves api3 h3, BuildServer api3 h3+     , Serves api4 h4, BuildServer api4 h4+     , Serves api5 h5, BuildServer api5 h5+     , Serves api6 h6, BuildServer api6 h6+     , Serves api7 h7, BuildServer api7 h7+     , Serves api8 h8, BuildServer api8 h8+     )+  => h1 -> h2 -> h3 -> h4 -> h5 -> h6 -> h7 -> h8+  -> Service IO (Request ByteString) (Response ByteString)+combineServer8 h1 h2 h3 h4 h5 h6 h7 h8 = serve+  $ subRouter @api8 h8+  $ subRouter @api7 h7+  $ subRouter @api6 h6+  $ subRouter @api5 h5+  $ subRouter @api4 h4+  $ subRouter @api3 h3+  $ subRouter @api2 h2+  $ subRouter @api1 h1+  $ emptyRouter

@@ -0,0 +1,58 @@+-- | Backward-compatible aliases for combined effect-tracked servers.+--+-- 'CombinedServer' is now a type alias for 'EffectfulServer'.+-- 'provideEffect' and 'runCombined' are aliases for 'provide' and 'run'.+-- 'combinedFromRouter' is an alias for 'fromRouter'.+--+-- New code should use 'EffectfulServer', 'provide', 'run', and+-- 'fromRouter' directly from "Acolyte.Server.Effects".+module Acolyte.Server.CombineEffects+  ( -- * Combined effectful server (aliases)+    CombinedServer+  , combinedFromRouter+    -- * Effect tracking (aliases)+  , provideEffect+  , runCombined+  ) where++import Data.ByteString (ByteString)+import Data.Kind (Type)++import Spire (Middleware)+import Http.Core (Request, Response)++import Acolyte.Core.Effect (AllEffectsProvided)+import Acolyte.Server.Router (Router)+import Acolyte.Server.Effects+  ( EffectfulServer, fromRouter, provide, run )+import Spire.Service (Service)+++-- | Alias for 'EffectfulServer'. Kept for backward compatibility.+type CombinedServer = EffectfulServer++-- | Alias for 'fromRouter'. Kept for backward compatibility.+combinedFromRouter+  :: forall fullApi+   . Router+  -> EffectfulServer fullApi '[]+combinedFromRouter = fromRouter+{-# INLINE combinedFromRouter #-}++-- | Alias for 'provide'. Kept for backward compatibility.+provideEffect+  :: forall e fullApi provided+   . Middleware IO (Request ByteString) (Response ByteString)+  -> EffectfulServer fullApi provided+  -> EffectfulServer fullApi (e ': provided)+provideEffect = provide @e+{-# INLINE provideEffect #-}++-- | Alias for 'run'. Kept for backward compatibility.+runCombined+  :: forall fullApi provided+   . AllEffectsProvided fullApi provided+  => EffectfulServer fullApi provided+  -> Service IO (Request ByteString) (Response ByteString)+runCombined = run+{-# INLINE runCombined #-}

@@ -0,0 +1,122 @@+-- | EffectfulServer: compile-time middleware effect tracking.+--+-- The builder pattern tracks which middleware effects have been+-- provided as a phantom type parameter. The 'run' method only+-- compiles when all effects declared in the API (via 'Requires')+-- have been discharged via 'provide'.+--+-- @+-- type API = '[ Requires Auth (Get UserPath (Json User))+--             , Requires Cors (Get PublicPath (Json Data))+--             , Get HealthPath String+--             ]+--+-- main = runWarp 3000+--   $ run+--   $ provide @Auth authMw+--   $ provide @Cors corsMw+--   $ effectfulServer @API handlers+-- @+module Acolyte.Server.Effects+  ( -- * Builder+    EffectfulServer (..)+  , effectfulServer+  , effectfulApi+  , fromRouter+    -- * Adding effects+  , provide+    -- * Finalizing+  , run+  ) where++import Data.Kind (Type)+import Data.ByteString (ByteString)++import Spire (Middleware, Service)+import Spire.Service (Service (..))+import Spire.Layer (applyLayer)+import Http.Core (Request, Response)++import Acolyte.Core.API (Serves)+import Acolyte.Core.Effect (AllEffectsProvided)+import Acolyte.Server.Wiring (BuildServer, mkServer)+import Acolyte.Server.MkApi (BuildApi, mkApi)+import Acolyte.Server.Router (Router, serve)+++-- | A server builder that tracks which effects have been provided.+--+-- @api@ is the API type (type-level list of endpoints).+-- @provided@ is the type-level list of effects discharged so far.+-- Starts as @'[]@ and grows with each 'provide' call.+--+-- Used for both single-API servers (via 'effectfulServer') and+-- combined multi-sub-API servers (via 'fromRouter').+data EffectfulServer (api :: [Type]) (provided :: [Type]) = EffectfulServer+  { esService :: !(Service IO (Request ByteString) (Response ByteString))+  }+++-- | Create an effectful server from an API type and handler tuple.+effectfulServer+  :: forall api handlers+   . (Serves api handlers, BuildServer api handlers)+  => handlers+  -> EffectfulServer api '[]+effectfulServer handlers = EffectfulServer (mkServer @api handlers)+++-- | Create an effectful server from an API type and plain handler functions.+--+-- Like 'effectfulServer' but uses 'mkApi' — no 'wrapHandler' or+-- 'toHandler' ceremony needed.+--+-- @+-- effectfulApi \@API (healthHandler, getUserHandler)+-- @+effectfulApi+  :: forall api handlers+   . (Serves api handlers, BuildApi api handlers)+  => handlers+  -> EffectfulServer api '[]+effectfulApi handlers = EffectfulServer (mkApi @api handlers)+++-- | Create an effectful server from a pre-built router.+--+-- Used with sub-API composition:+--+-- @+-- fromRouter @FullAPI+--   $ subRouter @API2 h2+--   $ subRouter @API1 h1+--   $ emptyRouter+-- @+fromRouter+  :: forall api+   . Router+  -> EffectfulServer api '[]+fromRouter router = EffectfulServer (serve router)+++-- | Provide a middleware that satisfies an effect requirement, applying it to the server.+--+-- Usage: @provide \@Auth authMiddleware@+provide+  :: forall e api provided+   . Middleware IO (Request ByteString) (Response ByteString)+  -> EffectfulServer api provided+  -> EffectfulServer api (e ': provided)+provide mw (EffectfulServer svc) =+  EffectfulServer (applyLayer mw svc)+++-- | Finalize the server into a spire Service.+--+-- Only compiles if every 'Requires' in the API has been provided.+run+  :: forall api provided+   . AllEffectsProvided api provided+  => EffectfulServer api provided+  -> Service IO (Request ByteString) (Response ByteString)+run (EffectfulServer svc) = svc

@@ -0,0 +1,907 @@+-- | Request extraction: turning raw requests into typed handler arguments.+--+-- Two extraction protocols mirror the typeway/axum pattern:+--+-- * 'FromRequestParts' — extracts from method, path, query, headers,+--   extensions (can be called multiple times per request)+-- * 'FromRequest' — extracts from the body (consumed once)+module Acolyte.Server.Extract+  ( -- * Extraction protocols+    FromRequestParts (..)+  , FromRequest (..)+    -- * Built-in extractors+  , PathCapture (..)+  , JsonBody (..)+  , ValidatedBody (..)+  , AppState (..)+  , RawBody (..)+  , ReqHeader (..)+  , Extension (..)+  , Optional (..)+  , ReqMethod (..)+    -- * Query parameter extractors+  , QueryParam (..)+  , QueryParams (..)+  , OptionalParam (..)+    -- * Header extractors+  , HeaderMap (..)+    -- * Body extractors+  , BodyBytes (..)+  , StringBody (..)+  , Form (..)+  , FromForm (..)+  , RawForm (..)+  , Multipart (..)+  , FilePart (..)+    -- * Form/Multipart parsing (internal, exported for testing)+  , parseFormUrlEncoded+  , parseMultipart+    -- * Request access+  , FullRequest (..)+  , RawQuery (..)+  , OriginalUri (..)+  , MatchedPath (..)+  , NestedPath (..)+  , ConnectInfo (..)+    -- * Capture support+  , CaptureList (..)+  , RawPathParams (..)+  , ParseCapture (..)+    -- * Server error+  , ServerError (..)+  , mkError+  ) where++import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.CaseInsensitive as CI+import Data.Kind (Type)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Text.Read as T+import Data.Typeable (Typeable)+import GHC.TypeLits (Symbol, KnownSymbol, symbolVal)+import Data.Proxy (Proxy (..))+import Network.HTTP.Types (Status, status400, status422, status500, urlDecode)++import qualified Data.Aeson as Aeson++import Http.Core (RequestParts (..), Extensions, lookupExtension, insertExtension)+import Acolyte.Core.Wrapper (Validate (..))+++-- | A structured server error with status and message.+data ServerError = ServerError+  { seStatus  :: !Status+  , seMessage :: !Text+  } deriving (Show)++-- | Construct a 'ServerError' from a status code and message.+mkError :: Status -> Text -> ServerError+mkError = ServerError+++-- | Extract a value from request data available via 'RequestParts'.+--+-- Originally designed for non-body extractions (path, query, headers,+-- extensions), but body types ('JsonBody', 'RawBody', 'StringBody',+-- 'Form', 'Multipart') also have instances — they read from+-- 'BodyBytes' stored in request extensions by the router. This means+-- 'FromRequestParts' is the universal extraction protocol used by+-- 'ToHandler' to peel handler arguments, regardless of whether the+-- data comes from the URL, headers, or body.+--+-- Can be called multiple times (nothing is consumed).+class FromRequestParts a where+  fromRequestParts :: RequestParts -> IO (Either ServerError a)+++-- | Extract a value from the request body (legacy protocol).+--+-- This is the original body extraction interface, taking the raw body+-- bytes as a parameter. It is used by the low-level 'HandlerFn' path+-- ('mkHandler1Body', 'mkHandler2PartsBody'). For ergonomic handlers+-- via 'ToHandler', body extraction goes through 'FromRequestParts'+-- instead (via 'BodyBytes' in extensions).+class FromRequest a where+  fromRequest :: RequestParts -> ByteString -> IO (Either ServerError a)+++-- ===================================================================+-- ParseCapture: text -> typed value parsing+-- ===================================================================++-- | Parse a text capture into a typed value.+class ParseCapture a where+  parseCapture :: Text -> Maybe a++instance ParseCapture Int where+  parseCapture t = case T.decimal t of+    Right (n, rest) | T.null rest -> Just n+    _ -> Nothing++instance ParseCapture Text where+  parseCapture = Just++instance ParseCapture String where+  parseCapture = Just . T.unpack+++-- ===================================================================+-- BodyBytes: raw body stored in Extensions by the router+-- ===================================================================++-- | Raw request body bytes, stored in Extensions by the router.+-- Enables body extractors to work through 'FromRequestParts'.+newtype BodyBytes = BodyBytes { unBodyBytes :: ByteString }+  deriving (Show, Eq, Typeable)+++-- ===================================================================+-- CaptureList: raw captures stored in Extensions by the router+-- ===================================================================++-- | Raw captured path segments stored in Extensions by the router.+newtype CaptureList = CaptureList { unCaptureList :: [Text] }+  deriving (Typeable)+++-- ===================================================================+-- PathCapture: extract typed captures from the URL path+-- ===================================================================++-- | A typed path capture extracted from the URL.+--+-- For a path like @'[Lit "users", Capture Int]@, use+-- @PathCapture Int@ in your handler to get the parsed value:+--+-- @+-- getUser :: PathCapture Int -> IO (Json User)+-- getUser (PathCapture uid) = ...+-- @+newtype PathCapture a = PathCapture { unPathCapture :: a }+  deriving (Show, Eq, Typeable)++instance (Typeable a, ParseCapture a) => FromRequestParts (PathCapture a) where+  fromRequestParts parts = do+    mCaps <- lookupExtension @CaptureList (rpExtensions parts)+    case mCaps of+      Just (CaptureList (t : rest)) ->+        case parseCapture @a t of+          Just val -> do+            -- Consume the capture: update CaptureList to remove the head+            insertExtension (CaptureList rest) (rpExtensions parts)+            pure $ Right (PathCapture val)+          Nothing  -> pure $ Left (mkError status400 "Invalid path capture")+      Just (CaptureList []) ->+        pure $ Left (mkError status400 "Missing path capture")+      Nothing ->+        pure $ Left (mkError status500 "CaptureList not found in extensions (router bug)")+++-- ===================================================================+-- JsonBody: parse JSON request body+-- ===================================================================++-- | A JSON-decoded request body.+--+-- Works as both a 'FromRequest' extractor (with the old HandlerFn API)+-- and a 'FromRequestParts' extractor (with ergonomic handlers via+-- 'ToHandler'), since the router stores body bytes in Extensions.+--+-- @+-- createUser :: JsonBody CreateUserReq -> IO (Json User)+-- createUser (JsonBody req) = ...+-- @+newtype JsonBody a = JsonBody { unJsonBody :: a }+  deriving (Show, Eq)++instance Aeson.FromJSON a => FromRequest (JsonBody a) where+  fromRequest _parts body =+    case Aeson.eitherDecodeStrict' body of+      Right val -> pure (Right (JsonBody val))+      Left err  -> pure (Left (mkError status422 (T.pack ("JSON parse error: " ++ err))))++instance Aeson.FromJSON a => FromRequestParts (JsonBody a) where+  fromRequestParts parts = do+    mBody <- lookupExtension @BodyBytes (rpExtensions parts)+    pure $ case mBody of+      Just (BodyBytes body) ->+        case Aeson.eitherDecodeStrict' body of+          Right val -> Right (JsonBody val)+          Left err  -> Left (mkError status422 (T.pack ("JSON parse error: " ++ err)))+      Nothing -> Left (mkError status500 "Request body not available (router bug)")+++-- ===================================================================+-- ValidatedBody: JSON body with validation+-- ===================================================================++-- | A JSON-deserialized request body that has been validated.+--+-- Uses the 'Validate' type class from core to run validation after+-- deserialization. Returns 422 if validation fails.+--+-- @+-- data CreateUserValidator+-- instance Validate CreateUserValidator CreateUser where+--   validate u+--     | T.null (userName u) = Left "name is required"+--     | otherwise           = Right u+--+-- handler :: ValidatedBody CreateUserValidator CreateUser -> IO (Json User)+-- handler (ValidatedBody user) = ...+-- @+newtype ValidatedBody v a = ValidatedBody { unValidatedBody :: a }+  deriving (Show, Eq)++instance (Aeson.FromJSON a, Validate v a) => FromRequest (ValidatedBody v a) where+  fromRequest _parts body =+    case Aeson.eitherDecodeStrict' body of+      Left err -> pure (Left (mkError status422 (T.pack ("JSON parse error: " ++ err))))+      Right a  -> case validate @v a of+        Left msg -> pure (Left (mkError status422 (T.pack msg)))+        Right a' -> pure (Right (ValidatedBody a'))++instance (Aeson.FromJSON a, Validate v a) => FromRequestParts (ValidatedBody v a) where+  fromRequestParts parts = do+    mBody <- lookupExtension @BodyBytes (rpExtensions parts)+    pure $ case mBody of+      Just (BodyBytes body) ->+        case Aeson.eitherDecodeStrict' body of+          Left err -> Left (mkError status422 (T.pack ("JSON parse error: " ++ err)))+          Right a  -> case validate @v a of+            Left msg -> Left (mkError status422 (T.pack msg))+            Right a' -> Right (ValidatedBody a')+      Nothing -> Left (mkError status500 "Request body not available (router bug)")+++-- ===================================================================+-- AppState: shared application state from Extensions+-- ===================================================================++-- | Shared application state injected via 'serveWithState'.+--+-- @+-- handler :: AppState DbPool -> PathCapture Int -> IO (Json User)+-- @+newtype AppState a = AppState { unAppState :: a }+  deriving (Show, Eq)++instance Typeable a => FromRequestParts (AppState a) where+  fromRequestParts parts = do+    mVal <- lookupExtension @(AppState a) (rpExtensions parts)+    pure $ case mVal of+      Just st -> Right st+      Nothing -> Left (mkError status500 "AppState not found in extensions (forgot serveWithState?)")+++-- ===================================================================+-- RawBody: raw request body bytes+-- ===================================================================++-- | The raw request body as a ByteString.+--+-- Works as both a 'FromRequest' and 'FromRequestParts' extractor.+--+-- @+-- handler :: RawBody -> IO (Response ByteString)+-- handler (RawBody bytes) = ...+-- @+newtype RawBody = RawBody { unRawBody :: ByteString }+  deriving (Show, Eq)++instance FromRequest RawBody where+  fromRequest _parts body = pure (Right (RawBody body))++instance FromRequestParts RawBody where+  fromRequestParts parts = do+    mBody <- lookupExtension @BodyBytes (rpExtensions parts)+    pure $ case mBody of+      Just (BodyBytes body) -> Right (RawBody body)+      Nothing -> Left (mkError status500 "Request body not available (router bug)")+++-- ===================================================================+-- ReqHeader: extract a specific header by type-level name+-- ===================================================================++-- | Extract a specific request header by its type-level name.+--+-- @+-- handler :: ReqHeader "Authorization" -> IO (Json User)+-- @+newtype ReqHeader (name :: Symbol) = ReqHeader { unReqHeader :: ByteString }+  deriving (Show, Eq)++instance KnownSymbol name => FromRequestParts (ReqHeader name) where+  fromRequestParts parts = do+    let headerName = CI.mk (TE.encodeUtf8 (T.pack (symbolVal (Proxy @name))))+    pure $ case lookup headerName (rpHeaders parts) of+      Just val -> Right (ReqHeader val)+      Nothing  -> Left (mkError status400+        (T.pack ("Missing required header: " ++ symbolVal (Proxy @name))))+++-- ===================================================================+-- QueryParam: extract a required query parameter+-- ===================================================================++-- | Extract a required, typed query parameter.+--+-- @+-- handler :: QueryParam "page" Int -> IO (Json [Item])+-- handler (QueryParam page) = ...+-- @+--+-- Returns 400 if the parameter is missing or unparseable.+newtype QueryParam (name :: Symbol) a = QueryParam { unQueryParam :: a }+  deriving (Show, Eq)++instance (KnownSymbol name, ParseCapture a) => FromRequestParts (QueryParam name a) where+  fromRequestParts parts = do+    let name = TE.encodeUtf8 (T.pack (symbolVal (Proxy @name)))+    pure $ case lookup name (rpQuery parts) of+      Just (Just val) ->+        case parseCapture @a (TE.decodeUtf8Lenient val) of+          Just v  -> Right (QueryParam v)+          Nothing -> Left (mkError status400+            ("Invalid query parameter: " <> T.pack (symbolVal (Proxy @name))))+      _ -> Left (mkError status400+        ("Missing required query parameter: " <> T.pack (symbolVal (Proxy @name))))+++-- ===================================================================+-- QueryParams: extract all values for a repeated query parameter+-- ===================================================================++-- | Extract all values for a repeated query parameter.+--+-- @+-- -- /search?tag=haskell&tag=web+-- handler :: QueryParams "tag" Text -> IO (Json [Article])+-- handler (QueryParams tags) = ...+-- @+--+-- Returns an empty list if the parameter is not present.+newtype QueryParams (name :: Symbol) a = QueryParams { unQueryParams :: [a] }+  deriving (Show, Eq)++instance (KnownSymbol name, ParseCapture a) => FromRequestParts (QueryParams name a) where+  fromRequestParts parts = do+    let name = TE.encodeUtf8 (T.pack (symbolVal (Proxy @name)))+        vals = [ v | (k, Just raw) <- rpQuery parts+                   , k == name+                   , Just v <- [parseCapture @a (TE.decodeUtf8Lenient raw)]+               ]+    pure (Right (QueryParams vals))+++-- ===================================================================+-- OptionalParam: extract an optional query parameter+-- ===================================================================++-- | Extract an optional, typed query parameter.+--+-- @+-- handler :: OptionalParam "limit" Int -> IO (Json [Item])+-- handler (OptionalParam mLimit) = do+--   let limit = fromMaybe 20 mLimit+--   ...+-- @+newtype OptionalParam (name :: Symbol) a = OptionalParam { unOptionalParam :: Maybe a }+  deriving (Show, Eq)++instance (KnownSymbol name, ParseCapture a) => FromRequestParts (OptionalParam name a) where+  fromRequestParts parts = do+    let name = TE.encodeUtf8 (T.pack (symbolVal (Proxy @name)))+    pure $ Right $ OptionalParam $ case lookup name (rpQuery parts) of+      Just (Just val) -> parseCapture @a (TE.decodeUtf8Lenient val)+      _               -> Nothing+++-- ===================================================================+-- Extension: extract typed data from request extensions+-- ===================================================================++-- | Extract typed data from request extensions.+-- Middleware stores data via 'insertExtension'; handlers retrieve it here.+--+-- @+-- handler :: Extension RequestId -> IO Response+-- @+newtype Extension a = Extension { unExtension :: a }+  deriving (Show, Eq)++instance Typeable a => FromRequestParts (Extension a) where+  fromRequestParts parts = do+    mVal <- lookupExtension @a (rpExtensions parts)+    pure $ case mVal of+      Just val -> Right (Extension val)+      Nothing  -> Left (mkError status500 "Extension not found in request")+++-- ===================================================================+-- Optional: make any FromRequestParts extractor optional+-- ===================================================================++-- | Wraps any 'FromRequestParts' extractor to make it optional.+-- Returns 'Nothing' instead of failing if extraction fails.+--+-- @+-- handler :: Optional (ReqHeader "Authorization") -> IO Response+-- @+newtype Optional a = Optional { unOptional :: Maybe a }+  deriving (Show, Eq)++instance FromRequestParts a => FromRequestParts (Optional a) where+  fromRequestParts parts = do+    result <- fromRequestParts @a parts+    pure $ Right $ Optional $ case result of+      Right val -> Just val+      Left _    -> Nothing+++-- ===================================================================+-- ReqMethod: extract the HTTP method+-- ===================================================================++-- | Extract the HTTP method from the request.+newtype ReqMethod = ReqMethod { unReqMethod :: ByteString }+  deriving (Show, Eq)++instance FromRequestParts ReqMethod where+  fromRequestParts parts = pure (Right (ReqMethod (rpMethod parts)))+++-- ===================================================================+-- HeaderMap: all request headers+-- ===================================================================++-- | All request headers as an association list.+--+-- @+-- handler :: HeaderMap -> IO (Json Value)+-- handler (HeaderMap hdrs) = ...+-- @+newtype HeaderMap = HeaderMap { unHeaderMap :: [(CI.CI ByteString, ByteString)] }+  deriving (Show, Eq)++instance FromRequestParts HeaderMap where+  fromRequestParts parts = pure (Right (HeaderMap (rpHeaders parts)))+++-- ===================================================================+-- FullRequest: access the complete RequestParts+-- ===================================================================++-- | Access the full 'RequestParts' — method, path, query, headers,+-- extensions. Use when no specific extractor fits.+--+-- @+-- handler :: FullRequest -> IO (Response ByteString)+-- handler (FullRequest parts) = ...+-- @+newtype FullRequest = FullRequest { unFullRequest :: RequestParts }++instance FromRequestParts FullRequest where+  fromRequestParts parts = pure (Right (FullRequest parts))+++-- ===================================================================+-- RawQuery: unparsed query string+-- ===================================================================++-- | The raw query string from the request path (everything after @?@).+--+-- @+-- handler :: RawQuery -> IO Text+-- handler (RawQuery q) = ...+-- @+newtype RawQuery = RawQuery { unRawQuery :: ByteString }+  deriving (Show, Eq)++instance FromRequestParts RawQuery where+  fromRequestParts parts =+    let raw = rpPathRaw parts+        q = BS.drop 1 (snd (BS.break (== 0x3F) raw))  -- 0x3F = '?'+    in pure (Right (RawQuery q))+++-- ===================================================================+-- RawPathParams: untyped path captures as text+-- ===================================================================++-- | The raw captured path segments as a list of 'Text', before+-- any type-level parsing. Useful for logging or debugging.+--+-- @+-- handler :: RawPathParams -> IO Text+-- handler (RawPathParams segs) = ...+-- @+newtype RawPathParams = RawPathParams { unRawPathParams :: [Text] }+  deriving (Show, Eq)++instance FromRequestParts RawPathParams where+  fromRequestParts parts = do+    mCaps <- lookupExtension @CaptureList (rpExtensions parts)+    pure $ Right $ RawPathParams $ case mCaps of+      Just (CaptureList caps) -> caps+      Nothing                 -> []+++-- ===================================================================+-- StringBody: request body as Text (UTF-8)+-- ===================================================================++-- | The request body decoded as UTF-8 'Text'.+--+-- @+-- handler :: StringBody -> IO Text+-- handler (StringBody txt) = pure ("Echo: " <> txt)+-- @+newtype StringBody = StringBody { unStringBody :: Text }+  deriving (Show, Eq)++instance FromRequest StringBody where+  fromRequest _parts body = pure (Right (StringBody (TE.decodeUtf8Lenient body)))++instance FromRequestParts StringBody where+  fromRequestParts parts = do+    mBody <- lookupExtension @BodyBytes (rpExtensions parts)+    pure $ case mBody of+      Just (BodyBytes body) -> Right (StringBody (TE.decodeUtf8Lenient body))+      Nothing -> Left (mkError status500 "Request body not available (router bug)")+++-- ===================================================================+-- OriginalUri: the original request URI+-- ===================================================================++-- | The original request URI before any routing transformations.+-- Stored in Extensions by the router.+--+-- @+-- handler :: OriginalUri -> IO Text+-- handler (OriginalUri uri) = ...+-- @+newtype OriginalUri = OriginalUri { unOriginalUri :: ByteString }+  deriving (Show, Eq, Typeable)++instance FromRequestParts OriginalUri where+  fromRequestParts parts =+    -- If stored by the router, use that; otherwise fall back to rpPathRaw+    do mUri <- lookupExtension @OriginalUri (rpExtensions parts)+       pure $ Right $ case mUri of+         Just uri -> uri+         Nothing  -> OriginalUri (rpPathRaw parts)+++-- ===================================================================+-- MatchedPath: the route pattern that matched+-- ===================================================================++-- | The route pattern that matched this request (e.g. @\/users\/{capture}@).+-- Stored in Extensions by the router.+--+-- @+-- handler :: MatchedPath -> IO Text+-- handler (MatchedPath pat) = ...  -- e.g. "/users/{capture}"+-- @+newtype MatchedPath = MatchedPath { unMatchedPath :: Text }+  deriving (Show, Eq, Typeable)++instance FromRequestParts MatchedPath where+  fromRequestParts parts = do+    mPath <- lookupExtension @MatchedPath (rpExtensions parts)+    pure $ case mPath of+      Just mp -> Right mp+      Nothing -> Left (mkError status500 "MatchedPath not found in extensions (router bug)")+++-- ===================================================================+-- NestedPath: nesting context for sub-routers+-- ===================================================================++-- | The path prefix consumed by parent routers when using sub-API+-- composition. Useful for building relative URLs.+--+-- @+-- handler :: NestedPath -> IO Text+-- handler (NestedPath prefix) = ...+-- @+newtype NestedPath = NestedPath { unNestedPath :: [Text] }+  deriving (Show, Eq, Typeable)++instance FromRequestParts NestedPath where+  fromRequestParts parts = do+    mNested <- lookupExtension @NestedPath (rpExtensions parts)+    pure $ Right $ case mNested of+      Just np -> np+      Nothing -> NestedPath []+++-- ===================================================================+-- ConnectInfo: client connection information+-- ===================================================================++-- | Client connection metadata (IP address, port).+-- Stored in Extensions by the backend adapter (spire-server, spire-wai).+--+-- @+-- handler :: ConnectInfo -> IO Text+-- handler (ConnectInfo host port) = ...+-- @+data ConnectInfo = ConnectInfo+  { ciHost :: !Text+  , ciPort :: !Int+  } deriving (Show, Eq, Typeable)++instance FromRequestParts ConnectInfo where+  fromRequestParts parts = do+    mInfo <- lookupExtension @ConnectInfo (rpExtensions parts)+    pure $ case mInfo of+      Just ci -> Right ci+      Nothing -> Left (mkError status500+        "ConnectInfo not available (backend adapter must inject it)")+++-- ===================================================================+-- Form: url-encoded form body+-- ===================================================================++-- | A form-decoded request body (@application\/x-www-form-urlencoded@).+--+-- @+-- data LoginForm = LoginForm { lfUser :: Text, lfPass :: Text }+--+-- handler :: Form LoginForm -> IO (Json Session)+-- handler (Form form) = ...+-- @+--+-- The inner type must have a 'FromForm' instance (provided by the user)+-- which converts @[(ByteString, ByteString)]@ to the desired type.+newtype Form a = Form { unForm :: a }+  deriving (Show, Eq)++-- | Convert parsed form key-value pairs into a typed value.+class FromForm a where+  fromForm :: [(ByteString, ByteString)] -> Either Text a++instance FromForm a => FromRequest (Form a) where+  fromRequest _parts body =+    let pairs = parseFormUrlEncoded body+    in pure $ case fromForm pairs of+      Right val -> Right (Form val)+      Left err  -> Left (mkError status422 ("Form parse error: " <> err))++instance FromForm a => FromRequestParts (Form a) where+  fromRequestParts parts = do+    mBody <- lookupExtension @BodyBytes (rpExtensions parts)+    pure $ case mBody of+      Just (BodyBytes body) ->+        case fromForm (parseFormUrlEncoded body) of+          Right val -> Right (Form val)+          Left err  -> Left (mkError status422 ("Form parse error: " <> err))+      Nothing -> Left (mkError status500 "Request body not available (router bug)")++-- | Parse @application\/x-www-form-urlencoded@ bytes into key-value pairs.+--+-- Uses 'Network.HTTP.Types.urlDecode' for proper percent-decoding+-- (handles @%XX@ encoding and @+@ as space).+parseFormUrlEncoded :: ByteString -> [(ByteString, ByteString)]+parseFormUrlEncoded bs+  | BS.null bs = []+  | otherwise  = map parsePair (BS.split 0x26 bs)  -- 0x26 = '&'+  where+    parsePair p =+      let (k, rest) = BS.break (== 0x3D) p  -- 0x3D = '='+      in (urlDecode True k, urlDecode True (BS.drop 1 rest))+++-- ===================================================================+-- RawForm: unparsed form key-value pairs+-- ===================================================================++-- | Raw form data as key-value pairs without typed parsing.+-- For @application\/x-www-form-urlencoded@ bodies.+--+-- @+-- handler :: RawForm -> IO Text+-- handler (RawForm pairs) = ...+-- @+newtype RawForm = RawForm { unRawForm :: [(ByteString, ByteString)] }+  deriving (Show, Eq)++instance FromRequest RawForm where+  fromRequest _parts body = pure (Right (RawForm (parseFormUrlEncoded body)))++instance FromRequestParts RawForm where+  fromRequestParts parts = do+    mBody <- lookupExtension @BodyBytes (rpExtensions parts)+    pure $ case mBody of+      Just (BodyBytes body) -> Right (RawForm (parseFormUrlEncoded body))+      Nothing -> Left (mkError status500 "Request body not available (router bug)")+++-- ===================================================================+-- Multipart: file uploads (multipart/form-data)+-- ===================================================================++-- | A parsed multipart form body, containing fields and file uploads.+--+-- @+-- handler :: Multipart -> IO (Json UploadResult)+-- handler (Multipart parts) = do+--   let files = [p | p <- parts, fpFileName p /= Nothing]+--   ...+-- @+--+-- Each part contains the field name, optional filename, content type,+-- and body bytes.+newtype Multipart = Multipart { unMultipart :: [FilePart] }+  deriving (Show, Eq)++-- | A single part of a multipart form submission.+data FilePart = FilePart+  { fpFieldName   :: !Text+  , fpFileName    :: !(Maybe Text)+  , fpContentType :: !ByteString+  , fpBody        :: !ByteString+  } deriving (Show, Eq)++instance FromRequest Multipart where+  fromRequest parts body = do+    let ct = lookup (CI.mk "content-type") (rpHeaders parts)+    pure $ case ct >>= extractBoundary of+      Just boundary -> Right (Multipart (parseMultipart boundary body))+      Nothing       -> Left (mkError status400+        "Missing or invalid Content-Type for multipart/form-data")++instance FromRequestParts Multipart where+  fromRequestParts parts = do+    mBody <- lookupExtension @BodyBytes (rpExtensions parts)+    let ct = lookup (CI.mk "content-type") (rpHeaders parts)+    pure $ case (mBody, ct >>= extractBoundary) of+      (Just (BodyBytes body), Just boundary) ->+        Right (Multipart (parseMultipart boundary body))+      (Nothing, _) ->+        Left (mkError status500 "Request body not available (router bug)")+      (_, Nothing) ->+        Left (mkError status400+          "Missing or invalid Content-Type for multipart/form-data")++-- | Extract the boundary string from a multipart Content-Type header.+extractBoundary :: ByteString -> Maybe ByteString+extractBoundary ct+  | "multipart/form-data" `BS.isPrefixOf` ct =+      let parts = BS.split 0x3B ct  -- 0x3B = ';'+      in case filter (hasBoundary . BS.dropWhile (== 0x20)) parts of+           (p : _) -> Just (BS.drop 1 (snd (BS.break (== 0x3D) (BS.dropWhile (== 0x20) p))))+           []       -> Nothing+  | otherwise = Nothing+  where+    hasBoundary s = "boundary=" `BS.isPrefixOf` s || "boundary=" `BS.isPrefixOf` BS.map toLowerW8 s+    toLowerW8 w+      | w >= 0x41 && w <= 0x5A = w + 0x20+      | otherwise              = w++-- | Maximum number of parts allowed in a multipart body.+-- Prevents excessive memory/CPU usage from adversarial inputs with+-- thousands of parts.+maxMultipartParts :: Int+maxMultipartParts = 1000++-- | Parse a multipart body given the boundary string.+-- This is a simplified parser that handles the common case.+-- Output is capped at 'maxMultipartParts' parts.+parseMultipart :: ByteString -> ByteString -> [FilePart]+parseMultipart boundary body =+  let delim = "--" <> boundary+      chunks = splitOnBoundary delim body+  in take maxMultipartParts (concatMap parsePart chunks)++-- | Split the body on boundary delimiters.+splitOnBoundary :: ByteString -> ByteString -> [ByteString]+splitOnBoundary delim body = go body+  where+    go bs+      | BS.null bs = []+      | otherwise  = case BS.breakSubstring delim bs of+          (_, rest) | BS.null rest -> []+          (_, rest) ->+            let afterDelim = BS.drop (BS.length delim) rest+                -- Skip CRLF after boundary+                afterCrlf = if "\r\n" `BS.isPrefixOf` afterDelim+                            then BS.drop 2 afterDelim+                            else if "\n" `BS.isPrefixOf` afterDelim+                            then BS.drop 1 afterDelim+                            else afterDelim+            in if "--" `BS.isPrefixOf` afterDelim+               then []  -- final boundary+               else case BS.breakSubstring delim afterCrlf of+                 (chunk, _) ->+                   let trimmed = if "\r\n" `BS.isSuffixOf` chunk+                                 then BS.take (BS.length chunk - 2) chunk+                                 else chunk+                   in trimmed : go (BS.drop (BS.length chunk) afterCrlf)++-- | Parse a single multipart part (headers + body).+parsePart :: ByteString -> [FilePart]+parsePart chunk+  | BS.null chunk = []+  | otherwise =+    let (headerSection, bodySection) = splitHeaders chunk+        headers = parsePartHeaders headerSection+        fieldName = lookupPartHeader "name" headers+        fileName  = lookupPartHeader "filename" headers+        contentType = maybe "application/octet-stream" id+                      (lookup "content-type" headers >>= id)+    in case fieldName of+      Just name -> [FilePart+        { fpFieldName   = TE.decodeUtf8Lenient name+        , fpFileName    = TE.decodeUtf8Lenient <$> fileName+        , fpContentType = contentType+        , fpBody        = bodySection+        }]+      Nothing -> []++-- | Split part into headers and body at the blank line.+splitHeaders :: ByteString -> (ByteString, ByteString)+splitHeaders bs = case BS.breakSubstring "\r\n\r\n" bs of+  (h, rest) | not (BS.null rest) -> (h, BS.drop 4 rest)+  _ -> case BS.breakSubstring "\n\n" bs of+    (h, rest) | not (BS.null rest) -> (h, BS.drop 2 rest)+    _ -> (bs, "")++-- | Parse part headers into key-value pairs.+parsePartHeaders :: ByteString -> [(ByteString, Maybe ByteString)]+parsePartHeaders bs =+  let ls = filter (not . BS.null) (BS.split 0x0A bs)  -- split on LF+  in concatMap parseOneHeader ls+  where+    parseOneHeader line =+      let cleaned = if "\r" `BS.isSuffixOf` line then BS.init line else line+          (name, rest) = BS.break (== 0x3A) cleaned  -- ':'+          val = BS.dropWhile (== 0x20) (BS.drop 1 rest)+      in if "content-disposition" `BS.isPrefixOf` BS.map toLowerW8 name+         then [("content-disposition", Just val)] ++ parseDisposition val+         else if "content-type" `BS.isPrefixOf` BS.map toLowerW8 name+         then [("content-type", Just val)]+         else [(BS.map toLowerW8 name, Just val)]++    toLowerW8 w+      | w >= 0x41 && w <= 0x5A = w + 0x20+      | otherwise              = w++-- | Parse Content-Disposition parameters (name, filename).+parseDisposition :: ByteString -> [(ByteString, Maybe ByteString)]+parseDisposition val =+  let parts = BS.split 0x3B val  -- ';'+  in concatMap parseParam (drop 1 parts)+  where+    parseParam p =+      let trimmed = BS.dropWhile (== 0x20) p+          (key, rest) = BS.break (== 0x3D) trimmed  -- '='+          rawVal = BS.drop 1 rest+          unquoted = if BS.length rawVal >= 2+                     && BS.head rawVal == 0x22  -- '"'+                     && BS.last rawVal == 0x22+                     then BS.init (BS.tail rawVal)+                     else rawVal+      in [(BS.map toLowerW8 key, Just unquoted)]++    toLowerW8 w+      | w >= 0x41 && w <= 0x5A = w + 0x20+      | otherwise              = w++-- | Lookup a parameter from parsed disposition headers.+lookupPartHeader :: ByteString -> [(ByteString, Maybe ByteString)] -> Maybe ByteString+lookupPartHeader key headers = do+  (_, mVal) <- find (\(k, _) -> k == key) headers+  mVal+  where+    find _ [] = Nothing+    find p (x:xs) = if p x then Just x else find p xs

@@ -0,0 +1,265 @@+-- | Handler binding: connecting typed handlers to API endpoints.+module Acolyte.Server.Handler+  ( -- * Bound handler+    BoundHandler (..)+  , HandlerFn+  , MatchResult (..)+    -- * Endpoint metadata+  , HasEndpointInfo (..)+    -- * Path reflection+  , ReflectPath (..)+    -- * Handler constructors+  , mkHandler0+  , mkHandler1Parts+  , mkHandler1Body+  , mkHandler2PartsBody+  ) where++import Data.ByteString (ByteString)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Typeable (Typeable)+import Network.HTTP.Types (Method)+import GHC.TypeLits (KnownSymbol, symbolVal)+import Data.Proxy (Proxy (..))++import Http.Core+  ( Request (..), Response (..)+  , RequestParts (..)+  , Extensions, insertExtension+  )+import Acolyte.Server.Extract+import Acolyte.Server.Response++import Acolyte.Core.Endpoint (Endpoint)+import Acolyte.Core.Effect (Requires)+import Acolyte.Core.Wrapper+  ( Protected, Validated, Versioned, ApiVersion (..), Describe, Description, Named+  , WithParams, WithHeaders+  , ServerStream, ClientStream, BidiStream, RespondsWith+  )+import Acolyte.Core.Method (KnownMethod, methodVal)+import qualified Acolyte.Core.Method as Core+import Acolyte.Core.Path (PathSegment(..))+++-- | A type-erased handler function.+type HandlerFn = RequestParts -> ByteString -> IO (Response ByteString)+++-- | Result of matching a path.+data MatchResult = MatchResult+  { mrCaptures :: ![Text]+  } deriving (Show)+++-- | A handler bound to a specific endpoint.+data BoundHandler = BoundHandler+  { bhMethod   :: !Method+  , bhPattern  :: !Text+  , bhMatchFn  :: [Text] -> Maybe MatchResult+  , bhHandler  :: HandlerFn+  }+++-- ===================================================================+-- Endpoint metadata extraction+-- ===================================================================++-- | Extract HTTP method, URL pattern, and path matcher from an endpoint type.+class HasEndpointInfo endpoint where+  endpointMethod  :: Method+  endpointPattern :: Text+  endpointMatcher :: [Text] -> Maybe MatchResult+++instance (KnownMethod m, ReflectPath path)+  => HasEndpointInfo (Endpoint m path req resp) where+    endpointMethod  = methodToBS (methodVal @m)+    endpointPattern = reflectPattern @path+    endpointMatcher = reflectMatch @path++-- Requires delegates to inner endpoint (Layer 1 effect tracking is phantom-only)+instance HasEndpointInfo inner+  => HasEndpointInfo (Requires e inner) where+    endpointMethod  = endpointMethod @inner+    endpointPattern = endpointPattern @inner+    endpointMatcher = endpointMatcher @inner++-- Protected delegates to inner endpoint (Layer 2 wrapper)+instance HasEndpointInfo inner+  => HasEndpointInfo (Protected auth inner) where+    endpointMethod  = endpointMethod @inner+    endpointPattern = endpointPattern @inner+    endpointMatcher = endpointMatcher @inner++-- Validated delegates to inner endpoint (Layer 2 wrapper)+instance HasEndpointInfo inner+  => HasEndpointInfo (Validated v inner) where+    endpointMethod  = endpointMethod @inner+    endpointPattern = endpointPattern @inner+    endpointMatcher = endpointMatcher @inner++-- Describe delegates to inner endpoint (Layer 2 wrapper)+instance HasEndpointInfo inner+  => HasEndpointInfo (Describe desc inner) where+    endpointMethod  = endpointMethod @inner+    endpointPattern = endpointPattern @inner+    endpointMatcher = endpointMatcher @inner++-- Description delegates to inner endpoint (Layer 2 wrapper)+instance HasEndpointInfo inner+  => HasEndpointInfo (Description desc inner) where+    endpointMethod  = endpointMethod @inner+    endpointPattern = endpointPattern @inner+    endpointMatcher = endpointMatcher @inner++-- WithParams delegates to inner endpoint (transparent annotation)+instance HasEndpointInfo inner+  => HasEndpointInfo (WithParams ps inner) where+    endpointMethod  = endpointMethod @inner+    endpointPattern = endpointPattern @inner+    endpointMatcher = endpointMatcher @inner++-- WithHeaders delegates to inner endpoint (transparent annotation)+instance HasEndpointInfo inner+  => HasEndpointInfo (WithHeaders hs inner) where+    endpointMethod  = endpointMethod @inner+    endpointPattern = endpointPattern @inner+    endpointMatcher = endpointMatcher @inner++-- ServerStream delegates to inner endpoint (streaming marker)+instance HasEndpointInfo inner+  => HasEndpointInfo (ServerStream inner) where+    endpointMethod  = endpointMethod @inner+    endpointPattern = endpointPattern @inner+    endpointMatcher = endpointMatcher @inner++-- ClientStream delegates to inner endpoint (streaming marker)+instance HasEndpointInfo inner+  => HasEndpointInfo (ClientStream inner) where+    endpointMethod  = endpointMethod @inner+    endpointPattern = endpointPattern @inner+    endpointMatcher = endpointMatcher @inner++-- BidiStream delegates to inner endpoint (streaming marker)+instance HasEndpointInfo inner+  => HasEndpointInfo (BidiStream inner) where+    endpointMethod  = endpointMethod @inner+    endpointPattern = endpointPattern @inner+    endpointMatcher = endpointMatcher @inner++-- RespondsWith delegates to inner endpoint (status code annotation)+instance HasEndpointInfo inner+  => HasEndpointInfo (RespondsWith s inner) where+    endpointMethod  = endpointMethod @inner+    endpointPattern = endpointPattern @inner+    endpointMatcher = endpointMatcher @inner++-- Named delegates to inner endpoint (name annotation)+instance HasEndpointInfo inner+  => HasEndpointInfo (Named name inner) where+    endpointMethod  = endpointMethod @inner+    endpointPattern = endpointPattern @inner+    endpointMatcher = endpointMatcher @inner++-- Versioned prepends the version prefix to the path+instance (ApiVersion v, HasEndpointInfo inner)+  => HasEndpointInfo (Versioned v inner) where+    endpointMethod = endpointMethod @inner+    endpointPattern = "/" <> versionPrefix @v <> endpointPattern @inner+    endpointMatcher (seg : rest)+      | seg == versionPrefix @v = endpointMatcher @inner rest+      | otherwise = Nothing+    endpointMatcher [] = Nothing+++methodToBS :: Core.Method -> Method+methodToBS Core.GET     = "GET"+methodToBS Core.POST    = "POST"+methodToBS Core.PUT     = "PUT"+methodToBS Core.DELETE  = "DELETE"+methodToBS Core.PATCH   = "PATCH"+methodToBS Core.HEAD    = "HEAD"+methodToBS Core.OPTIONS = "OPTIONS"+++-- ===================================================================+-- Path reflection: type-level -> runtime+-- ===================================================================++-- | Reflect a type-level path into a runtime URL pattern and path matcher.+class ReflectPath (path :: [PathSegment]) where+  reflectPattern :: Text+  reflectMatch   :: [Text] -> Maybe MatchResult++instance ReflectPath '[] where+  reflectPattern = ""+  reflectMatch [] = Just (MatchResult [])+  reflectMatch _  = Nothing++instance (KnownSymbol s, ReflectPath rest) => ReflectPath ('Lit s ': rest) where+  reflectPattern = "/" <> T.pack (symbolVal (Proxy @s)) <> reflectPattern @rest+  reflectMatch (seg : segs)+    | seg == T.pack (symbolVal (Proxy @s)) = reflectMatch @rest segs+    | otherwise = Nothing+  reflectMatch [] = Nothing++instance ReflectPath rest => ReflectPath ('Capture t ': rest) where+  reflectPattern = "/{capture}" <> reflectPattern @rest+  reflectMatch (seg : segs) =+    case reflectMatch @rest segs of+      Just (MatchResult caps) -> Just (MatchResult (seg : caps))+      Nothing                 -> Nothing+  reflectMatch [] = Nothing++instance (KnownSymbol name, ReflectPath rest) => ReflectPath ('CaptureNamed name t ': rest) where+  reflectPattern = "/{" <> T.pack (symbolVal (Proxy @name)) <> "}" <> reflectPattern @rest+  reflectMatch (seg : segs) =+    case reflectMatch @rest segs of+      Just (MatchResult caps) -> Just (MatchResult (seg : caps))+      Nothing -> Nothing+  reflectMatch [] = Nothing+++-- ===================================================================+-- Handler constructors+-- ===================================================================++-- | Build a handler that takes no extracted arguments.+mkHandler0 :: IntoResponse resp => IO resp -> HandlerFn+mkHandler0 action _parts _body = intoResponse <$> action++-- | Build a handler that extracts one argument from request parts (not body).+mkHandler1Parts+  :: (FromRequestParts a, IntoResponse resp)+  => (a -> IO resp) -> HandlerFn+mkHandler1Parts f parts _body = do+  ea <- fromRequestParts parts+  case ea of+    Left err -> pure (intoResponse err)+    Right a  -> intoResponse <$> f a++-- | Build a handler that extracts one argument from the request body.+mkHandler1Body+  :: (FromRequest b, IntoResponse resp)+  => (b -> IO resp) -> HandlerFn+mkHandler1Body f parts body = do+  eb <- fromRequest parts body+  case eb of+    Left err -> pure (intoResponse err)+    Right b  -> intoResponse <$> f b++-- | Build a handler that extracts one argument from request parts and one from the body.+mkHandler2PartsBody+  :: (FromRequestParts a, FromRequest b, IntoResponse resp)+  => (a -> b -> IO resp) -> HandlerFn+mkHandler2PartsBody f parts body = do+  ea <- fromRequestParts parts+  case ea of+    Left err -> pure (intoResponse err)+    Right a -> do+      eb <- fromRequest parts body+      case eb of+        Left err -> pure (intoResponse err)+        Right b  -> intoResponse <$> f a b

@@ -0,0 +1,314 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+-- | Ergonomic server construction: pass handler functions directly.+--+-- @mkApi@ lets you build a server from an API type and a tuple of+-- plain handler functions — no 'wrapHandler', no 'toHandler', no+-- ceremony:+--+-- @+-- type API = '[ Get HealthPath Text+--             , Get UserByIdPath (Json Text)+--             ]+--+-- healthHandler :: IO Text+-- healthHandler = pure "ok"+--+-- getUserHandler :: PathCapture Int -> IO (Json Text)+-- getUserHandler (PathCapture n) = pure (Json (T.pack ("user-" ++ show n)))+--+-- svc = mkApi \@API (healthHandler, getUserHandler)+-- @+--+-- Each handler must satisfy 'ToHandler' (the same class used with the+-- explicit API). Endpoint metadata is extracted via 'HasEndpointInfo'.+-- The tuple is matched positionally to the type-level API list.+module Acolyte.Server.MkApi+  ( -- * Server construction+    mkApi+    -- * BuildApi class (internal)+  , BuildApi (..)+    -- * Helper+  , toBoundHandler+    -- * Protected auth enforcement+  , FirstArg+  ) where++import Data.Kind (Type, Constraint)+import Data.ByteString (ByteString)+import GHC.TypeLits (TypeError, ErrorMessage (..))++import Spire.Service (Service (..))+import Http.Core (Request, Response)++import Acolyte.Core.API (Serves)+import Acolyte.Core.Wrapper (Protected)+import Acolyte.Server.Handler+  ( BoundHandler (..), HasEndpointInfo (..) )+import Acolyte.Server.ToHandler (ToHandler (..))+import Acolyte.Server.Router+  ( Router, emptyRouter, addRoute )+import qualified Acolyte.Server.Router as Router+++-- | Build a 'BoundHandler' from a handler function and endpoint metadata.+--+-- Combines 'toHandler' (typed function -> HandlerFn) with+-- 'HasEndpointInfo' (endpoint type -> routing metadata).+toBoundHandler+  :: forall endpoint f. (HasEndpointInfo endpoint, ToHandler f)+  => f -> BoundHandler+toBoundHandler f = BoundHandler+  { bhMethod  = endpointMethod @endpoint+  , bhPattern = endpointPattern @endpoint+  , bhMatchFn = endpointMatcher @endpoint+  , bhHandler = toHandler f+  }+++-- | Build a spire Service from an API type and a tuple of handler functions.+--+-- This is the most ergonomic entry point. Each handler function is+-- positionally matched to the corresponding endpoint in the API+-- type-level list. Handlers must satisfy 'ToHandler' — they can be+-- plain @IO r@ actions or functions taking extractors+-- (@PathCapture@, @JsonBody@, etc.).+--+-- @+-- mkApi \@API (healthHandler, getUserHandler, createUserHandler)+-- @+mkApi+  :: forall api handlers+   . (Serves api handlers, BuildApi api handlers)+  => handlers+  -> Service IO (Request ByteString) (Response ByteString)+mkApi handlers = Router.serve (buildApi @api handlers emptyRouter)+++-- | Decompose a tuple into its first element and the rest.+--+-- Supports arities 2–25. For a 2-tuple, the tail is the bare second+-- element (not a 1-tuple). This enables 'BuildApi' to recursively+-- peel one handler at a time from a handler tuple.+class SplitTuple t where+  type TupleHead t :: Type+  type TupleTail t :: Type+  tupleHead :: t -> TupleHead t+  tupleTail :: t -> TupleTail t++instance SplitTuple (a, b) where+  type TupleHead (a, b) = a+  type TupleTail (a, b) = b+  tupleHead (a, _) = a+  tupleTail (_, b) = b++instance SplitTuple (a, b, c) where+  type TupleHead (a, b, c) = a+  type TupleTail (a, b, c) = (b, c)+  tupleHead (a, _, _) = a+  tupleTail (_, b, c) = (b, c)++instance SplitTuple (a, b, c, d) where+  type TupleHead (a, b, c, d) = a+  type TupleTail (a, b, c, d) = (b, c, d)+  tupleHead (a, _, _, _) = a+  tupleTail (_, b, c, d) = (b, c, d)++instance SplitTuple (a, b, c, d, e) where+  type TupleHead (a, b, c, d, e) = a+  type TupleTail (a, b, c, d, e) = (b, c, d, e)+  tupleHead (a, _, _, _, _) = a+  tupleTail (_, b, c, d, e) = (b, c, d, e)++instance SplitTuple (a, b, c, d, e, f) where+  type TupleHead (a, b, c, d, e, f) = a+  type TupleTail (a, b, c, d, e, f) = (b, c, d, e, f)+  tupleHead (a, _, _, _, _, _) = a+  tupleTail (_, b, c, d, e, f) = (b, c, d, e, f)++instance SplitTuple (a, b, c, d, e, f, g) where+  type TupleHead (a, b, c, d, e, f, g) = a+  type TupleTail (a, b, c, d, e, f, g) = (b, c, d, e, f, g)+  tupleHead (a, _, _, _, _, _, _) = a+  tupleTail (_, b, c, d, e, f, g) = (b, c, d, e, f, g)++instance SplitTuple (a, b, c, d, e, f, g, h) where+  type TupleHead (a, b, c, d, e, f, g, h) = a+  type TupleTail (a, b, c, d, e, f, g, h) = (b, c, d, e, f, g, h)+  tupleHead (a, _, _, _, _, _, _, _) = a+  tupleTail (_, b, c, d, e, f, g, h) = (b, c, d, e, f, g, h)++instance SplitTuple (a, b, c, d, e, f, g, h, i) where+  type TupleHead (a, b, c, d, e, f, g, h, i) = a+  type TupleTail (a, b, c, d, e, f, g, h, i) = (b, c, d, e, f, g, h, i)+  tupleHead (a, _, _, _, _, _, _, _, _) = a+  tupleTail (_, b, c, d, e, f, g, h, i) = (b, c, d, e, f, g, h, i)++instance SplitTuple (a, b, c, d, e, f, g, h, i, j) where+  type TupleHead (a, b, c, d, e, f, g, h, i, j) = a+  type TupleTail (a, b, c, d, e, f, g, h, i, j) = (b, c, d, e, f, g, h, i, j)+  tupleHead (a, _, _, _, _, _, _, _, _, _) = a+  tupleTail (_, b, c, d, e, f, g, h, i, j) = (b, c, d, e, f, g, h, i, j)++instance SplitTuple (a, b, c, d, e, f, g, h, i, j, k) where+  type TupleHead (a, b, c, d, e, f, g, h, i, j, k) = a+  type TupleTail (a, b, c, d, e, f, g, h, i, j, k) = (b, c, d, e, f, g, h, i, j, k)+  tupleHead (a, _, _, _, _, _, _, _, _, _, _) = a+  tupleTail (_, b, c, d, e, f, g, h, i, j, k) = (b, c, d, e, f, g, h, i, j, k)++instance SplitTuple (a, b, c, d, e, f, g, h, i, j, k, l) where+  type TupleHead (a, b, c, d, e, f, g, h, i, j, k, l) = a+  type TupleTail (a, b, c, d, e, f, g, h, i, j, k, l) = (b, c, d, e, f, g, h, i, j, k, l)+  tupleHead (a, _, _, _, _, _, _, _, _, _, _, _) = a+  tupleTail (_, b, c, d, e, f, g, h, i, j, k, l) = (b, c, d, e, f, g, h, i, j, k, l)++instance SplitTuple (a, b, c, d, e, f, g, h, i, j, k, l, m) where+  type TupleHead (a, b, c, d, e, f, g, h, i, j, k, l, m) = a+  type TupleTail (a, b, c, d, e, f, g, h, i, j, k, l, m) = (b, c, d, e, f, g, h, i, j, k, l, m)+  tupleHead (a, _, _, _, _, _, _, _, _, _, _, _, _) = a+  tupleTail (_, b, c, d, e, f, g, h, i, j, k, l, m) = (b, c, d, e, f, g, h, i, j, k, l, m)++instance SplitTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where+  type TupleHead (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = a+  type TupleTail (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = (b, c, d, e, f, g, h, i, j, k, l, m, n)+  tupleHead (a, _, _, _, _, _, _, _, _, _, _, _, _, _) = a+  tupleTail (_, b, c, d, e, f, g, h, i, j, k, l, m, n) = (b, c, d, e, f, g, h, i, j, k, l, m, n)++instance SplitTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where+  type TupleHead (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = a+  type TupleTail (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = (b, c, d, e, f, g, h, i, j, k, l, m, n, o)+  tupleHead (a, _, _, _, _, _, _, _, _, _, _, _, _, _, _) = a+  tupleTail (_, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = (b, c, d, e, f, g, h, i, j, k, l, m, n, o)++instance SplitTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) where+  type TupleHead (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) = a+  type TupleTail (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) = (b, c, d, e, f, g, h, i, j, k, l, m, n, o, p)+  tupleHead (a, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _) = a+  tupleTail (_, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) = (b, c, d, e, f, g, h, i, j, k, l, m, n, o, p)++instance SplitTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) where+  type TupleHead (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) = a+  type TupleTail (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) = (b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q)+  tupleHead (a, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _) = a+  tupleTail (_, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) = (b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q)++instance SplitTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) where+  type TupleHead (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) = a+  type TupleTail (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) = (b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r)+  tupleHead (a, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _) = a+  tupleTail (_, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) = (b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r)++instance SplitTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) where+  type TupleHead (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) = a+  type TupleTail (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) = (b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s)+  tupleHead (a, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _) = a+  tupleTail (_, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) = (b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s)++instance SplitTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) where+  type TupleHead (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) = a+  type TupleTail (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) = (b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t)+  tupleHead (a, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _) = a+  tupleTail (_, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) = (b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t)++instance SplitTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u) where+  type TupleHead (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u) = a+  type TupleTail (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u) = (b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u)+  tupleHead (a, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _) = a+  tupleTail (_, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u) = (b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u)++instance SplitTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v) where+  type TupleHead (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v) = a+  type TupleTail (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v) = (b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v)+  tupleHead (a, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _) = a+  tupleTail (_, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v) = (b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v)++instance SplitTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w) where+  type TupleHead (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w) = a+  type TupleTail (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w) = (b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w)+  tupleHead (a, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _) = a+  tupleTail (_, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w) = (b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w)++instance SplitTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x) where+  type TupleHead (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x) = a+  type TupleTail (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x) = (b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x)+  tupleHead (a, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _) = a+  tupleTail (_, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x) = (b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x)++instance SplitTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y) where+  type TupleHead (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y) = a+  type TupleTail (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y) = (b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y)+  tupleHead (a, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _, _) = a+  tupleTail (_, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y) = (b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y)+++-- | Class that walks the API list and handler tuple, populating a Router.+--+-- Each endpoint gets its routing metadata from 'HasEndpointInfo',+-- and each handler is converted via 'ToHandler'. Uses 'SplitTuple'+-- to recursively peel handlers from the tuple.+class BuildApi (api :: [Type]) handlers where+  buildApi :: handlers -> Router -> Router++-- Single endpoint: bare handler (not a tuple)+instance (HasEndpointInfo e, ToHandler h)+  => BuildApi '[e] h where+  buildApi h router =+    addRoute (toBoundHandler @e h) router++-- Two+ endpoints: peel the first handler from the tuple, recurse on the rest+instance {-# OVERLAPPABLE #-}+  ( HasEndpointInfo e+  , ToHandler (TupleHead handlers)+  , SplitTuple handlers+  , BuildApi es (TupleTail handlers)+  )+  => BuildApi (e ': es) handlers where+  buildApi handlers router =+    buildApi @es (tupleTail handlers)+      (addRoute (toBoundHandler @e (tupleHead handlers)) router)+++-- ===================================================================+-- Protected auth enforcement+-- ===================================================================++-- | Extract the first argument type from a function.+-- Produces a clear 'TypeError' if the handler is not a function+-- (i.e., it doesn't accept the auth type as its first argument).+type FirstArg :: Type -> Type+type family FirstArg (f :: Type) :: Type where+  FirstArg (a -> b) = a+  FirstArg other = TypeError+    ( 'Text "Protected endpoint handler must be a function (auth -> ...),"+      ':$$: 'Text "but got: " ':<>: 'ShowType other+      ':$$: 'Text "The handler's first argument must be the auth type."+    )++-- Single Protected endpoint: enforce auth as first handler argument+instance {-# OVERLAPPING #-}+  ( HasEndpointInfo (Protected auth inner)+  , ToHandler h+  , FirstArg h ~ auth+  ) => BuildApi '[Protected auth inner] h where+  buildApi h router =+    addRoute (toBoundHandler @(Protected auth inner) h) router++-- Protected in a multi-endpoint API: enforce auth on the head handler+instance {-# OVERLAPPING #-}+  ( HasEndpointInfo (Protected auth inner)+  , ToHandler (TupleHead handlers)+  , FirstArg (TupleHead handlers) ~ auth+  , SplitTuple handlers+  , BuildApi es (TupleTail handlers)+  ) => BuildApi (Protected auth inner ': es) handlers where+  buildApi handlers router =+    buildApi @es (tupleTail handlers)+      (addRoute (toBoundHandler @(Protected auth inner) (tupleHead handlers)) router)

@@ -0,0 +1,196 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+-- | Named routes: register handlers via a record instead of a positional tuple.+--+-- Two approaches are provided:+--+-- == Manual: 'NamedApi' (no 'Named' wrapper required)+--+-- Define a record, write a 'NamedApi' instance that maps it to a tuple,+-- and use 'mkNamedApi'. The mapping is explicit and positional.+--+-- == Automatic: 'mkRecordApi' (requires 'Named' wrappers)+--+-- Wrap each endpoint with @Named "fieldName"@, define a record whose+-- field names match the endpoint names, and use 'mkRecordApi'. GHC's+-- 'HasField' instances handle the matching — field order doesn't matter.+--+-- @+-- type API =+--   '[ Named "health"  (Get (At "health") Text)+--    , Named "getUser" (Get (Param "users" Int) (Json User))+--    ]+--+-- data Handlers = Handlers+--   { getUser :: PathCapture Int -> IO (Json User)  -- order doesn't matter+--   , health  :: IO Text+--   }+--+-- server = mkRecordApi \@API Handlers { getUser = ..., health = ... }+-- @+module Acolyte.Server.Named+  ( -- * Manual named handler conversion+    NamedApi (..)+  , mkNamedApi+  , effectfulNamedApi+    -- * Automatic record-based handler binding+  , BuildRecordApi (..)+  , mkRecordApi+  , effectfulRecordApi+  ) where++import Data.Kind (Type)+import Data.ByteString (ByteString)+import GHC.Records (HasField (..))++import Spire.Service (Service)+import Http.Core (Request, Response)++import Acolyte.Core.API (Serves)+import Acolyte.Core.Wrapper (Named, Protected, AllNamed, EndpointNames, NoDuplicateNames)+import Acolyte.Server.MkApi (BuildApi, mkApi, toBoundHandler, FirstArg)+import Acolyte.Server.Handler (HasEndpointInfo)+import Acolyte.Server.ToHandler (ToHandler)+import Acolyte.Server.Effects (EffectfulServer (..), effectfulApi, fromRouter)+import Acolyte.Server.Router (Router, emptyRouter, addRoute)+import qualified Acolyte.Server.Router as Router+++-- ===================================================================+-- Manual approach: NamedApi (backward-compatible)+-- ===================================================================++-- | Type class for converting a named handler record to a positional tuple+-- for use with 'mkApi'.+--+-- The @api@ parameter is the API type (a type-level list of endpoints).+-- @record@ is the user's handler record type. @tuple@ is the handler+-- tuple that 'BuildApi' expects.+--+-- The functional dependency @record -> tuple@ means each record type+-- determines a unique tuple type — GHC can infer the tuple from the record.+class NamedApi (api :: [Type]) record tuple | record -> tuple where+  toHandlerTuple :: record -> tuple+++-- | Build a spire 'Service' from a named handler record.+--+-- Equivalent to @mkApi \@api . toHandlerTuple@.+--+-- @+-- server = mkNamedApi \@API MyHandlers { ... }+-- @+mkNamedApi+  :: forall api record tuple+   . (NamedApi api record tuple, Serves api tuple, BuildApi api tuple)+  => record+  -> Service IO (Request ByteString) (Response ByteString)+mkNamedApi record = mkApi @api (toHandlerTuple @api record)+++-- | Build an 'EffectfulServer' from a named handler record.+--+-- Equivalent to @effectfulApi \@api . toHandlerTuple@.+--+-- @+-- server = run $ effectfulNamedApi \@API MyHandlers { ... }+-- @+effectfulNamedApi+  :: forall api record tuple+   . (NamedApi api record tuple, Serves api tuple, BuildApi api tuple)+  => record+  -> EffectfulServer api '[]+effectfulNamedApi record = effectfulApi @api (toHandlerTuple @api record)+++-- ===================================================================+-- Automatic approach: BuildRecordApi (requires Named wrappers)+-- ===================================================================++-- | Recursively walk a Named API list, extracting handlers from a record+-- via 'HasField' and adding them to the router.+--+-- Each endpoint must be wrapped with @Named "fieldName"@. The record+-- must have a field with that name whose type satisfies 'ToHandler'.+class BuildRecordApi (api :: [Type]) record where+  buildRecordApi :: record -> Router -> Router++instance BuildRecordApi '[] record where+  buildRecordApi _ router = router++instance {-# OVERLAPPABLE #-}+  ( HasField name record handler+  , HasEndpointInfo (Named name endpoint)+  , ToHandler handler+  , BuildRecordApi rest record+  ) => BuildRecordApi (Named name endpoint ': rest) record where+  buildRecordApi rec router =+    buildRecordApi @rest rec+      (addRoute (toBoundHandler @(Named name endpoint) (getField @name rec)) router)++-- Protected endpoint in a Named API: enforce auth as first handler argument+instance {-# OVERLAPPING #-}+  ( HasField name record handler+  , HasEndpointInfo (Named name (Protected auth inner))+  , ToHandler handler+  , FirstArg handler ~ auth+  , BuildRecordApi rest record+  ) => BuildRecordApi (Named name (Protected auth inner) ': rest) record where+  buildRecordApi rec router =+    buildRecordApi @rest rec+      (addRoute (toBoundHandler @(Named name (Protected auth inner)) (getField @name rec)) router)+++-- | Build a spire 'Service' from a Named API and a handler record.+--+-- Record fields are matched to endpoints by name — field order does+-- not matter. Every endpoint in the API must be wrapped with 'Named',+-- all names must be unique, and the record must have a matching field+-- for each name.+--+-- @+-- type API =+--   '[ Named "health"     (Get (At "health") Text)+--    , Named "getUser"    (Get (Param "users" Int) (Json User))+--    , Named "createUser" (Post (At "users") (Json CreateUser) (Json User))+--    ]+--+-- data Handlers = Handlers+--   { createUser :: JsonBody CreateUser -> IO (Json User)+--   , health     :: IO Text+--   , getUser    :: PathCapture Int -> IO (Json User)+--   }+--+-- server = mkRecordApi \@API Handlers { ... }+-- @+mkRecordApi+  :: forall api record+   . (AllNamed api, NoDuplicateNames (EndpointNames api), BuildRecordApi api record)+  => record+  -> Service IO (Request ByteString) (Response ByteString)+mkRecordApi record = Router.serve (buildRecordApi @api record emptyRouter)+++-- | Build an 'EffectfulServer' from a Named API and a handler record.+--+-- Like 'mkRecordApi' but returns an 'EffectfulServer' for use with+-- 'provide' and 'run'.+--+-- @+-- server = run $ effectfulRecordApi \@API Handlers { ... }+-- @+effectfulRecordApi+  :: forall api record+   . (AllNamed api, NoDuplicateNames (EndpointNames api), BuildRecordApi api record)+  => record+  -> EffectfulServer api '[]+effectfulRecordApi record = fromRouter (buildRecordApi @api record emptyRouter)

@@ -0,0 +1,201 @@+-- | Server-side content negotiation for @Negotiate@ types.+--+-- Parses the @Accept@ header, matches against the format list,+-- and serializes the response using the best matching format.+module Acolyte.Server.Negotiate+  ( -- * Content format serialization+    FormatEncoder (..)+    -- * Negotiation+  , negotiate+  , parseAccept+  , matchFormat+    -- * Negotiated response wrapper+  , NegotiatedResponse (..)+  ) where++import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Char8 as BS8+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Data.List (sortBy)+import Data.Ord (Down (..))+import Data.Char (isSpace, isDigit)+import Network.HTTP.Types (status200, status406)++import qualified Data.Aeson as Aeson++import Http.Core (Response (..))+import Acolyte.Core.Negotiate+  ( ContentFormat (..)+  , JsonFormat+  , XmlFormat+  , TextFormat+  , HtmlFormat+  )+++-- | Encode a value in a specific content format.+--+-- Each @(format, value-type)@ pair needs an instance.+class ContentFormat fmt => FormatEncoder fmt a where+  formatEncode :: a -> ByteString+++-- | JSON encoding via aeson.+instance Aeson.ToJSON a => FormatEncoder JsonFormat a where+  formatEncode = LBS.toStrict . Aeson.encode+++-- | Plain text encoding for 'Text'.+instance FormatEncoder TextFormat Text where+  formatEncode = TE.encodeUtf8+++-- | Plain text encoding for 'String'.+instance FormatEncoder TextFormat String where+  formatEncode = TE.encodeUtf8 . T.pack+++-- | Simple XML wrapping. Not a full XML serializer — wraps the value+-- in a @\<value\>@ tag using its 'Show' instance.+instance Show a => FormatEncoder XmlFormat a where+  formatEncode a =+    TE.encodeUtf8 $ "<?xml version=\"1.0\"?><value>" <> T.pack (show a) <> "</value>"+++-- | HTML encoding for 'Text' — wraps in a minimal HTML document.+instance FormatEncoder HtmlFormat Text where+  formatEncode t =+    TE.encodeUtf8 $ "<html><body>" <> t <> "</body></html>"+++-- | A response produced by content negotiation, pairing the selected+-- content type with the serialized body.+data NegotiatedResponse = NegotiatedResponse+  { nrContentType :: !ByteString+  , nrBody        :: !ByteString+  } deriving (Show, Eq)+++-- | Parse an @Accept@ header into a list of @(media-type, quality)@ pairs,+-- sorted by descending quality.+--+-- Examples:+--+-- @+-- parseAccept "application/json, text/plain;q=0.9"+--   == [("application/json", 1.0), ("text/plain", 0.9)]+-- @+--+-- Missing quality values default to 1.0. The @*/*@ wildcard is preserved+-- as-is for downstream matching.+parseAccept :: ByteString -> [(ByteString, Double)]+parseAccept hdr+  | BS.null hdr = []+  | otherwise   = sortBy (\a b -> compare (Down (snd a)) (Down (snd b)))+                $ map parseEntry (BS8.split ',' hdr)+  where+    parseEntry :: ByteString -> (ByteString, Double)+    parseEntry entry =+      case BS8.break (== ';') (trimBS entry) of+        (mediaType, rest)+          | BS.null rest -> (trimBS mediaType, 1.0)+          | otherwise    -> (trimBS mediaType, parseQuality rest)++    parseQuality :: ByteString -> Double+    parseQuality bs =+      -- rest starts with ';', so drop it, then look for q=+      let params = BS8.drop 1 bs  -- drop the ';'+          parts  = BS8.split ';' params+      in case filter (isQParam . trimBS) parts of+           (p : _) -> readQ (trimBS p)+           []       -> 1.0++    isQParam :: ByteString -> Bool+    isQParam bs =+      let stripped = trimBS bs+      in BS8.take 2 stripped == "q=" || BS8.take 2 stripped == "Q="++    readQ :: ByteString -> Double+    readQ bs =+      let valStr = BS8.unpack (BS8.drop 2 bs)+          cleaned = takeWhile (\c -> isDigit c || c == '.') valStr+      in case reads cleaned of+           ((d, _) : _) -> d+           []            -> 1.0++    trimBS :: ByteString -> ByteString+    trimBS = BS8.dropWhile isSpaceByte . BS8.reverse . BS8.dropWhile isSpaceByte . BS8.reverse++    isSpaceByte :: Char -> Bool+    isSpaceByte = isSpace+++-- | Given a parsed Accept header and a list of available+-- @(content-type, encoder)@ pairs, find the best matching encoder.+--+-- Returns 'Nothing' if no match is found (the caller should produce 406).+matchFormat+  :: ByteString                          -- ^ Raw Accept header+  -> [(Text, a -> ByteString)]           -- ^ Available formats: (content-type, encoder)+  -> Maybe (Text, a -> ByteString)       -- ^ Best match+matchFormat acceptHdr available+  | BS.null acceptHdr = case available of+      []    -> Nothing+      (f:_) -> Just f+  | otherwise =+      let parsed = parseAccept acceptHdr+      in firstMatch parsed available++  where+    firstMatch :: [(ByteString, Double)] -> [(Text, a -> ByteString)] -> Maybe (Text, a -> ByteString)+    firstMatch [] avail = Nothing+    firstMatch ((mediaType, _q) : rest) avail =+      case findAvailable mediaType avail of+        Just found -> Just found+        Nothing+          | mediaType == "*/*" -> case avail of+              []    -> Nothing+              (f:_) -> Just f+          | isWildcardSubtype mediaType -> findWildcardMatch mediaType avail rest+          | otherwise -> firstMatch rest avail++    findAvailable :: ByteString -> [(Text, a -> ByteString)] -> Maybe (Text, a -> ByteString)+    findAvailable _  [] = Nothing+    findAvailable mt ((ct, enc) : rest)+      | TE.encodeUtf8 ct == mt = Just (ct, enc)+      | otherwise               = findAvailable mt rest++    isWildcardSubtype :: ByteString -> Bool+    isWildcardSubtype bs = BS8.isSuffixOf "/*" bs++    findWildcardMatch :: ByteString -> [(Text, a -> ByteString)] -> [(ByteString, Double)] -> Maybe (Text, a -> ByteString)+    findWildcardMatch wildcard avail rest =+      let prefix = BS8.takeWhile (/= '/') wildcard  -- e.g. "text" from "text/*"+      in case filter (\(ct, _) -> TE.encodeUtf8 (T.takeWhile (/= '/') ct) == prefix) avail of+           (f:_) -> Just f+           []    -> firstMatch rest avail+++-- | Perform content negotiation: given an Accept header, a list of+-- available formats, and a value, produce an HTTP response.+--+-- If no format matches, returns 406 Not Acceptable.+negotiate+  :: ByteString                          -- ^ Raw Accept header+  -> [(Text, a -> ByteString)]           -- ^ Available formats: (content-type, encoder)+  -> a                                   -- ^ The value to serialize+  -> Response ByteString+negotiate acceptHdr available val =+  case matchFormat acceptHdr available of+    Just (ct, encoder) ->+      Response status200+        [("Content-Type", TE.encodeUtf8 ct)]+        (encoder val)+    Nothing ->+      Response status406+        [("Content-Type", "text/plain")]+        "406 Not Acceptable"

@@ -0,0 +1,118 @@+-- | Response encoding: converting handler return values to HTTP responses.+module Acolyte.Server.Response+  ( -- * Response class+    IntoResponse (..)+    -- * JSON response wrapper+  , Json (..)+    -- * Structured error+  , JsonError (..)+  , jsonError+  ) where++import Data.ByteString (ByteString)+import qualified Data.ByteString.Builder.Extra as Builder+import qualified Data.ByteString.Lazy as LBS+import Data.Text (Text)+import qualified Data.Text.Encoding as TE+import Network.HTTP.Types+  ( Status, status200, status400, status401, status403, status404+  , status422, status500, statusCode+  )++import qualified Data.Aeson as Aeson++import Http.Core (Response (..))+import Acolyte.Core.Endpoint (Json (..))+import Acolyte.Server.Extract (ServerError (..))+++-- | Convert a value into an HTTP 'Response'.+--+-- Handlers can return any type with an 'IntoResponse' instance.+-- The endpoint's declared response type (for OpenAPI/clients) is+-- separate — see 'CompatibleWith' (future).+class IntoResponse a where+  intoResponse :: a -> Response ByteString+++-- | Passthrough: Response is already a Response.+instance IntoResponse (Response ByteString) where+  intoResponse = id++-- | Plain text from ByteString.+instance IntoResponse ByteString where+  intoResponse bs = Response status200 [("Content-Type", "text/plain")] bs++-- | Plain text from Text.+instance IntoResponse Text where+  intoResponse t = Response status200 [("Content-Type", "text/plain; charset=utf-8")] (TE.encodeUtf8 t)++-- | Status code only (empty body).+instance IntoResponse Status where+  intoResponse s = Response s [] ""++-- | Status + body tuple.+instance IntoResponse a => IntoResponse (Status, a) where+  intoResponse (s, a) = (intoResponse a) { responseStatus = s }++-- | Either: Left is error response, Right is success response.+instance (IntoResponse e, IntoResponse a) => IntoResponse (Either e a) where+  intoResponse (Left e)  = intoResponse e+  intoResponse (Right a) = intoResponse a++-- | ServerError as a JSON error response.+instance IntoResponse ServerError where+  intoResponse (ServerError s msg) =+    let body = Aeson.encode $ Aeson.object+          [ "error" Aeson..= Aeson.object+            [ "status"  Aeson..= statusCode s+            , "message" Aeson..= msg+            ]+          ]+    in Response s [("Content-Type", "application/json")] (LBS.toStrict body)+++-- ===================================================================+-- Json: JSON response wrapper+-- ===================================================================++-- | A JSON-serialized response with @application/json@ content type.+--+-- @+-- handler :: IO (Json User)+-- handler = pure (Json myUser)+-- @++instance Aeson.ToJSON a => IntoResponse (Json a) where+  intoResponse (Json val) =+    let body = LBS.toStrict+             $ Builder.toLazyByteStringWith+                 (Builder.safeStrategy 256 256)+                 LBS.empty+             $ Aeson.fromEncoding (Aeson.toEncoding val)+    in Response status200 [("Content-Type", "application/json")] body+++-- ===================================================================+-- JsonError: structured JSON error responses+-- ===================================================================++-- | A structured JSON error response.+data JsonError = JsonError+  { jeStatus  :: !Status+  , jeMessage :: !Text+  } deriving (Show)++-- | Construct a 'JsonError' from a status code and message.+jsonError :: Status -> Text -> JsonError+jsonError = JsonError++instance IntoResponse JsonError where+  intoResponse (JsonError s msg) =+    let body = Aeson.encode $ Aeson.object+          [ "error" Aeson..= Aeson.object+            [ "status"  Aeson..= statusCode s+            , "message" Aeson..= msg+            ]+          ]+    in Response s [("Content-Type", "application/json")] (LBS.toStrict body)

@@ -0,0 +1,161 @@+-- | Router and Server: dispatch requests to handlers, produce spire Service.+module Acolyte.Server.Router+  ( -- * Router+    Router+  , emptyRouter+  , addRoute+  , dispatch+    -- * Server construction+  , serve+  , serveWithState+    -- * Capture parsing+  , ParseCapture (..)+  , CaptureList (..)+  , injectCaptures+  ) where++import Data.ByteString (ByteString)+import Data.List (insertBy)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Ord (comparing)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Typeable (Typeable)+import Network.HTTP.Types (status404, status405)++import Spire.Service (Service (..))+import Http.Core+  ( Request (..), Response (..)+  , RequestParts (..), splitRequest+  , Extensions, insertExtension+  )+import Acolyte.Server.Handler+import Acolyte.Server.Extract+  ( AppState (..), PathCapture (..), BodyBytes (..)+  , CaptureList (..), ParseCapture (..)+  , MatchedPath (..), OriginalUri (..)+  )+import Acolyte.Server.Response (IntoResponse (..))+++-- | A collection of routes, indexed by first path segment for fast dispatch.+--+-- Routes are split into two groups:+-- * 'riBySegment' — keyed by first literal path segment (O(log n) lookup)+-- * 'riWildcard' — routes whose first segment is a capture (fallback scan)+data Router = Router+  { riBySegment :: !(Map Text [BoundHandler])+  , riWildcard  :: ![BoundHandler]+  }++-- | An empty router with no routes registered.+emptyRouter :: Router+emptyRouter = Router Map.empty []++-- | Whether a pattern segment is a literal or a capture placeholder.+--+-- The 'Ord' instance puts 'Literal' before 'Capture', so when patterns+-- are compared segment-by-segment a literal wins over a capture at the+-- same position. This is what makes literal paths match before+-- conflicting capture paths.+data Specificity = Literal | Capture+  deriving (Eq, Ord, Show)++-- | Add a bound handler as a new route to the router.+--+-- Within each prefix bucket the handler list is kept sorted by+-- specificity. Routes with more literal segments (and literals at+-- earlier positions) come first, so e.g. @/api/articles/feed@ is+-- always tried before @/api/articles/{slug}@ regardless of+-- declaration order.+addRoute :: BoundHandler -> Router -> Router+addRoute bh (Router bySegs wild) =+  case firstLiteral (bhPattern bh) of+    Just seg -> Router (Map.alter insertOrCreate seg bySegs) wild+    Nothing  -> Router bySegs (insertBySpec bh wild)+  where+    insertOrCreate Nothing   = Just [bh]+    insertOrCreate (Just bs) = Just (insertBySpec bh bs)++-- | Insert into a bucket sorted by pattern specificity (most specific+-- first). For routes of equal specificity the newly inserted handler+-- goes before existing ones, preserving the historical+-- "newer-overrides-older" behavior within a tie.+insertBySpec :: BoundHandler -> [BoundHandler] -> [BoundHandler]+insertBySpec = insertBy (comparing (patternSpecificity . bhPattern))++-- | Compute a pattern's specificity as a list of segment kinds.+--+-- Compared lexicographically with 'Literal' < 'Capture', so a more+-- specific pattern (more literals at earlier positions) sorts before+-- a less specific one.+patternSpecificity :: Text -> [Specificity]+patternSpecificity pat =+  map segKind $ filter (/= "") $ T.splitOn "/" pat+  where+    segKind seg+      | T.isPrefixOf "{" seg = Capture+      | otherwise            = Literal++-- | Extract the first literal segment from a pattern like "/users/{capture}".+firstLiteral :: Text -> Maybe Text+firstLiteral pat =+  case filter (/= "") $ T.splitOn "/" pat of+    (seg : _) | not (T.isPrefixOf "{" seg) -> Just seg+    _ -> Nothing+++-- | Inject captured text segments into extensions.+injectCaptures :: [Text] -> Extensions -> IO ()+injectCaptures caps exts = insertExtension (CaptureList caps) exts+++-- | Dispatch a request through the router.+--+-- First looks up the first path segment in the index (O(log n)).+-- Falls back to wildcard routes if no indexed match.+dispatch :: Router -> Request ByteString -> IO (Response ByteString)+dispatch router req = do+  let segments = requestPath req+      method   = requestMethod req+      (parts, body) = splitRequest req+      -- Look up candidates by first segment+      candidates = case segments of+        (seg : _) -> Map.findWithDefault [] seg (riBySegment router)+                     ++ riWildcard router+        []        -> riWildcard router+  go candidates segments method parts body False+  where+    go [] _segs _method _parts _body methodMatched+      | methodMatched = pure (Response status405 [] "Method Not Allowed")+      | otherwise     = pure (Response status404 [] "Not Found")++    go (bh : rest) segs method parts body methodMatched =+      case bhMatchFn bh segs of+        Just (MatchResult caps) ->+          if bhMethod bh == method+          then do+            injectCaptures caps (rpExtensions parts)+            insertExtension (BodyBytes body) (rpExtensions parts)+            insertExtension (MatchedPath (bhPattern bh)) (rpExtensions parts)+            insertExtension (OriginalUri (rpPathRaw parts)) (rpExtensions parts)+            bhHandler bh parts body+          else+            go rest segs method parts body True+        Nothing ->+          go rest segs method parts body methodMatched+++-- | Build a spire Service from a router.+serve :: Router -> Service IO (Request ByteString) (Response ByteString)+serve router = Service (dispatch router)+++-- | Build a service with shared state injected into every request.+serveWithState+  :: Typeable s+  => s -> Router -> Service IO (Request ByteString) (Response ByteString)+serveWithState state router = Service $ \req -> do+  insertExtension (AppState state) (requestExtensions req)+  dispatch router req

@@ -0,0 +1,175 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Streaming handler support: SSE, chunked responses, and bidirectional streams.+--+-- Server-Sent Events (SSE) for 'ServerStream' endpoints:+--+-- @+-- handler :: (SSEvent Item -> IO ()) -> IO ()+-- handler emit = do+--   items <- loadItems+--   mapM_ (\i -> emit (SSEvent (Json i) Nothing Nothing)) items+-- @+--+-- Chunked request bodies for 'ClientStream' endpoints:+--+-- @+-- handler :: IO (Maybe ByteString) -> IO (Json Summary)+-- handler readChunk = do+--   chunks <- collectChunks readChunk+--   pure (Json (summarize chunks))+-- @+--+-- Bidirectional via WebSocket for 'BidiStream' endpoints:+--+-- @+-- handler :: IO (Maybe Msg) -> (Msg -> IO ()) -> IO ()+-- handler recv send = do+--   mmsg <- recv+--   case mmsg of+--     Just msg -> send (process msg) >> handler recv send+--     Nothing  -> pure ()+-- @+module Acolyte.Server.Streaming+  ( -- * Server-Sent Events+    SSEvent (..)+  , sseEvent+  , sseData+    -- * Streaming handler types+  , ServerStreamHandler+  , ClientStreamHandler+  , BidiStreamHandler+    -- * SSE response builders+  , sseResponse+  , sseResponseSync+  , sseChunk+  ) where++import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Data.IORef+import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.MVar+import Network.HTTP.Types (status200)++import qualified Data.Aeson as Aeson++import Http.Core (Response (..))+import Http.Core.Body (Body (..), BodyChunk (..), streamBody)+++-- | A Server-Sent Event.+--+-- @+-- SSEvent { ssePayload = Json item, sseId = Just "1", sseEventType = Nothing }+-- @+data SSEvent a = SSEvent+  { ssePayload   :: !a+  , sseId        :: !(Maybe Text)+  , sseEventType :: !(Maybe Text)+  }++-- | Convenience: data-only SSE (no id or event type).+sseData :: a -> SSEvent a+sseData a = SSEvent a Nothing Nothing++-- | Convenience: SSE with an event type.+sseEvent :: Text -> a -> SSEvent a+sseEvent typ a = SSEvent a Nothing (Just typ)+++-- | A handler that pushes server-sent events to the client.+-- Receives an emit function and calls it for each event.+type ServerStreamHandler a = (SSEvent a -> IO ()) -> IO ()++-- | A handler that reads chunks from a client upload.+-- Receives a pull function that returns Nothing at end-of-stream.+type ClientStreamHandler a r = (IO (Maybe a) -> IO r)++-- | A handler that reads from the client and writes to the client.+-- Receives pull (read) and push (write) functions.+type BidiStreamHandler a b = IO (Maybe a) -> (b -> IO ()) -> IO ()+++-- | Encode an SSEvent as an SSE-format ByteString chunk.+sseChunk :: Aeson.ToJSON a => SSEvent a -> ByteString+sseChunk ev = BS.concat $ concat+  [ case sseEventType ev of+      Nothing  -> []+      Just typ -> ["event: ", TE.encodeUtf8 typ, "\n"]+  , case sseId ev of+      Nothing -> []+      Just i  -> ["id: ", TE.encodeUtf8 i, "\n"]+  , ["data: ", LBS.toStrict (Aeson.encode (ssePayload ev)), "\n\n"]+  ]+++-- | Build a streaming 'Response Body' from a 'ServerStreamHandler'.+--+-- The handler runs concurrently in a forked thread, and events are+-- delivered to the response stream as they are produced. This enables+-- true server-push: the client receives events incrementally rather+-- than all at once after the handler completes.+--+-- Sets @Content-Type: text/event-stream@ and produces a 'BodyStream'+-- that emits SSE-formatted chunks. The spire-server layer renders+-- this with @Transfer-Encoding: chunked@.+sseResponse :: Aeson.ToJSON a => ServerStreamHandler a -> IO (Response Body)+sseResponse handler = do+  -- MVar-based queue: handler writes chunks, response stream reads them.+  -- Nothing signals end-of-stream.+  queue <- newEmptyMVar :: IO (MVar (Maybe ByteString))++  -- Fork the handler so events stream as they are produced+  _ <- forkIO $ do+    handler (\ev -> putMVar queue (Just (sseChunk ev)))+    putMVar queue Nothing  -- signal completion++  let pull = do+        mChunk <- takeMVar queue+        case mChunk of+          Nothing -> pure Nothing+          Just c  -> pure (Just (Chunk c))++  let headers =+        [ ("Content-Type", "text/event-stream")+        , ("Cache-Control", "no-cache")+        , ("Connection", "keep-alive")+        ]++  pure (Response status200 headers (BodyStream pull))+++-- | Build a streaming 'Response Body' synchronously.+--+-- Runs the handler to completion, collects all events, then serves+-- them from an in-memory list. Useful for simple cases where all+-- events are known upfront and no concurrent streaming is needed.+sseResponseSync :: Aeson.ToJSON a => ServerStreamHandler a -> IO (Response Body)+sseResponseSync handler = do+  ref <- newIORef ([] :: [ByteString])++  let emit ev = modifyIORef' ref (++ [sseChunk ev])+  handler emit++  chunks <- readIORef ref+  chunksRef <- newIORef chunks++  let pull = do+        cs <- readIORef chunksRef+        case cs of+          []     -> pure Nothing+          (c:rest) -> do+            writeIORef chunksRef rest+            pure (Just (Chunk c))++  let headers =+        [ ("Content-Type", "text/event-stream")+        , ("Cache-Control", "no-cache")+        , ("Connection", "keep-alive")+        ]++  pure (Response status200 headers (BodyStream pull))

@@ -0,0 +1,70 @@+-- | Ergonomic handler conversion.+--+-- 'ToHandler' converts typed handler functions into the internal+-- 'HandlerFn' representation. Instead of writing:+--+-- @+-- getUserHandler :: HandlerFn+-- getUserHandler parts _body = do+--   mCaps <- lookupExtension \@CaptureList (rpExtensions parts)+--   case mCaps of+--     Just (CaptureList (idText : _)) ->+--       case parseCapture \@Int idText of ...+-- @+--+-- You write:+--+-- @+-- getUserHandler :: PathCapture Int -> IO (Json Text)+-- getUserHandler (PathCapture uid) = pure (Json (T.pack ("user-" ++ show uid)))+-- @+--+-- 'ToHandler' recursively peels arguments from left to right. Each+-- argument must have a 'FromRequestParts' instance. The final return+-- type must be @IO r@ where @r@ has an 'IntoResponse' instance.+module Acolyte.Server.ToHandler+  ( ToHandler (..)+  ) where++import Data.ByteString (ByteString)++import Http.Core (RequestParts (..), Response)+import Acolyte.Server.Extract (FromRequestParts (..))+import Acolyte.Server.Response (IntoResponse (..))+import Acolyte.Server.Handler (HandlerFn)+++-- | Convert a typed handler function into a 'HandlerFn'.+--+-- @+-- -- No arguments:+-- health :: IO Text+--+-- -- One extractor:+-- getUser :: PathCapture Int -> IO (Json User)+--+-- -- Multiple extractors:+-- search :: QueryParam "q" Text -> OptionalParam "page" Int -> IO (Json [Result])+--+-- -- Body extractor:+-- create :: JsonBody CreateReq -> IO (Json Item)+--+-- -- Mixed:+-- update :: PathCapture Int -> JsonBody UpdateReq -> IO (Json Item)+-- @+class ToHandler f where+  toHandler :: f -> HandlerFn+++-- | Base case: @IO r@ with no arguments.+instance {-# OVERLAPPING #-} IntoResponse r => ToHandler (IO r) where+  toHandler action _parts _body = intoResponse <$> action+++-- | Recursive case: peel one 'FromRequestParts' argument.+instance (FromRequestParts a, ToHandler rest) => ToHandler (a -> rest) where+  toHandler f parts body = do+    ea <- fromRequestParts parts+    case ea of+      Left err -> pure (intoResponse err)+      Right a  -> toHandler (f a) parts body

@@ -0,0 +1,83 @@+-- | Runtime request validation middleware.+--+-- Validates incoming requests against the API type before they reach+-- handlers: correct method for matched path, path actually matches+-- a known route. Rejects non-matching requests with 400/404 before+-- handler dispatch.+--+-- @+-- svc |> validationLayer @MyAPI+-- @+module Acolyte.Server.Validate+  ( -- * Validation middleware+    validationLayer+    -- * Route table+  , RouteInfo (..)+  , BuildRouteTable (..)+  ) where++import Data.ByteString (ByteString)+import Data.Kind (Type)+import Data.Text (Text)+import qualified Data.Text as T+import Network.HTTP.Types (status404, status405)++import Spire (Middleware, middleware)+import Spire.Service (Service (..))+import Http.Core (Request (..), Response (..))++import Acolyte.Server.Handler (HasEndpointInfo (..), MatchResult (..))+++-- | Info about a single route for validation.+data RouteInfo = RouteInfo+  { riMethod  :: !ByteString+  , riPattern :: !Text+  , riMatcher :: [Text] -> Maybe MatchResult+  }+++-- | Build a route table from an API type.+class BuildRouteTable (api :: [Type]) where+  routeTable :: [RouteInfo]++instance BuildRouteTable '[] where+  routeTable = []++instance (HasEndpointInfo e, BuildRouteTable rest)+  => BuildRouteTable (e ': rest) where+    routeTable = RouteInfo+      { riMethod  = endpointMethod @e+      , riPattern = endpointPattern @e+      , riMatcher = endpointMatcher @e+      } : routeTable @rest+++-- | Validation middleware that rejects requests not matching the API.+--+-- Checks:+-- 1. Path matches at least one endpoint → if not, 404+-- 2. Method matches for the matched path → if not, 405+--+-- This runs BEFORE the router, catching obviously invalid requests+-- early (useful when the router has fallback behavior or when you+-- want a strict "only defined routes" policy).+validationLayer+  :: forall api. BuildRouteTable api+  => Middleware IO (Request ByteString) (Response ByteString)+validationLayer = middleware $ \(Service inner) -> Service $ \req -> do+  let segments = requestPath req+      method   = requestMethod req+      routes   = routeTable @api+      pathMatches = [ ri | ri <- routes, isJust (riMatcher ri segments) ]+  case pathMatches of+    [] -> pure (Response status404 [] "Not Found: no route matches this path")+    matches ->+      if any (\ri -> riMethod ri == method) matches+      then inner req  -- valid: let it through+      else pure (Response status405 [] "Method Not Allowed")+++isJust :: Maybe a -> Bool+isJust (Just _) = True+isJust Nothing  = False

@@ -0,0 +1,375 @@+-- | Automatic handler wiring: connect handler tuples to API types.+--+-- 'BuildServer' walks a type-level API list and a handler tuple in+-- lockstep, building a 'Router' with one 'BoundHandler' per endpoint.+--+-- @+-- type API = '[ Get HealthPath Text, Get UserByIdPath (Json User) ]+--+-- svc = mkServer @API+--   ( mkHandler0 (pure ("ok" :: Text))+--   , mkHandler1Parts (\(PathCapture uid) -> pure (Json (lookupUser uid)))+--   )+-- @+--+-- The 'Serves' constraint from the core ensures the tuple length+-- matches. 'BuildServer' additionally requires 'HasEndpointInfo'+-- for each endpoint to extract routing metadata.+module Acolyte.Server.Wiring+  ( -- * Server construction+    mkServer+    -- * Simplified server construction (no wrapHandler needed)+  , mkServerWith+  , BuildHandlers (..)+    -- * Handler wrapping+  , WrappedHandler (..)+  , wrapHandler+  , handle  -- shorter alias+    -- * BuildServer class (internal)+  , BuildServer (..)+  ) where++import Data.Kind (Type)+import Data.ByteString (ByteString)+import Data.Text (Text)++import Spire.Service (Service (..))+import Http.Core (Request, Response)++import Acolyte.Core.API (Serves)+import Acolyte.Server.Handler+import Acolyte.Server.Router (Router, emptyRouter, addRoute, serve)+++-- | A type-erased handler paired with a phantom endpoint type.+-- Users create these with 'wrapHandler'.+data WrappedHandler endpoint = WrappedHandler+  { whHandler :: !HandlerFn+  }+++-- | Wrap a HandlerFn for a specific endpoint type.+--+-- @+-- wrapHandler @(Get HealthPath Text) (mkHandler0 (pure "ok"))+-- @+wrapHandler :: forall endpoint. HandlerFn -> WrappedHandler endpoint+wrapHandler = WrappedHandler++-- | Short alias for 'wrapHandler'.+handle :: forall endpoint. HandlerFn -> WrappedHandler endpoint+handle = WrappedHandler+{-# INLINE handle #-}+++-- | Build a server from an API type and a plain tuple of HandlerFns.+--+-- No 'wrapHandler' needed — the handler functions are positionally+-- matched to endpoints in the API type.+--+-- @+-- mkServerWith @MyAPI (health, listUsers, getUser)+-- @+--+-- where each element is a 'HandlerFn' (not a 'WrappedHandler').+mkServerWith+  :: forall api handlers wrapped+   . (BuildHandlers api handlers wrapped, Serves api wrapped, BuildServer api wrapped)+  => handlers+  -> Service IO (Request ByteString) (Response ByteString)+mkServerWith handlers = serve (buildRouter @api (buildHandlers @api handlers) emptyRouter)+++-- | Convert a tuple of plain HandlerFns to a tuple of WrappedHandlers,+-- matching each position to the corresponding endpoint in the API.+class BuildHandlers (api :: [Type]) handlers wrapped | api handlers -> wrapped where+  buildHandlers :: handlers -> wrapped++-- Arity 1+instance BuildHandlers '[e1] HandlerFn (WrappedHandler e1) where+  buildHandlers h = WrappedHandler h++-- Arity 2+instance BuildHandlers '[e1, e2]+    (HandlerFn, HandlerFn)+    (WrappedHandler e1, WrappedHandler e2) where+  buildHandlers (h1, h2) = (WrappedHandler h1, WrappedHandler h2)++-- Arity 3+instance BuildHandlers '[e1, e2, e3]+    (HandlerFn, HandlerFn, HandlerFn)+    (WrappedHandler e1, WrappedHandler e2, WrappedHandler e3) where+  buildHandlers (h1, h2, h3) = (WrappedHandler h1, WrappedHandler h2, WrappedHandler h3)++-- Arity 4+instance BuildHandlers '[e1, e2, e3, e4]+    (HandlerFn, HandlerFn, HandlerFn, HandlerFn)+    (WrappedHandler e1, WrappedHandler e2, WrappedHandler e3, WrappedHandler e4) where+  buildHandlers (h1, h2, h3, h4) = (WrappedHandler h1, WrappedHandler h2, WrappedHandler h3, WrappedHandler h4)++-- Arity 5+instance BuildHandlers '[e1, e2, e3, e4, e5]+    (HandlerFn, HandlerFn, HandlerFn, HandlerFn, HandlerFn)+    (WrappedHandler e1, WrappedHandler e2, WrappedHandler e3, WrappedHandler e4, WrappedHandler e5) where+  buildHandlers (h1, h2, h3, h4, h5) = (WrappedHandler h1, WrappedHandler h2, WrappedHandler h3, WrappedHandler h4, WrappedHandler h5)++-- Arity 6+instance BuildHandlers '[e1, e2, e3, e4, e5, e6]+    (HandlerFn, HandlerFn, HandlerFn, HandlerFn, HandlerFn, HandlerFn)+    (WrappedHandler e1, WrappedHandler e2, WrappedHandler e3, WrappedHandler e4, WrappedHandler e5, WrappedHandler e6) where+  buildHandlers (h1, h2, h3, h4, h5, h6) = (WrappedHandler h1, WrappedHandler h2, WrappedHandler h3, WrappedHandler h4, WrappedHandler h5, WrappedHandler h6)++-- Arity 7+instance BuildHandlers '[e1, e2, e3, e4, e5, e6, e7]+    (HandlerFn, HandlerFn, HandlerFn, HandlerFn, HandlerFn, HandlerFn, HandlerFn)+    (WrappedHandler e1, WrappedHandler e2, WrappedHandler e3, WrappedHandler e4, WrappedHandler e5, WrappedHandler e6, WrappedHandler e7) where+  buildHandlers (h1, h2, h3, h4, h5, h6, h7) = (WrappedHandler h1, WrappedHandler h2, WrappedHandler h3, WrappedHandler h4, WrappedHandler h5, WrappedHandler h6, WrappedHandler h7)++-- Arity 8+instance BuildHandlers '[e1, e2, e3, e4, e5, e6, e7, e8]+    (HandlerFn, HandlerFn, HandlerFn, HandlerFn, HandlerFn, HandlerFn, HandlerFn, HandlerFn)+    (WrappedHandler e1, WrappedHandler e2, WrappedHandler e3, WrappedHandler e4, WrappedHandler e5, WrappedHandler e6, WrappedHandler e7, WrappedHandler e8) where+  buildHandlers (h1, h2, h3, h4, h5, h6, h7, h8) = (WrappedHandler h1, WrappedHandler h2, WrappedHandler h3, WrappedHandler h4, WrappedHandler h5, WrappedHandler h6, WrappedHandler h7, WrappedHandler h8)+++-- | Build a server from an API type and handler tuple.+--+-- @+-- mkServer @API (handler1, handler2, handler3)+-- @+--+-- The 'Serves' constraint checks tuple length. 'BuildServer' does+-- the runtime wiring.+mkServer+  :: forall api handlers+   . (Serves api handlers, BuildServer api handlers)+  => handlers+  -> Service IO (Request ByteString) (Response ByteString)+mkServer handlers = serve (buildRouter @api handlers emptyRouter)+++-- | Class that walks the API list and handler tuple, populating a Router.+class BuildServer (api :: [Type]) handlers where+  buildRouter :: handlers -> Router -> Router+++-- Arity 1+instance HasEndpointInfo e1+  => BuildServer '[e1] (WrappedHandler e1) where+  buildRouter h router =+    addRoute (mkBound @e1 h) router++-- Arity 2+instance (HasEndpointInfo e1, HasEndpointInfo e2)+  => BuildServer '[e1, e2] (WrappedHandler e1, WrappedHandler e2) where+  buildRouter (h1, h2) router =+    addRoute (mkBound @e2 h2)+    . addRoute (mkBound @e1 h1)+    $ router++-- Arity 3+instance (HasEndpointInfo e1, HasEndpointInfo e2, HasEndpointInfo e3)+  => BuildServer '[e1, e2, e3] (WrappedHandler e1, WrappedHandler e2, WrappedHandler e3) where+  buildRouter (h1, h2, h3) router =+    addRoute (mkBound @e3 h3)+    . addRoute (mkBound @e2 h2)+    . addRoute (mkBound @e1 h1)+    $ router++-- Arity 4+instance (HasEndpointInfo e1, HasEndpointInfo e2, HasEndpointInfo e3, HasEndpointInfo e4)+  => BuildServer '[e1, e2, e3, e4]+       (WrappedHandler e1, WrappedHandler e2, WrappedHandler e3, WrappedHandler e4) where+  buildRouter (h1, h2, h3, h4) router =+    addRoute (mkBound @e4 h4)+    . addRoute (mkBound @e3 h3)+    . addRoute (mkBound @e2 h2)+    . addRoute (mkBound @e1 h1)+    $ router++-- Arity 5+instance (HasEndpointInfo e1, HasEndpointInfo e2, HasEndpointInfo e3, HasEndpointInfo e4, HasEndpointInfo e5)+  => BuildServer '[e1, e2, e3, e4, e5]+       (WrappedHandler e1, WrappedHandler e2, WrappedHandler e3, WrappedHandler e4, WrappedHandler e5) where+  buildRouter (h1, h2, h3, h4, h5) router =+    addRoute (mkBound @e5 h5)+    . addRoute (mkBound @e4 h4)+    . addRoute (mkBound @e3 h3)+    . addRoute (mkBound @e2 h2)+    . addRoute (mkBound @e1 h1)+    $ router++-- Arities 6-16 follow the same pattern. Adding up to 8 for now.++-- Arity 6+instance (HasEndpointInfo e1, HasEndpointInfo e2, HasEndpointInfo e3, HasEndpointInfo e4, HasEndpointInfo e5, HasEndpointInfo e6)+  => BuildServer '[e1, e2, e3, e4, e5, e6]+       (WrappedHandler e1, WrappedHandler e2, WrappedHandler e3, WrappedHandler e4, WrappedHandler e5, WrappedHandler e6) where+  buildRouter (h1, h2, h3, h4, h5, h6) router =+    addRoute (mkBound @e6 h6)+    . addRoute (mkBound @e5 h5)+    . addRoute (mkBound @e4 h4)+    . addRoute (mkBound @e3 h3)+    . addRoute (mkBound @e2 h2)+    . addRoute (mkBound @e1 h1)+    $ router++-- Arity 7+instance (HasEndpointInfo e1, HasEndpointInfo e2, HasEndpointInfo e3, HasEndpointInfo e4, HasEndpointInfo e5, HasEndpointInfo e6, HasEndpointInfo e7)+  => BuildServer '[e1, e2, e3, e4, e5, e6, e7]+       (WrappedHandler e1, WrappedHandler e2, WrappedHandler e3, WrappedHandler e4, WrappedHandler e5, WrappedHandler e6, WrappedHandler e7) where+  buildRouter (h1, h2, h3, h4, h5, h6, h7) router =+    addRoute (mkBound @e7 h7)+    . addRoute (mkBound @e6 h6)+    . addRoute (mkBound @e5 h5)+    . addRoute (mkBound @e4 h4)+    . addRoute (mkBound @e3 h3)+    . addRoute (mkBound @e2 h2)+    . addRoute (mkBound @e1 h1)+    $ router++-- Arity 8+instance (HasEndpointInfo e1, HasEndpointInfo e2, HasEndpointInfo e3, HasEndpointInfo e4, HasEndpointInfo e5, HasEndpointInfo e6, HasEndpointInfo e7, HasEndpointInfo e8)+  => BuildServer '[e1, e2, e3, e4, e5, e6, e7, e8]+       (WrappedHandler e1, WrappedHandler e2, WrappedHandler e3, WrappedHandler e4, WrappedHandler e5, WrappedHandler e6, WrappedHandler e7, WrappedHandler e8) where+  buildRouter (h1, h2, h3, h4, h5, h6, h7, h8) router =+    addRoute (mkBound @e8 h8)+    . addRoute (mkBound @e7 h7)+    . addRoute (mkBound @e6 h6)+    . addRoute (mkBound @e5 h5)+    . addRoute (mkBound @e4 h4)+    . addRoute (mkBound @e3 h3)+    . addRoute (mkBound @e2 h2)+    . addRoute (mkBound @e1 h1)+    $ router+++-- Arity 9+instance (HasEndpointInfo e1, HasEndpointInfo e2, HasEndpointInfo e3, HasEndpointInfo e4, HasEndpointInfo e5, HasEndpointInfo e6, HasEndpointInfo e7, HasEndpointInfo e8, HasEndpointInfo e9)+  => BuildServer '[e1, e2, e3, e4, e5, e6, e7, e8, e9]+       (WrappedHandler e1, WrappedHandler e2, WrappedHandler e3, WrappedHandler e4, WrappedHandler e5, WrappedHandler e6, WrappedHandler e7, WrappedHandler e8, WrappedHandler e9) where+  buildRouter (h1, h2, h3, h4, h5, h6, h7, h8, h9) router =+    addRoute (mkBound @e9 h9) . addRoute (mkBound @e8 h8) . addRoute (mkBound @e7 h7) . addRoute (mkBound @e6 h6) . addRoute (mkBound @e5 h5) . addRoute (mkBound @e4 h4) . addRoute (mkBound @e3 h3) . addRoute (mkBound @e2 h2) . addRoute (mkBound @e1 h1) $ router++-- Arity 10+instance (HasEndpointInfo e1, HasEndpointInfo e2, HasEndpointInfo e3, HasEndpointInfo e4, HasEndpointInfo e5, HasEndpointInfo e6, HasEndpointInfo e7, HasEndpointInfo e8, HasEndpointInfo e9, HasEndpointInfo e10)+  => BuildServer '[e1, e2, e3, e4, e5, e6, e7, e8, e9, e10]+       (WrappedHandler e1, WrappedHandler e2, WrappedHandler e3, WrappedHandler e4, WrappedHandler e5, WrappedHandler e6, WrappedHandler e7, WrappedHandler e8, WrappedHandler e9, WrappedHandler e10) where+  buildRouter (h1, h2, h3, h4, h5, h6, h7, h8, h9, h10) router =+    addRoute (mkBound @e10 h10) . addRoute (mkBound @e9 h9) . addRoute (mkBound @e8 h8) . addRoute (mkBound @e7 h7) . addRoute (mkBound @e6 h6) . addRoute (mkBound @e5 h5) . addRoute (mkBound @e4 h4) . addRoute (mkBound @e3 h3) . addRoute (mkBound @e2 h2) . addRoute (mkBound @e1 h1) $ router++-- Arity 11+instance (HasEndpointInfo e1, HasEndpointInfo e2, HasEndpointInfo e3, HasEndpointInfo e4, HasEndpointInfo e5, HasEndpointInfo e6, HasEndpointInfo e7, HasEndpointInfo e8, HasEndpointInfo e9, HasEndpointInfo e10, HasEndpointInfo e11)+  => BuildServer '[e1, e2, e3, e4, e5, e6, e7, e8, e9, e10, e11]+       (WrappedHandler e1, WrappedHandler e2, WrappedHandler e3, WrappedHandler e4, WrappedHandler e5, WrappedHandler e6, WrappedHandler e7, WrappedHandler e8, WrappedHandler e9, WrappedHandler e10, WrappedHandler e11) where+  buildRouter (h1, h2, h3, h4, h5, h6, h7, h8, h9, h10, h11) router =+    addRoute (mkBound @e11 h11) . addRoute (mkBound @e10 h10) . addRoute (mkBound @e9 h9) . addRoute (mkBound @e8 h8) . addRoute (mkBound @e7 h7) . addRoute (mkBound @e6 h6) . addRoute (mkBound @e5 h5) . addRoute (mkBound @e4 h4) . addRoute (mkBound @e3 h3) . addRoute (mkBound @e2 h2) . addRoute (mkBound @e1 h1) $ router++-- Arity 12+instance (HasEndpointInfo e1, HasEndpointInfo e2, HasEndpointInfo e3, HasEndpointInfo e4, HasEndpointInfo e5, HasEndpointInfo e6, HasEndpointInfo e7, HasEndpointInfo e8, HasEndpointInfo e9, HasEndpointInfo e10, HasEndpointInfo e11, HasEndpointInfo e12)+  => BuildServer '[e1, e2, e3, e4, e5, e6, e7, e8, e9, e10, e11, e12]+       (WrappedHandler e1, WrappedHandler e2, WrappedHandler e3, WrappedHandler e4, WrappedHandler e5, WrappedHandler e6, WrappedHandler e7, WrappedHandler e8, WrappedHandler e9, WrappedHandler e10, WrappedHandler e11, WrappedHandler e12) where+  buildRouter (h1, h2, h3, h4, h5, h6, h7, h8, h9, h10, h11, h12) router =+    addRoute (mkBound @e12 h12) . addRoute (mkBound @e11 h11) . addRoute (mkBound @e10 h10) . addRoute (mkBound @e9 h9) . addRoute (mkBound @e8 h8) . addRoute (mkBound @e7 h7) . addRoute (mkBound @e6 h6) . addRoute (mkBound @e5 h5) . addRoute (mkBound @e4 h4) . addRoute (mkBound @e3 h3) . addRoute (mkBound @e2 h2) . addRoute (mkBound @e1 h1) $ router++-- Arity 13+instance (HasEndpointInfo e1, HasEndpointInfo e2, HasEndpointInfo e3, HasEndpointInfo e4, HasEndpointInfo e5, HasEndpointInfo e6, HasEndpointInfo e7, HasEndpointInfo e8, HasEndpointInfo e9, HasEndpointInfo e10, HasEndpointInfo e11, HasEndpointInfo e12, HasEndpointInfo e13)+  => BuildServer '[e1, e2, e3, e4, e5, e6, e7, e8, e9, e10, e11, e12, e13]+       (WrappedHandler e1, WrappedHandler e2, WrappedHandler e3, WrappedHandler e4, WrappedHandler e5, WrappedHandler e6, WrappedHandler e7, WrappedHandler e8, WrappedHandler e9, WrappedHandler e10, WrappedHandler e11, WrappedHandler e12, WrappedHandler e13) where+  buildRouter (h1, h2, h3, h4, h5, h6, h7, h8, h9, h10, h11, h12, h13) router =+    addRoute (mkBound @e13 h13) . addRoute (mkBound @e12 h12) . addRoute (mkBound @e11 h11) . addRoute (mkBound @e10 h10) . addRoute (mkBound @e9 h9) . addRoute (mkBound @e8 h8) . addRoute (mkBound @e7 h7) . addRoute (mkBound @e6 h6) . addRoute (mkBound @e5 h5) . addRoute (mkBound @e4 h4) . addRoute (mkBound @e3 h3) . addRoute (mkBound @e2 h2) . addRoute (mkBound @e1 h1) $ router++-- Arity 14+instance (HasEndpointInfo e1, HasEndpointInfo e2, HasEndpointInfo e3, HasEndpointInfo e4, HasEndpointInfo e5, HasEndpointInfo e6, HasEndpointInfo e7, HasEndpointInfo e8, HasEndpointInfo e9, HasEndpointInfo e10, HasEndpointInfo e11, HasEndpointInfo e12, HasEndpointInfo e13, HasEndpointInfo e14)+  => BuildServer '[e1, e2, e3, e4, e5, e6, e7, e8, e9, e10, e11, e12, e13, e14]+       (WrappedHandler e1, WrappedHandler e2, WrappedHandler e3, WrappedHandler e4, WrappedHandler e5, WrappedHandler e6, WrappedHandler e7, WrappedHandler e8, WrappedHandler e9, WrappedHandler e10, WrappedHandler e11, WrappedHandler e12, WrappedHandler e13, WrappedHandler e14) where+  buildRouter (h1, h2, h3, h4, h5, h6, h7, h8, h9, h10, h11, h12, h13, h14) router =+    addRoute (mkBound @e14 h14) . addRoute (mkBound @e13 h13) . addRoute (mkBound @e12 h12) . addRoute (mkBound @e11 h11) . addRoute (mkBound @e10 h10) . addRoute (mkBound @e9 h9) . addRoute (mkBound @e8 h8) . addRoute (mkBound @e7 h7) . addRoute (mkBound @e6 h6) . addRoute (mkBound @e5 h5) . addRoute (mkBound @e4 h4) . addRoute (mkBound @e3 h3) . addRoute (mkBound @e2 h2) . addRoute (mkBound @e1 h1) $ router++-- Arity 15+instance (HasEndpointInfo e1, HasEndpointInfo e2, HasEndpointInfo e3, HasEndpointInfo e4, HasEndpointInfo e5, HasEndpointInfo e6, HasEndpointInfo e7, HasEndpointInfo e8, HasEndpointInfo e9, HasEndpointInfo e10, HasEndpointInfo e11, HasEndpointInfo e12, HasEndpointInfo e13, HasEndpointInfo e14, HasEndpointInfo e15)+  => BuildServer '[e1, e2, e3, e4, e5, e6, e7, e8, e9, e10, e11, e12, e13, e14, e15]+       (WrappedHandler e1, WrappedHandler e2, WrappedHandler e3, WrappedHandler e4, WrappedHandler e5, WrappedHandler e6, WrappedHandler e7, WrappedHandler e8, WrappedHandler e9, WrappedHandler e10, WrappedHandler e11, WrappedHandler e12, WrappedHandler e13, WrappedHandler e14, WrappedHandler e15) where+  buildRouter (h1, h2, h3, h4, h5, h6, h7, h8, h9, h10, h11, h12, h13, h14, h15) router =+    addRoute (mkBound @e15 h15) . addRoute (mkBound @e14 h14) . addRoute (mkBound @e13 h13) . addRoute (mkBound @e12 h12) . addRoute (mkBound @e11 h11) . addRoute (mkBound @e10 h10) . addRoute (mkBound @e9 h9) . addRoute (mkBound @e8 h8) . addRoute (mkBound @e7 h7) . addRoute (mkBound @e6 h6) . addRoute (mkBound @e5 h5) . addRoute (mkBound @e4 h4) . addRoute (mkBound @e3 h3) . addRoute (mkBound @e2 h2) . addRoute (mkBound @e1 h1) $ router++-- Arity 16+instance (HasEndpointInfo e1, HasEndpointInfo e2, HasEndpointInfo e3, HasEndpointInfo e4, HasEndpointInfo e5, HasEndpointInfo e6, HasEndpointInfo e7, HasEndpointInfo e8, HasEndpointInfo e9, HasEndpointInfo e10, HasEndpointInfo e11, HasEndpointInfo e12, HasEndpointInfo e13, HasEndpointInfo e14, HasEndpointInfo e15, HasEndpointInfo e16)+  => BuildServer '[e1, e2, e3, e4, e5, e6, e7, e8, e9, e10, e11, e12, e13, e14, e15, e16]+       (WrappedHandler e1, WrappedHandler e2, WrappedHandler e3, WrappedHandler e4, WrappedHandler e5, WrappedHandler e6, WrappedHandler e7, WrappedHandler e8, WrappedHandler e9, WrappedHandler e10, WrappedHandler e11, WrappedHandler e12, WrappedHandler e13, WrappedHandler e14, WrappedHandler e15, WrappedHandler e16) where+  buildRouter (h1, h2, h3, h4, h5, h6, h7, h8, h9, h10, h11, h12, h13, h14, h15, h16) router =+    addRoute (mkBound @e16 h16) . addRoute (mkBound @e15 h15) . addRoute (mkBound @e14 h14) . addRoute (mkBound @e13 h13) . addRoute (mkBound @e12 h12) . addRoute (mkBound @e11 h11) . addRoute (mkBound @e10 h10) . addRoute (mkBound @e9 h9) . addRoute (mkBound @e8 h8) . addRoute (mkBound @e7 h7) . addRoute (mkBound @e6 h6) . addRoute (mkBound @e5 h5) . addRoute (mkBound @e4 h4) . addRoute (mkBound @e3 h3) . addRoute (mkBound @e2 h2) . addRoute (mkBound @e1 h1) $ router+++-- Arity 17+instance (HasEndpointInfo e1, HasEndpointInfo e2, HasEndpointInfo e3, HasEndpointInfo e4, HasEndpointInfo e5, HasEndpointInfo e6, HasEndpointInfo e7, HasEndpointInfo e8, HasEndpointInfo e9, HasEndpointInfo e10, HasEndpointInfo e11, HasEndpointInfo e12, HasEndpointInfo e13, HasEndpointInfo e14, HasEndpointInfo e15, HasEndpointInfo e16, HasEndpointInfo e17)+  => BuildServer '[e1, e2, e3, e4, e5, e6, e7, e8, e9, e10, e11, e12, e13, e14, e15, e16, e17]+       (WrappedHandler e1, WrappedHandler e2, WrappedHandler e3, WrappedHandler e4, WrappedHandler e5, WrappedHandler e6, WrappedHandler e7, WrappedHandler e8, WrappedHandler e9, WrappedHandler e10, WrappedHandler e11, WrappedHandler e12, WrappedHandler e13, WrappedHandler e14, WrappedHandler e15, WrappedHandler e16, WrappedHandler e17) where+  buildRouter (h1, h2, h3, h4, h5, h6, h7, h8, h9, h10, h11, h12, h13, h14, h15, h16, h17) router =+    addRoute (mkBound @e17 h17) . addRoute (mkBound @e16 h16) . addRoute (mkBound @e15 h15) . addRoute (mkBound @e14 h14) . addRoute (mkBound @e13 h13) . addRoute (mkBound @e12 h12) . addRoute (mkBound @e11 h11) . addRoute (mkBound @e10 h10) . addRoute (mkBound @e9 h9) . addRoute (mkBound @e8 h8) . addRoute (mkBound @e7 h7) . addRoute (mkBound @e6 h6) . addRoute (mkBound @e5 h5) . addRoute (mkBound @e4 h4) . addRoute (mkBound @e3 h3) . addRoute (mkBound @e2 h2) . addRoute (mkBound @e1 h1) $ router++-- Arity 18+instance (HasEndpointInfo e1, HasEndpointInfo e2, HasEndpointInfo e3, HasEndpointInfo e4, HasEndpointInfo e5, HasEndpointInfo e6, HasEndpointInfo e7, HasEndpointInfo e8, HasEndpointInfo e9, HasEndpointInfo e10, HasEndpointInfo e11, HasEndpointInfo e12, HasEndpointInfo e13, HasEndpointInfo e14, HasEndpointInfo e15, HasEndpointInfo e16, HasEndpointInfo e17, HasEndpointInfo e18)+  => BuildServer '[e1, e2, e3, e4, e5, e6, e7, e8, e9, e10, e11, e12, e13, e14, e15, e16, e17, e18]+       (WrappedHandler e1, WrappedHandler e2, WrappedHandler e3, WrappedHandler e4, WrappedHandler e5, WrappedHandler e6, WrappedHandler e7, WrappedHandler e8, WrappedHandler e9, WrappedHandler e10, WrappedHandler e11, WrappedHandler e12, WrappedHandler e13, WrappedHandler e14, WrappedHandler e15, WrappedHandler e16, WrappedHandler e17, WrappedHandler e18) where+  buildRouter (h1, h2, h3, h4, h5, h6, h7, h8, h9, h10, h11, h12, h13, h14, h15, h16, h17, h18) router =+    addRoute (mkBound @e18 h18) . addRoute (mkBound @e17 h17) . addRoute (mkBound @e16 h16) . addRoute (mkBound @e15 h15) . addRoute (mkBound @e14 h14) . addRoute (mkBound @e13 h13) . addRoute (mkBound @e12 h12) . addRoute (mkBound @e11 h11) . addRoute (mkBound @e10 h10) . addRoute (mkBound @e9 h9) . addRoute (mkBound @e8 h8) . addRoute (mkBound @e7 h7) . addRoute (mkBound @e6 h6) . addRoute (mkBound @e5 h5) . addRoute (mkBound @e4 h4) . addRoute (mkBound @e3 h3) . addRoute (mkBound @e2 h2) . addRoute (mkBound @e1 h1) $ router++-- Arity 19+instance (HasEndpointInfo e1, HasEndpointInfo e2, HasEndpointInfo e3, HasEndpointInfo e4, HasEndpointInfo e5, HasEndpointInfo e6, HasEndpointInfo e7, HasEndpointInfo e8, HasEndpointInfo e9, HasEndpointInfo e10, HasEndpointInfo e11, HasEndpointInfo e12, HasEndpointInfo e13, HasEndpointInfo e14, HasEndpointInfo e15, HasEndpointInfo e16, HasEndpointInfo e17, HasEndpointInfo e18, HasEndpointInfo e19)+  => BuildServer '[e1, e2, e3, e4, e5, e6, e7, e8, e9, e10, e11, e12, e13, e14, e15, e16, e17, e18, e19]+       (WrappedHandler e1, WrappedHandler e2, WrappedHandler e3, WrappedHandler e4, WrappedHandler e5, WrappedHandler e6, WrappedHandler e7, WrappedHandler e8, WrappedHandler e9, WrappedHandler e10, WrappedHandler e11, WrappedHandler e12, WrappedHandler e13, WrappedHandler e14, WrappedHandler e15, WrappedHandler e16, WrappedHandler e17, WrappedHandler e18, WrappedHandler e19) where+  buildRouter (h1, h2, h3, h4, h5, h6, h7, h8, h9, h10, h11, h12, h13, h14, h15, h16, h17, h18, h19) router =+    addRoute (mkBound @e19 h19) . addRoute (mkBound @e18 h18) . addRoute (mkBound @e17 h17) . addRoute (mkBound @e16 h16) . addRoute (mkBound @e15 h15) . addRoute (mkBound @e14 h14) . addRoute (mkBound @e13 h13) . addRoute (mkBound @e12 h12) . addRoute (mkBound @e11 h11) . addRoute (mkBound @e10 h10) . addRoute (mkBound @e9 h9) . addRoute (mkBound @e8 h8) . addRoute (mkBound @e7 h7) . addRoute (mkBound @e6 h6) . addRoute (mkBound @e5 h5) . addRoute (mkBound @e4 h4) . addRoute (mkBound @e3 h3) . addRoute (mkBound @e2 h2) . addRoute (mkBound @e1 h1) $ router++-- Arity 20+instance (HasEndpointInfo e1, HasEndpointInfo e2, HasEndpointInfo e3, HasEndpointInfo e4, HasEndpointInfo e5, HasEndpointInfo e6, HasEndpointInfo e7, HasEndpointInfo e8, HasEndpointInfo e9, HasEndpointInfo e10, HasEndpointInfo e11, HasEndpointInfo e12, HasEndpointInfo e13, HasEndpointInfo e14, HasEndpointInfo e15, HasEndpointInfo e16, HasEndpointInfo e17, HasEndpointInfo e18, HasEndpointInfo e19, HasEndpointInfo e20)+  => BuildServer '[e1, e2, e3, e4, e5, e6, e7, e8, e9, e10, e11, e12, e13, e14, e15, e16, e17, e18, e19, e20]+       (WrappedHandler e1, WrappedHandler e2, WrappedHandler e3, WrappedHandler e4, WrappedHandler e5, WrappedHandler e6, WrappedHandler e7, WrappedHandler e8, WrappedHandler e9, WrappedHandler e10, WrappedHandler e11, WrappedHandler e12, WrappedHandler e13, WrappedHandler e14, WrappedHandler e15, WrappedHandler e16, WrappedHandler e17, WrappedHandler e18, WrappedHandler e19, WrappedHandler e20) where+  buildRouter (h1, h2, h3, h4, h5, h6, h7, h8, h9, h10, h11, h12, h13, h14, h15, h16, h17, h18, h19, h20) router =+    addRoute (mkBound @e20 h20) . addRoute (mkBound @e19 h19) . addRoute (mkBound @e18 h18) . addRoute (mkBound @e17 h17) . addRoute (mkBound @e16 h16) . addRoute (mkBound @e15 h15) . addRoute (mkBound @e14 h14) . addRoute (mkBound @e13 h13) . addRoute (mkBound @e12 h12) . addRoute (mkBound @e11 h11) . addRoute (mkBound @e10 h10) . addRoute (mkBound @e9 h9) . addRoute (mkBound @e8 h8) . addRoute (mkBound @e7 h7) . addRoute (mkBound @e6 h6) . addRoute (mkBound @e5 h5) . addRoute (mkBound @e4 h4) . addRoute (mkBound @e3 h3) . addRoute (mkBound @e2 h2) . addRoute (mkBound @e1 h1) $ router++-- Arity 21+instance (HasEndpointInfo e1, HasEndpointInfo e2, HasEndpointInfo e3, HasEndpointInfo e4, HasEndpointInfo e5, HasEndpointInfo e6, HasEndpointInfo e7, HasEndpointInfo e8, HasEndpointInfo e9, HasEndpointInfo e10, HasEndpointInfo e11, HasEndpointInfo e12, HasEndpointInfo e13, HasEndpointInfo e14, HasEndpointInfo e15, HasEndpointInfo e16, HasEndpointInfo e17, HasEndpointInfo e18, HasEndpointInfo e19, HasEndpointInfo e20, HasEndpointInfo e21)+  => BuildServer '[e1, e2, e3, e4, e5, e6, e7, e8, e9, e10, e11, e12, e13, e14, e15, e16, e17, e18, e19, e20, e21]+       (WrappedHandler e1, WrappedHandler e2, WrappedHandler e3, WrappedHandler e4, WrappedHandler e5, WrappedHandler e6, WrappedHandler e7, WrappedHandler e8, WrappedHandler e9, WrappedHandler e10, WrappedHandler e11, WrappedHandler e12, WrappedHandler e13, WrappedHandler e14, WrappedHandler e15, WrappedHandler e16, WrappedHandler e17, WrappedHandler e18, WrappedHandler e19, WrappedHandler e20, WrappedHandler e21) where+  buildRouter (h1, h2, h3, h4, h5, h6, h7, h8, h9, h10, h11, h12, h13, h14, h15, h16, h17, h18, h19, h20, h21) router =+    addRoute (mkBound @e21 h21) . addRoute (mkBound @e20 h20) . addRoute (mkBound @e19 h19) . addRoute (mkBound @e18 h18) . addRoute (mkBound @e17 h17) . addRoute (mkBound @e16 h16) . addRoute (mkBound @e15 h15) . addRoute (mkBound @e14 h14) . addRoute (mkBound @e13 h13) . addRoute (mkBound @e12 h12) . addRoute (mkBound @e11 h11) . addRoute (mkBound @e10 h10) . addRoute (mkBound @e9 h9) . addRoute (mkBound @e8 h8) . addRoute (mkBound @e7 h7) . addRoute (mkBound @e6 h6) . addRoute (mkBound @e5 h5) . addRoute (mkBound @e4 h4) . addRoute (mkBound @e3 h3) . addRoute (mkBound @e2 h2) . addRoute (mkBound @e1 h1) $ router++-- Arity 22+instance (HasEndpointInfo e1, HasEndpointInfo e2, HasEndpointInfo e3, HasEndpointInfo e4, HasEndpointInfo e5, HasEndpointInfo e6, HasEndpointInfo e7, HasEndpointInfo e8, HasEndpointInfo e9, HasEndpointInfo e10, HasEndpointInfo e11, HasEndpointInfo e12, HasEndpointInfo e13, HasEndpointInfo e14, HasEndpointInfo e15, HasEndpointInfo e16, HasEndpointInfo e17, HasEndpointInfo e18, HasEndpointInfo e19, HasEndpointInfo e20, HasEndpointInfo e21, HasEndpointInfo e22)+  => BuildServer '[e1, e2, e3, e4, e5, e6, e7, e8, e9, e10, e11, e12, e13, e14, e15, e16, e17, e18, e19, e20, e21, e22]+       (WrappedHandler e1, WrappedHandler e2, WrappedHandler e3, WrappedHandler e4, WrappedHandler e5, WrappedHandler e6, WrappedHandler e7, WrappedHandler e8, WrappedHandler e9, WrappedHandler e10, WrappedHandler e11, WrappedHandler e12, WrappedHandler e13, WrappedHandler e14, WrappedHandler e15, WrappedHandler e16, WrappedHandler e17, WrappedHandler e18, WrappedHandler e19, WrappedHandler e20, WrappedHandler e21, WrappedHandler e22) where+  buildRouter (h1, h2, h3, h4, h5, h6, h7, h8, h9, h10, h11, h12, h13, h14, h15, h16, h17, h18, h19, h20, h21, h22) router =+    addRoute (mkBound @e22 h22) . addRoute (mkBound @e21 h21) . addRoute (mkBound @e20 h20) . addRoute (mkBound @e19 h19) . addRoute (mkBound @e18 h18) . addRoute (mkBound @e17 h17) . addRoute (mkBound @e16 h16) . addRoute (mkBound @e15 h15) . addRoute (mkBound @e14 h14) . addRoute (mkBound @e13 h13) . addRoute (mkBound @e12 h12) . addRoute (mkBound @e11 h11) . addRoute (mkBound @e10 h10) . addRoute (mkBound @e9 h9) . addRoute (mkBound @e8 h8) . addRoute (mkBound @e7 h7) . addRoute (mkBound @e6 h6) . addRoute (mkBound @e5 h5) . addRoute (mkBound @e4 h4) . addRoute (mkBound @e3 h3) . addRoute (mkBound @e2 h2) . addRoute (mkBound @e1 h1) $ router++-- Arity 23+instance (HasEndpointInfo e1, HasEndpointInfo e2, HasEndpointInfo e3, HasEndpointInfo e4, HasEndpointInfo e5, HasEndpointInfo e6, HasEndpointInfo e7, HasEndpointInfo e8, HasEndpointInfo e9, HasEndpointInfo e10, HasEndpointInfo e11, HasEndpointInfo e12, HasEndpointInfo e13, HasEndpointInfo e14, HasEndpointInfo e15, HasEndpointInfo e16, HasEndpointInfo e17, HasEndpointInfo e18, HasEndpointInfo e19, HasEndpointInfo e20, HasEndpointInfo e21, HasEndpointInfo e22, HasEndpointInfo e23)+  => BuildServer '[e1, e2, e3, e4, e5, e6, e7, e8, e9, e10, e11, e12, e13, e14, e15, e16, e17, e18, e19, e20, e21, e22, e23]+       (WrappedHandler e1, WrappedHandler e2, WrappedHandler e3, WrappedHandler e4, WrappedHandler e5, WrappedHandler e6, WrappedHandler e7, WrappedHandler e8, WrappedHandler e9, WrappedHandler e10, WrappedHandler e11, WrappedHandler e12, WrappedHandler e13, WrappedHandler e14, WrappedHandler e15, WrappedHandler e16, WrappedHandler e17, WrappedHandler e18, WrappedHandler e19, WrappedHandler e20, WrappedHandler e21, WrappedHandler e22, WrappedHandler e23) where+  buildRouter (h1, h2, h3, h4, h5, h6, h7, h8, h9, h10, h11, h12, h13, h14, h15, h16, h17, h18, h19, h20, h21, h22, h23) router =+    addRoute (mkBound @e23 h23) . addRoute (mkBound @e22 h22) . addRoute (mkBound @e21 h21) . addRoute (mkBound @e20 h20) . addRoute (mkBound @e19 h19) . addRoute (mkBound @e18 h18) . addRoute (mkBound @e17 h17) . addRoute (mkBound @e16 h16) . addRoute (mkBound @e15 h15) . addRoute (mkBound @e14 h14) . addRoute (mkBound @e13 h13) . addRoute (mkBound @e12 h12) . addRoute (mkBound @e11 h11) . addRoute (mkBound @e10 h10) . addRoute (mkBound @e9 h9) . addRoute (mkBound @e8 h8) . addRoute (mkBound @e7 h7) . addRoute (mkBound @e6 h6) . addRoute (mkBound @e5 h5) . addRoute (mkBound @e4 h4) . addRoute (mkBound @e3 h3) . addRoute (mkBound @e2 h2) . addRoute (mkBound @e1 h1) $ router++-- Arity 24+instance (HasEndpointInfo e1, HasEndpointInfo e2, HasEndpointInfo e3, HasEndpointInfo e4, HasEndpointInfo e5, HasEndpointInfo e6, HasEndpointInfo e7, HasEndpointInfo e8, HasEndpointInfo e9, HasEndpointInfo e10, HasEndpointInfo e11, HasEndpointInfo e12, HasEndpointInfo e13, HasEndpointInfo e14, HasEndpointInfo e15, HasEndpointInfo e16, HasEndpointInfo e17, HasEndpointInfo e18, HasEndpointInfo e19, HasEndpointInfo e20, HasEndpointInfo e21, HasEndpointInfo e22, HasEndpointInfo e23, HasEndpointInfo e24)+  => BuildServer '[e1, e2, e3, e4, e5, e6, e7, e8, e9, e10, e11, e12, e13, e14, e15, e16, e17, e18, e19, e20, e21, e22, e23, e24]+       (WrappedHandler e1, WrappedHandler e2, WrappedHandler e3, WrappedHandler e4, WrappedHandler e5, WrappedHandler e6, WrappedHandler e7, WrappedHandler e8, WrappedHandler e9, WrappedHandler e10, WrappedHandler e11, WrappedHandler e12, WrappedHandler e13, WrappedHandler e14, WrappedHandler e15, WrappedHandler e16, WrappedHandler e17, WrappedHandler e18, WrappedHandler e19, WrappedHandler e20, WrappedHandler e21, WrappedHandler e22, WrappedHandler e23, WrappedHandler e24) where+  buildRouter (h1, h2, h3, h4, h5, h6, h7, h8, h9, h10, h11, h12, h13, h14, h15, h16, h17, h18, h19, h20, h21, h22, h23, h24) router =+    addRoute (mkBound @e24 h24) . addRoute (mkBound @e23 h23) . addRoute (mkBound @e22 h22) . addRoute (mkBound @e21 h21) . addRoute (mkBound @e20 h20) . addRoute (mkBound @e19 h19) . addRoute (mkBound @e18 h18) . addRoute (mkBound @e17 h17) . addRoute (mkBound @e16 h16) . addRoute (mkBound @e15 h15) . addRoute (mkBound @e14 h14) . addRoute (mkBound @e13 h13) . addRoute (mkBound @e12 h12) . addRoute (mkBound @e11 h11) . addRoute (mkBound @e10 h10) . addRoute (mkBound @e9 h9) . addRoute (mkBound @e8 h8) . addRoute (mkBound @e7 h7) . addRoute (mkBound @e6 h6) . addRoute (mkBound @e5 h5) . addRoute (mkBound @e4 h4) . addRoute (mkBound @e3 h3) . addRoute (mkBound @e2 h2) . addRoute (mkBound @e1 h1) $ router++-- Arity 25+instance (HasEndpointInfo e1, HasEndpointInfo e2, HasEndpointInfo e3, HasEndpointInfo e4, HasEndpointInfo e5, HasEndpointInfo e6, HasEndpointInfo e7, HasEndpointInfo e8, HasEndpointInfo e9, HasEndpointInfo e10, HasEndpointInfo e11, HasEndpointInfo e12, HasEndpointInfo e13, HasEndpointInfo e14, HasEndpointInfo e15, HasEndpointInfo e16, HasEndpointInfo e17, HasEndpointInfo e18, HasEndpointInfo e19, HasEndpointInfo e20, HasEndpointInfo e21, HasEndpointInfo e22, HasEndpointInfo e23, HasEndpointInfo e24, HasEndpointInfo e25)+  => BuildServer '[e1, e2, e3, e4, e5, e6, e7, e8, e9, e10, e11, e12, e13, e14, e15, e16, e17, e18, e19, e20, e21, e22, e23, e24, e25]+       (WrappedHandler e1, WrappedHandler e2, WrappedHandler e3, WrappedHandler e4, WrappedHandler e5, WrappedHandler e6, WrappedHandler e7, WrappedHandler e8, WrappedHandler e9, WrappedHandler e10, WrappedHandler e11, WrappedHandler e12, WrappedHandler e13, WrappedHandler e14, WrappedHandler e15, WrappedHandler e16, WrappedHandler e17, WrappedHandler e18, WrappedHandler e19, WrappedHandler e20, WrappedHandler e21, WrappedHandler e22, WrappedHandler e23, WrappedHandler e24, WrappedHandler e25) where+  buildRouter (h1, h2, h3, h4, h5, h6, h7, h8, h9, h10, h11, h12, h13, h14, h15, h16, h17, h18, h19, h20, h21, h22, h23, h24, h25) router =+    addRoute (mkBound @e25 h25) . addRoute (mkBound @e24 h24) . addRoute (mkBound @e23 h23) . addRoute (mkBound @e22 h22) . addRoute (mkBound @e21 h21) . addRoute (mkBound @e20 h20) . addRoute (mkBound @e19 h19) . addRoute (mkBound @e18 h18) . addRoute (mkBound @e17 h17) . addRoute (mkBound @e16 h16) . addRoute (mkBound @e15 h15) . addRoute (mkBound @e14 h14) . addRoute (mkBound @e13 h13) . addRoute (mkBound @e12 h12) . addRoute (mkBound @e11 h11) . addRoute (mkBound @e10 h10) . addRoute (mkBound @e9 h9) . addRoute (mkBound @e8 h8) . addRoute (mkBound @e7 h7) . addRoute (mkBound @e6 h6) . addRoute (mkBound @e5 h5) . addRoute (mkBound @e4 h4) . addRoute (mkBound @e3 h3) . addRoute (mkBound @e2 h2) . addRoute (mkBound @e1 h1) $ router+++-- | Build a BoundHandler from a WrappedHandler using type-level endpoint info.+mkBound :: forall endpoint. HasEndpointInfo endpoint => WrappedHandler endpoint -> BoundHandler+mkBound (WrappedHandler fn) = BoundHandler+  { bhMethod  = endpointMethod @endpoint+  , bhPattern = endpointPattern @endpoint+  , bhMatchFn = endpointMatcher @endpoint+  , bhHandler = fn+  }

@@ -0,0 +1,1782 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeApplications #-}+module Main (main) where++import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.CaseInsensitive as CI+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Aeson as Aeson+import Data.Typeable (Typeable)+import GHC.Generics (Generic)+import Data.IORef+import Network.HTTP.Types++import Network.HTTP.Types (status500)++import Spire+import Spire.Service (Service (..))+import Http.Core+import Acolyte.Core+import Acolyte.Server+++assert :: String -> Bool -> IO ()+assert label True  = putStrLn $ "  OK: " ++ label+assert label False = error   $ "FAIL: " ++ label+++-- ===================================================================+-- API definition+-- ===================================================================++type HealthPath   = '[ 'Lit "health" ]+type UsersPath    = '[ 'Lit "users" ]+type UserByIdPath = '[ 'Lit "users", 'Capture Int ]++type TestAPI =+  '[ Get HealthPath   Text+   , Get UsersPath    (Json [Text])+   , Get UserByIdPath (Json Text)+   ]+++-- ===================================================================+-- Request builder+-- ===================================================================++mkReq :: ByteString -> [Text] -> ByteString -> ByteString -> IO (Request ByteString)+mkReq meth path rawPath body = do+  exts <- emptyExtensions+  pure Request+    { requestMethod     = meth+    , requestPathRaw    = rawPath+    , requestPath       = path+    , requestQuery      = []+    , requestHeaders    = [("Content-Type", "application/json")]+    , requestBody       = body+    , requestExtensions = exts+    }+++-- ===================================================================+-- Test 1: mkServer with automatic wiring+-- ===================================================================++testMkServer :: IO ()+testMkServer = do+  let svc = mkServer @TestAPI+        ( wrapHandler @(Get HealthPath Text)+            (mkHandler0 (pure ("ok" :: Text)))+        , wrapHandler @(Get UsersPath (Json [Text]))+            (mkHandler0 (pure (Json (["alice", "bob"] :: [Text]))))+        , wrapHandler @(Get UserByIdPath (Json Text))+            (\parts body -> do+              mCaps <- lookupExtension @CaptureList (rpExtensions parts)+              case mCaps of+                Just (CaptureList (idT : _)) ->+                  case parseCapture @Int idT of+                    Just n  -> pure $ intoResponse (Json (T.pack ("user-" ++ show n)))+                    Nothing -> pure $ intoResponse (mkError status400 "bad id")+                _ -> pure $ intoResponse (mkError status500 "no captures")+            )+        )++  -- GET /health+  req1 <- mkReq "GET" ["health"] "/health" ""+  resp1 <- runService svc req1+  assert "mkServer: GET /health -> 200" (statusCode (responseStatus resp1) == 200)+  assert "mkServer: GET /health -> 'ok'" (responseBody resp1 == "ok")++  -- GET /users+  req2 <- mkReq "GET" ["users"] "/users" ""+  resp2 <- runService svc req2+  assert "mkServer: GET /users -> 200" (statusCode (responseStatus resp2) == 200)+  let decoded = Aeson.decode (LBS.fromStrict (responseBody resp2)) :: Maybe [Text]+  assert "mkServer: GET /users -> JSON" (decoded == Just ["alice", "bob"])++  -- GET /users/7+  req3 <- mkReq "GET" ["users", "7"] "/users/7" ""+  resp3 <- runService svc req3+  assert "mkServer: GET /users/7 -> 200" (statusCode (responseStatus resp3) == 200)+  let decoded3 = Aeson.decode (LBS.fromStrict (responseBody resp3)) :: Maybe Text+  assert "mkServer: GET /users/7 -> 'user-7'" (decoded3 == Just "user-7")++  -- 404+  req4 <- mkReq "GET" ["nope"] "/nope" ""+  resp4 <- runService svc req4+  assert "mkServer: GET /nope -> 404" (statusCode (responseStatus resp4) == 404)++  -- 405+  req5 <- mkReq "POST" ["health"] "/health" ""+  resp5 <- runService svc req5+  assert "mkServer: POST /health -> 405" (statusCode (responseStatus resp5) == 405)+++-- ===================================================================+-- Test 2: mkServer composes with spire middleware+-- ===================================================================++testWithMiddleware :: IO ()+testWithMiddleware = do+  let svc = mkServer @TestAPI+        ( wrapHandler @(Get HealthPath Text)+            (mkHandler0 (pure ("ok" :: Text)))+        , wrapHandler @(Get UsersPath (Json [Text]))+            (mkHandler0 (pure (Json (["alice"] :: [Text]))))+        , wrapHandler @(Get UserByIdPath (Json Text))+            (mkHandler0 (pure (Json ("user" :: Text))))+        )++  -- Add a header via spire middleware+  let addHeader :: Middleware IO (Request ByteString) (Response ByteString)+      addHeader = middleware $ \inner -> Service $ \req -> do+        resp <- runService inner req+        pure resp { responseHeaders = ("X-Test", "present") : responseHeaders resp }++  let svc' = svc |> addHeader++  req <- mkReq "GET" ["health"] "/health" ""+  resp <- runService svc' req+  assert "middleware: handler still works" (responseBody resp == "ok")+  assert "middleware: header added" (lookup "X-Test" (responseHeaders resp) == Just "present")+++-- ===================================================================+-- Test 3: EffectfulServer with effect tracking+-- ===================================================================++-- API with effects+type EffectAPI =+  '[ Requires Auth (Get UserByIdPath (Json Text))+   , Get HealthPath Text+   ]++testEffectfulServer :: IO ()+testEffectfulServer = do+  -- Build with all effects provided+  let authMw :: Middleware IO (Request ByteString) (Response ByteString)+      authMw = middleware $ \inner -> Service $ \req -> do+        resp <- runService inner req+        pure resp { responseHeaders = ("X-Auth", "checked") : responseHeaders resp }++  let svc = run+        $ provide @Auth authMw+        $ effectfulServer @EffectAPI+            ( wrapHandler @(Requires Auth (Get UserByIdPath (Json Text)))+                (\parts body -> do+                  mCaps <- lookupExtension @CaptureList (rpExtensions parts)+                  case mCaps of+                    Just (CaptureList (idT : _)) ->+                      pure $ intoResponse (Json ("user-" <> idT))+                    _ -> pure $ intoResponse (Json ("unknown" :: Text))+                )+            , wrapHandler @(Get HealthPath Text)+                (mkHandler0 (pure ("ok" :: Text)))+            )++  -- GET /health (no auth required)+  req1 <- mkReq "GET" ["health"] "/health" ""+  resp1 <- runService svc req1+  assert "effectful: GET /health -> 200" (statusCode (responseStatus resp1) == 200)+  assert "effectful: auth middleware ran" (lookup "X-Auth" (responseHeaders resp1) == Just "checked")++  -- GET /users/5 (auth required — verified at compile time)+  req2 <- mkReq "GET" ["users", "5"] "/users/5" ""+  resp2 <- runService svc req2+  assert "effectful: GET /users/5 -> 200" (statusCode (responseStatus resp2) == 200)+++-- NEGATIVE TEST (uncomment to verify compile error):+-- "Missing middleware effect: Auth"+--+-- testMissingEffect :: IO ()+-- testMissingEffect = do+--   let svc = run  -- compile error: Auth not provided+--         $ effectfulServer @EffectAPI+--             ( wrapHandler @(Requires Auth (Get UserByIdPath (Json Text)))+--                 (mkHandler0 (pure (Json ("user" :: Text))))+--             , wrapHandler @(Get HealthPath Text)+--                 (mkHandler0 (pure ("ok" :: Text)))+--             )+--   pure ()+++-- ===================================================================+-- Test 4: endpoint metadata reflection+-- ===================================================================++testMetadata :: IO ()+testMetadata = do+  assert "method GET" (endpointMethod @(Get HealthPath Text) == "GET")+  assert "method POST" (endpointMethod @(Post UsersPath (Json Text) (Json Text)) == "POST")+  assert "pattern /health" (endpointPattern @(Get HealthPath Text) == "/health")+  assert "pattern /users/{capture}" (endpointPattern @(Get UserByIdPath (Json Text)) == "/users/{capture}")+++-- ===================================================================+-- Test 5: IntoResponse instances+-- ===================================================================++testResponses :: IO ()+testResponses = do+  let r1 = intoResponse ("hello" :: Text)+  assert "Text -> 200" (statusCode (responseStatus r1) == 200)++  let r2 = intoResponse (Json (42 :: Int))+  assert "Json Int -> 200" (statusCode (responseStatus r2) == 200)+  assert "Json Int -> json content-type" (lookup "Content-Type" (responseHeaders r2) == Just "application/json")++  let r3 = intoResponse (Left (mkError status403 "forbidden") :: Either ServerError (Json Int))+  assert "Left err -> 403" (statusCode (responseStatus r3) == 403)++  let r4 = intoResponse (jsonError status422 "bad input")+  assert "JsonError -> 422" (statusCode (responseStatus r4) == 422)+++-- ===================================================================+-- Test 6: Sub-API composition via combineServer+-- ===================================================================++-- Two separate sub-APIs+type SubAPI1 = '[ Get HealthPath Text ]+type SubAPI2 = '[ Get UsersPath (Json [Text]), Get UserByIdPath (Json Text) ]++-- Combined type for OpenAPI / client (type-level only)+type CombinedAPI = SubAPI1 ++ SubAPI2++testCombineServer :: IO ()+testCombineServer = do+  let svc = combineServer2 @SubAPI1 @SubAPI2+        -- SubAPI1 handlers+        ( wrapHandler @(Get HealthPath Text)+            (mkHandler0 (pure ("ok" :: Text)))+        )+        -- SubAPI2 handlers+        ( wrapHandler @(Get UsersPath (Json [Text]))+            (mkHandler0 (pure (Json (["alice"] :: [Text]))))+        , wrapHandler @(Get UserByIdPath (Json Text))+            (\parts _body -> do+              mCaps <- lookupExtension @CaptureList (rpExtensions parts)+              case mCaps of+                Just (CaptureList (idT : _)) ->+                  pure $ intoResponse (Json ("user-" <> idT))+                _ -> pure $ intoResponse (mkError status500 "no caps")+            )+        )++  -- Test SubAPI1+  req1 <- mkReq "GET" ["health"] "/health" ""+  resp1 <- runService svc req1+  assert "combined: GET /health -> 200" (statusCode (responseStatus resp1) == 200)+  assert "combined: GET /health body" (responseBody resp1 == "ok")++  -- Test SubAPI2+  req2 <- mkReq "GET" ["users"] "/users" ""+  resp2 <- runService svc req2+  assert "combined: GET /users -> 200" (statusCode (responseStatus resp2) == 200)++  req3 <- mkReq "GET" ["users", "7"] "/users/7" ""+  resp3 <- runService svc req3+  assert "combined: GET /users/7 -> 200" (statusCode (responseStatus resp3) == 200)++  -- Test 404 still works+  req4 <- mkReq "GET" ["nope"] "/nope" ""+  resp4 <- runService svc req4+  assert "combined: GET /nope -> 404" (statusCode (responseStatus resp4) == 404)+++-- ===================================================================+-- Test 7: Combined effectful server+-- ===================================================================++type EffectSubAPI1 = '[ Get HealthPath Text ]+type EffectSubAPI2 = '[ Requires Auth (Get UsersPath (Json [Text])) ]+type EffectFullAPI = EffectSubAPI1 ++ EffectSubAPI2++testCombinedEffects :: IO ()+testCombinedEffects = do+  let router = subRouter @EffectSubAPI2+                 ( wrapHandler @(Requires Auth (Get UsersPath (Json [Text])))+                     (mkHandler0 (pure (Json (["bob"] :: [Text]))))+                 )+               $ subRouter @EffectSubAPI1+                   ( wrapHandler @(Get HealthPath Text)+                       (mkHandler0 (pure ("ok" :: Text)))+                   )+               $ emptyRouter++      authMw :: Middleware IO (Request ByteString) (Response ByteString)+      authMw = before $ \_ -> pure ()++      svc = runCombined @EffectFullAPI+          $ provideEffect @Auth authMw+          $ combinedFromRouter @EffectFullAPI router++  req1 <- mkReq "GET" ["health"] "/health" ""+  resp1 <- runService svc req1+  assert "combined+effects: GET /health -> 200" (statusCode (responseStatus resp1) == 200)++  req2 <- mkReq "GET" ["users"] "/users" ""+  resp2 <- runService svc req2+  assert "combined+effects: GET /users -> 200" (statusCode (responseStatus resp2) == 200)++  -- COMPILE-TIME CHECK: if we remove `provideEffect @Auth`, this won't compile+  -- because EffectFullAPI contains Requires Auth and runCombined checks AllEffectsProvided.+++-- ===================================================================+-- Test 8: ToHandler ergonomic handlers+-- ===================================================================++-- Ergonomic handler: no arguments+healthErgo :: IO Text+healthErgo = pure "ok"++-- Ergonomic handler: PathCapture+getUserErgo :: PathCapture Int -> IO (Json Text)+getUserErgo (PathCapture n) = pure (Json (T.pack ("user-" ++ show n)))++type ErgoAPI =+  '[ Get HealthPath Text+   , Get UserByIdPath (Json Text)+   ]++testToHandler :: IO ()+testToHandler = do+  let svc = mkServer @ErgoAPI+        ( wrapHandler @(Get HealthPath Text) (toHandler healthErgo)+        , wrapHandler @(Get UserByIdPath (Json Text)) (toHandler getUserErgo)+        )++  -- GET /health via ergonomic handler+  req1 <- mkReq "GET" ["health"] "/health" ""+  resp1 <- runService svc req1+  assert "toHandler: GET /health -> 200" (statusCode (responseStatus resp1) == 200)+  assert "toHandler: GET /health -> 'ok'" (responseBody resp1 == "ok")++  -- GET /users/42 via PathCapture ergonomic handler+  req2 <- mkReq "GET" ["users", "42"] "/users/42" ""+  resp2 <- runService svc req2+  assert "toHandler: GET /users/42 -> 200" (statusCode (responseStatus resp2) == 200)+  let decoded2 = Aeson.decode (LBS.fromStrict (responseBody resp2)) :: Maybe Text+  assert "toHandler: GET /users/42 -> 'user-42'" (decoded2 == Just "user-42")++  -- GET /users/bad -> 400 (invalid capture)+  req3 <- mkReq "GET" ["users", "bad"] "/users/bad" ""+  resp3 <- runService svc req3+  assert "toHandler: GET /users/bad -> 400" (statusCode (responseStatus resp3) == 400)+++-- ===================================================================+-- Test 8b: mkApi — ergonomic server construction (no wrapHandler)+-- ===================================================================++testMkApi :: IO ()+testMkApi = do+  -- mkApi @ErgoAPI directly accepts handler functions — no wrapHandler, no toHandler+  let svc = mkApi @ErgoAPI (healthErgo, getUserErgo)++  -- GET /health+  req1 <- mkReq "GET" ["health"] "/health" ""+  resp1 <- runService svc req1+  assert "mkApi: GET /health -> 200" (statusCode (responseStatus resp1) == 200)+  assert "mkApi: GET /health -> 'ok'" (responseBody resp1 == "ok")++  -- GET /users/42 via PathCapture+  req2 <- mkReq "GET" ["users", "42"] "/users/42" ""+  resp2 <- runService svc req2+  assert "mkApi: GET /users/42 -> 200" (statusCode (responseStatus resp2) == 200)+  let decoded2 = Aeson.decode (LBS.fromStrict (responseBody resp2)) :: Maybe Text+  assert "mkApi: GET /users/42 -> 'user-42'" (decoded2 == Just "user-42")++  -- GET /users/bad -> 400 (invalid capture)+  req3 <- mkReq "GET" ["users", "bad"] "/users/bad" ""+  resp3 <- runService svc req3+  assert "mkApi: GET /users/bad -> 400" (statusCode (responseStatus resp3) == 400)++  -- 404+  req4 <- mkReq "GET" ["nope"] "/nope" ""+  resp4 <- runService svc req4+  assert "mkApi: GET /nope -> 404" (statusCode (responseStatus resp4) == 404)++  -- 405+  req5 <- mkReq "POST" ["health"] "/health" ""+  resp5 <- runService svc req5+  assert "mkApi: POST /health -> 405" (statusCode (responseStatus resp5) == 405)+++-- ===================================================================+-- Test 9: PathCapture FromRequestParts+-- ===================================================================++testPathCapture :: IO ()+testPathCapture = do+  -- Build a request with CaptureList in extensions+  exts <- emptyExtensions+  insertExtension (CaptureList ["99"]) exts+  let parts = RequestParts+        { rpMethod     = "GET"+        , rpPathRaw    = "/users/99"+        , rpPath       = ["users", "99"]+        , rpQuery      = []+        , rpHeaders    = []+        , rpExtensions = exts+        }++  -- Extract PathCapture Int+  result <- fromRequestParts @(PathCapture Int) parts+  case result of+    Right (PathCapture n) -> assert "PathCapture: parses Int from CaptureList" (n == 99)+    Left _                -> assert "PathCapture: parses Int from CaptureList" False++  -- Extract with bad data+  exts2 <- emptyExtensions+  insertExtension (CaptureList ["notanumber"]) exts2+  let parts2 = parts { rpExtensions = exts2 }+  result2 <- fromRequestParts @(PathCapture Int) parts2+  case result2 of+    Left _  -> assert "PathCapture: bad parse -> Left" True+    Right _ -> assert "PathCapture: bad parse -> Left" False++  -- Extract with no CaptureList+  exts3 <- emptyExtensions+  let parts3 = parts { rpExtensions = exts3 }+  result3 <- fromRequestParts @(PathCapture Int) parts3+  case result3 of+    Left _  -> assert "PathCapture: missing CaptureList -> Left" True+    Right _ -> assert "PathCapture: missing CaptureList -> Left" False+++-- ===================================================================+-- Test 10: QueryParam extraction+-- ===================================================================++type SearchPath = '[ 'Lit "search" ]+type SearchAPI = '[ Get SearchPath (Json Text) ]++-- Ergonomic handler with QueryParam+searchHandler :: QueryParam "page" Int -> IO (Json Text)+searchHandler (QueryParam page) = pure (Json (T.pack ("page-" ++ show page)))++mkReqWithQuery :: ByteString -> [Text] -> ByteString -> ByteString+              -> [(ByteString, Maybe ByteString)] -> IO (Request ByteString)+mkReqWithQuery meth path rawPath body qs = do+  exts <- emptyExtensions+  pure Request+    { requestMethod     = meth+    , requestPathRaw    = rawPath+    , requestPath       = path+    , requestQuery      = qs+    , requestHeaders    = [("Content-Type", "application/json")]+    , requestBody       = body+    , requestExtensions = exts+    }++testQueryParam :: IO ()+testQueryParam = do+  let svc = mkServer @SearchAPI+        ( wrapHandler @(Get SearchPath (Json Text)) (toHandler searchHandler)+        )++  -- GET /search?page=5 -> success+  req1 <- mkReqWithQuery "GET" ["search"] "/search" "" [("page", Just "5")]+  resp1 <- runService svc req1+  assert "QueryParam: GET /search?page=5 -> 200" (statusCode (responseStatus resp1) == 200)+  let decoded1 = Aeson.decode (LBS.fromStrict (responseBody resp1)) :: Maybe Text+  assert "QueryParam: GET /search?page=5 -> 'page-5'" (decoded1 == Just "page-5")++  -- GET /search (missing page) -> 400+  req2 <- mkReqWithQuery "GET" ["search"] "/search" "" []+  resp2 <- runService svc req2+  assert "QueryParam: GET /search (missing param) -> 400" (statusCode (responseStatus resp2) == 400)++  -- GET /search?page=abc (invalid) -> 400+  req3 <- mkReqWithQuery "GET" ["search"] "/search" "" [("page", Just "abc")]+  resp3 <- runService svc req3+  assert "QueryParam: GET /search?page=abc -> 400" (statusCode (responseStatus resp3) == 400)+++-- ===================================================================+-- Test 11: JsonBody via FromRequestParts (ergonomic handler)+-- ===================================================================++data CreateUser = CreateUser+  { userName :: Text+  } deriving (Show, Eq, Generic)++instance Aeson.FromJSON CreateUser+instance Aeson.ToJSON CreateUser++type CreateUserPath = '[ 'Lit "users" ]+type CreateUserAPI = '[ Post CreateUserPath (Json CreateUser) (Json Text) ]++createUserHandler :: JsonBody CreateUser -> IO (Json Text)+createUserHandler (JsonBody cu) = pure (Json ("created: " <> userName cu))++testJsonBody :: IO ()+testJsonBody = do+  let svc = mkServer @CreateUserAPI+        ( wrapHandler @(Post CreateUserPath (Json CreateUser) (Json Text))+            (toHandler createUserHandler)+        )++  -- POST /users with valid JSON+  let body1 = LBS.toStrict (Aeson.encode (CreateUser "alice"))+  req1 <- mkReq "POST" ["users"] "/users" body1+  resp1 <- runService svc req1+  assert "JsonBody: POST /users -> 200" (statusCode (responseStatus resp1) == 200)+  let decoded1 = Aeson.decode (LBS.fromStrict (responseBody resp1)) :: Maybe Text+  assert "JsonBody: POST /users -> 'created: alice'" (decoded1 == Just "created: alice")++  -- POST /users with invalid JSON+  req2 <- mkReq "POST" ["users"] "/users" "not json"+  resp2 <- runService svc req2+  assert "JsonBody: POST /users (bad JSON) -> 422" (statusCode (responseStatus resp2) == 422)++  -- POST /users with empty body+  req3 <- mkReq "POST" ["users"] "/users" ""+  resp3 <- runService svc req3+  assert "JsonBody: POST /users (empty body) -> 422" (statusCode (responseStatus resp3) == 422)+++-- ===================================================================+-- Test 12: HeaderMap extraction+-- ===================================================================++testHeaderMap :: IO ()+testHeaderMap = do+  exts <- emptyExtensions+  let parts = RequestParts+        { rpMethod     = "GET"+        , rpPathRaw    = "/test"+        , rpPath       = ["test"]+        , rpQuery      = []+        , rpHeaders    = [("Content-Type", "application/json"), ("X-Custom", "hello")]+        , rpExtensions = exts+        }+  result <- fromRequestParts @HeaderMap parts+  case result of+    Right (HeaderMap hdrs) -> do+      assert "HeaderMap: has Content-Type" (lookup "Content-Type" hdrs == Just "application/json")+      assert "HeaderMap: has X-Custom" (lookup "X-Custom" hdrs == Just "hello")+      assert "HeaderMap: correct count" (length hdrs == 2)+    Left _ -> assert "HeaderMap: extraction succeeded" False+++-- ===================================================================+-- Test 13: FullRequest extraction+-- ===================================================================++testFullRequest :: IO ()+testFullRequest = do+  exts <- emptyExtensions+  let parts = RequestParts+        { rpMethod     = "POST"+        , rpPathRaw    = "/api/users"+        , rpPath       = ["api", "users"]+        , rpQuery      = []+        , rpHeaders    = []+        , rpExtensions = exts+        }+  result <- fromRequestParts @FullRequest parts+  case result of+    Right (FullRequest fp) -> do+      assert "FullRequest: correct method" (rpMethod fp == "POST")+      assert "FullRequest: correct path" (rpPath fp == ["api", "users"])+      assert "FullRequest: correct rawPath" (rpPathRaw fp == "/api/users")+    Left _ -> assert "FullRequest: extraction succeeded" False+++-- ===================================================================+-- Test 14: RawQuery extraction+-- ===================================================================++testRawQuery :: IO ()+testRawQuery = do+  exts <- emptyExtensions+  let parts = RequestParts+        { rpMethod     = "GET"+        , rpPathRaw    = "/foo?bar=baz"+        , rpPath       = ["foo"]+        , rpQuery      = [("bar", Just "baz")]+        , rpHeaders    = []+        , rpExtensions = exts+        }+  result <- fromRequestParts @RawQuery parts+  case result of+    Right (RawQuery q) -> assert "RawQuery: extracts query string" (q == "bar=baz")+    Left _ -> assert "RawQuery: extraction succeeded" False++  -- Test with no query string+  let parts2 = parts { rpPathRaw = "/foo" }+  result2 <- fromRequestParts @RawQuery parts2+  case result2 of+    Right (RawQuery q2) -> assert "RawQuery: empty when no '?'" (BS.null q2)+    Left _ -> assert "RawQuery: extraction succeeded (no query)" False+++-- ===================================================================+-- Test 15: RawPathParams extraction+-- ===================================================================++testRawPathParams :: IO ()+testRawPathParams = do+  exts <- emptyExtensions+  insertExtension (CaptureList ["42", "hello"]) exts+  let parts = RequestParts+        { rpMethod     = "GET"+        , rpPathRaw    = "/users/42/hello"+        , rpPath       = ["users", "42", "hello"]+        , rpQuery      = []+        , rpHeaders    = []+        , rpExtensions = exts+        }+  result <- fromRequestParts @RawPathParams parts+  case result of+    Right (RawPathParams segs) -> do+      assert "RawPathParams: correct segments" (segs == ["42", "hello"])+      assert "RawPathParams: correct count" (length segs == 2)+    Left _ -> assert "RawPathParams: extraction succeeded" False++  -- Test with no CaptureList -> empty list+  exts2 <- emptyExtensions+  let parts2 = parts { rpExtensions = exts2 }+  result2 <- fromRequestParts @RawPathParams parts2+  case result2 of+    Right (RawPathParams segs2) -> assert "RawPathParams: empty when no CaptureList" (null segs2)+    Left _ -> assert "RawPathParams: extraction succeeded (empty)" False+++-- ===================================================================+-- Test 16: StringBody extraction+-- ===================================================================++testStringBody :: IO ()+testStringBody = do+  exts <- emptyExtensions+  insertExtension (BodyBytes "hello world") exts+  let parts = RequestParts+        { rpMethod     = "GET"+        , rpPathRaw    = "/test"+        , rpPath       = ["test"]+        , rpQuery      = []+        , rpHeaders    = []+        , rpExtensions = exts+        }+  result <- fromRequestParts @StringBody parts+  case result of+    Right (StringBody txt) -> assert "StringBody: correct text" (txt == "hello world")+    Left _ -> assert "StringBody: extraction succeeded" False++  -- Test with no BodyBytes -> Left+  exts2 <- emptyExtensions+  let parts2 = parts { rpExtensions = exts2 }+  result2 <- fromRequestParts @StringBody parts2+  case result2 of+    Left _  -> assert "StringBody: Left when no BodyBytes" True+    Right _ -> assert "StringBody: Left when no BodyBytes" False+++-- ===================================================================+-- Test 17: MatchedPath extraction+-- ===================================================================++testMatchedPathExtract :: IO ()+testMatchedPathExtract = do+  exts <- emptyExtensions+  insertExtension (MatchedPath "/users/{capture}") exts+  let parts = RequestParts+        { rpMethod     = "GET"+        , rpPathRaw    = "/users/42"+        , rpPath       = ["users", "42"]+        , rpQuery      = []+        , rpHeaders    = []+        , rpExtensions = exts+        }+  result <- fromRequestParts @MatchedPath parts+  case result of+    Right (MatchedPath pat) -> assert "MatchedPath: correct pattern" (pat == "/users/{capture}")+    Left _ -> assert "MatchedPath: extraction succeeded" False++  -- Test without MatchedPath in extensions -> Left+  exts2 <- emptyExtensions+  let parts2 = parts { rpExtensions = exts2 }+  result2 <- fromRequestParts @MatchedPath parts2+  case result2 of+    Left _  -> assert "MatchedPath: Left when not set" True+    Right _ -> assert "MatchedPath: Left when not set" False+++-- ===================================================================+-- Test 18: OriginalUri extraction+-- ===================================================================++testOriginalUri :: IO ()+testOriginalUri = do+  -- With OriginalUri stored in extensions+  exts <- emptyExtensions+  insertExtension (OriginalUri "/api/v1/users?page=1") exts+  let parts = RequestParts+        { rpMethod     = "GET"+        , rpPathRaw    = "/users"+        , rpPath       = ["users"]+        , rpQuery      = []+        , rpHeaders    = []+        , rpExtensions = exts+        }+  result <- fromRequestParts @OriginalUri parts+  case result of+    Right (OriginalUri uri) -> assert "OriginalUri: from extensions" (uri == "/api/v1/users?page=1")+    Left _ -> assert "OriginalUri: extraction succeeded" False++  -- Without OriginalUri in extensions -> falls back to rpPathRaw+  exts2 <- emptyExtensions+  let parts2 = parts { rpExtensions = exts2, rpPathRaw = "/fallback/path" }+  result2 <- fromRequestParts @OriginalUri parts2+  case result2 of+    Right (OriginalUri uri2) -> assert "OriginalUri: fallback to rpPathRaw" (uri2 == "/fallback/path")+    Left _ -> assert "OriginalUri: fallback extraction succeeded" False+++-- ===================================================================+-- Test 19: NestedPath extraction+-- ===================================================================++testNestedPath :: IO ()+testNestedPath = do+  -- Without NestedPath in extensions -> empty list+  exts <- emptyExtensions+  let parts = RequestParts+        { rpMethod     = "GET"+        , rpPathRaw    = "/test"+        , rpPath       = ["test"]+        , rpQuery      = []+        , rpHeaders    = []+        , rpExtensions = exts+        }+  result <- fromRequestParts @NestedPath parts+  case result of+    Right (NestedPath segs) -> assert "NestedPath: empty when not set" (null segs)+    Left _ -> assert "NestedPath: extraction succeeded" False++  -- With NestedPath stored+  exts2 <- emptyExtensions+  insertExtension (NestedPath ["api", "v1"]) exts2+  let parts2 = parts { rpExtensions = exts2 }+  result2 <- fromRequestParts @NestedPath parts2+  case result2 of+    Right (NestedPath segs2) -> assert "NestedPath: correct prefix" (segs2 == ["api", "v1"])+    Left _ -> assert "NestedPath: extraction with value succeeded" False+++-- ===================================================================+-- Test 20: RawForm extraction+-- ===================================================================++testRawForm :: IO ()+testRawForm = do+  exts <- emptyExtensions+  insertExtension (BodyBytes "user=alice&age=30") exts+  let parts = RequestParts+        { rpMethod     = "POST"+        , rpPathRaw    = "/login"+        , rpPath       = ["login"]+        , rpQuery      = []+        , rpHeaders    = [("Content-Type", "application/x-www-form-urlencoded")]+        , rpExtensions = exts+        }+  result <- fromRequestParts @RawForm parts+  case result of+    Right (RawForm pairs) -> do+      assert "RawForm: has user field" (lookup "user" pairs == Just "alice")+      assert "RawForm: has age field" (lookup "age" pairs == Just "30")+      assert "RawForm: correct pair count" (length pairs == 2)+    Left _ -> assert "RawForm: extraction succeeded" False+++-- ===================================================================+-- Test 21: Form extraction with FromForm instance+-- ===================================================================++data SimpleForm = SimpleForm Text Int+  deriving (Show, Eq)++instance FromForm SimpleForm where+  fromForm pairs = case (lookup "user" pairs, lookup "age" pairs) of+    (Just u, Just a) -> case parseCapture (TE.decodeUtf8 a) of+      Just n  -> Right (SimpleForm (TE.decodeUtf8 u) n)+      Nothing -> Left "invalid age"+    _ -> Left "missing fields"++testForm :: IO ()+testForm = do+  exts <- emptyExtensions+  insertExtension (BodyBytes "user=alice&age=30") exts+  let parts = RequestParts+        { rpMethod     = "POST"+        , rpPathRaw    = "/register"+        , rpPath       = ["register"]+        , rpQuery      = []+        , rpHeaders    = [("Content-Type", "application/x-www-form-urlencoded")]+        , rpExtensions = exts+        }+  result <- fromRequestParts @(Form SimpleForm) parts+  case result of+    Right (Form (SimpleForm user age)) -> do+      assert "Form: correct user" (user == "alice")+      assert "Form: correct age" (age == 30)+    Left _ -> assert "Form: extraction succeeded" False++  -- Invalid form data+  exts2 <- emptyExtensions+  insertExtension (BodyBytes "user=alice&age=notanumber") exts2+  let parts2 = parts { rpExtensions = exts2 }+  result2 <- fromRequestParts @(Form SimpleForm) parts2+  case result2 of+    Left _  -> assert "Form: Left on invalid data" True+    Right _ -> assert "Form: Left on invalid data" False++  -- Missing fields+  exts3 <- emptyExtensions+  insertExtension (BodyBytes "user=alice") exts3+  let parts3 = parts { rpExtensions = exts3 }+  result3 <- fromRequestParts @(Form SimpleForm) parts3+  case result3 of+    Left _  -> assert "Form: Left on missing fields" True+    Right _ -> assert "Form: Left on missing fields" False+++-- ===================================================================+-- Test 22: Multipart extraction+-- ===================================================================++testMultipart :: IO ()+testMultipart = do+  exts <- emptyExtensions+  let multipartBody = BS.concat+        [ "--boundary123\r\n"+        , "Content-Disposition: form-data; name=\"file\"; filename=\"test.txt\"\r\n"+        , "Content-Type: text/plain\r\n"+        , "\r\n"+        , "hello world\r\n"+        , "--boundary123--"+        ]+  insertExtension (BodyBytes multipartBody) exts+  let parts = RequestParts+        { rpMethod     = "POST"+        , rpPathRaw    = "/upload"+        , rpPath       = ["upload"]+        , rpQuery      = []+        , rpHeaders    = [(CI.mk "content-type", "multipart/form-data; boundary=boundary123")]+        , rpExtensions = exts+        }+  result <- fromRequestParts @Multipart parts+  case result of+    Right (Multipart fileParts) -> do+      assert "Multipart: has one part" (length fileParts == 1)+      case fileParts of+        (fp : _) -> do+          assert "Multipart: field name is 'file'" (fpFieldName fp == "file")+          assert "Multipart: filename is 'test.txt'" (fpFileName fp == Just "test.txt")+          assert "Multipart: body is 'hello world'" (fpBody fp == "hello world")+        [] -> assert "Multipart: has parts" False+    Left err -> do+      assert ("Multipart: extraction succeeded (got: " ++ show (seMessage err) ++ ")") False+++-- ===================================================================+-- Test 23: ConnectInfo extractor+-- ===================================================================++testConnectInfo :: IO ()+testConnectInfo = do+  -- With ConnectInfo in extensions+  exts <- emptyExtensions+  insertExtension (ConnectInfo "127.0.0.1" 8080) exts+  let parts = RequestParts+        { rpMethod     = "GET"+        , rpPathRaw    = "/test"+        , rpPath       = ["test"]+        , rpQuery      = []+        , rpHeaders    = []+        , rpExtensions = exts+        }+  result <- fromRequestParts @ConnectInfo parts+  case result of+    Right ci -> do+      assert "ConnectInfo: host is 127.0.0.1" (ciHost ci == "127.0.0.1")+      assert "ConnectInfo: port is 8080" (ciPort ci == 8080)+    Left _ -> assert "ConnectInfo: extraction succeeded" False++  -- Without ConnectInfo -> Left+  exts2 <- emptyExtensions+  let parts2 = parts { rpExtensions = exts2 }+  result2 <- fromRequestParts @ConnectInfo parts2+  case result2 of+    Left _  -> assert "ConnectInfo: Left when missing" True+    Right _ -> assert "ConnectInfo: Left when missing" False+++-- ===================================================================+-- Test 24: ReqMethod extractor+-- ===================================================================++testReqMethod :: IO ()+testReqMethod = do+  exts <- emptyExtensions+  let parts = RequestParts+        { rpMethod     = "POST"+        , rpPathRaw    = "/test"+        , rpPath       = ["test"]+        , rpQuery      = []+        , rpHeaders    = []+        , rpExtensions = exts+        }+  result <- fromRequestParts @ReqMethod parts+  case result of+    Right (ReqMethod m) -> assert "ReqMethod: is POST" (m == "POST")+    Left _ -> assert "ReqMethod: extraction succeeded" False+++-- ===================================================================+-- Test 25: Extension extractor+-- ===================================================================++newtype MyExt = MyExt Int deriving (Show, Eq, Typeable)++testExtension :: IO ()+testExtension = do+  -- With Extension present+  exts <- emptyExtensions+  insertExtension (MyExt 42) exts+  let parts = RequestParts+        { rpMethod     = "GET"+        , rpPathRaw    = "/test"+        , rpPath       = ["test"]+        , rpQuery      = []+        , rpHeaders    = []+        , rpExtensions = exts+        }+  result <- fromRequestParts @(Extension MyExt) parts+  case result of+    Right (Extension (MyExt n)) -> assert "Extension MyExt: value is 42" (n == 42)+    Left _ -> assert "Extension MyExt: extraction succeeded" False++  -- Without Extension -> Left+  exts2 <- emptyExtensions+  let parts2 = parts { rpExtensions = exts2 }+  result2 <- fromRequestParts @(Extension MyExt) parts2+  case result2 of+    Left _  -> assert "Extension MyExt: Left when missing" True+    Right _ -> assert "Extension MyExt: Left when missing" False+++-- ===================================================================+-- Test 26: Optional extractor+-- ===================================================================++testOptional :: IO ()+testOptional = do+  -- Without Authorization header -> Optional Nothing+  exts <- emptyExtensions+  let parts = RequestParts+        { rpMethod     = "GET"+        , rpPathRaw    = "/test"+        , rpPath       = ["test"]+        , rpQuery      = []+        , rpHeaders    = []+        , rpExtensions = exts+        }+  result <- fromRequestParts @(Optional (ReqHeader "Authorization")) parts+  case result of+    Right (Optional Nothing) -> assert "Optional: Nothing when header missing" True+    Right (Optional (Just _)) -> assert "Optional: Nothing when header missing" False+    Left _ -> assert "Optional: extraction succeeded" False++  -- With Authorization header -> Optional (Just ...)+  let parts2 = parts { rpHeaders = [("Authorization", "Bearer token123")] }+  result2 <- fromRequestParts @(Optional (ReqHeader "Authorization")) parts2+  case result2 of+    Right (Optional (Just (ReqHeader val))) ->+      assert "Optional: Just when header present" (val == "Bearer token123")+    Right (Optional Nothing) -> assert "Optional: Just when header present" False+    Left _ -> assert "Optional: extraction succeeded" False+++-- ===================================================================+-- Test 27: AppState extractor+-- ===================================================================++testAppState :: IO ()+testAppState = do+  -- With AppState in extensions+  exts <- emptyExtensions+  insertExtension (AppState (42 :: Int)) exts+  let parts = RequestParts+        { rpMethod     = "GET"+        , rpPathRaw    = "/test"+        , rpPath       = ["test"]+        , rpQuery      = []+        , rpHeaders    = []+        , rpExtensions = exts+        }+  result <- fromRequestParts @(AppState Int) parts+  case result of+    Right (AppState n) -> assert "AppState: value is 42" (n == 42)+    Left _ -> assert "AppState: extraction succeeded" False++  -- Without AppState -> Left+  exts2 <- emptyExtensions+  let parts2 = parts { rpExtensions = exts2 }+  result2 <- fromRequestParts @(AppState Int) parts2+  case result2 of+    Left _  -> assert "AppState: Left when missing" True+    Right _ -> assert "AppState: Left when missing" False+++-- ===================================================================+-- Test 28: ToHandler with two extractors+-- ===================================================================++type TwoExtPath = '[ 'Lit "items", 'Capture Int ]+type TwoExtAPI  = '[ Get TwoExtPath (Json Text) ]++twoArgHandler :: PathCapture Int -> QueryParam "name" Text -> IO (Json Text)+twoArgHandler (PathCapture n) (QueryParam name) =+  pure (Json (T.pack (show n) <> "-" <> name))++testToHandlerTwoArgs :: IO ()+testToHandlerTwoArgs = do+  let svc = mkServer @TwoExtAPI+        ( wrapHandler @(Get TwoExtPath (Json Text)) (toHandler twoArgHandler)+        )++  req <- mkReqWithQuery "GET" ["items", "7"] "/items/7" "" [("name", Just "widget")]+  resp <- runService svc req+  assert "ToHandler 2-arg: status 200" (statusCode (responseStatus resp) == 200)+  let decoded = Aeson.decode (LBS.fromStrict (responseBody resp)) :: Maybe Text+  assert "ToHandler 2-arg: correct body" (decoded == Just "7-widget")+++-- ===================================================================+-- Test 29: ToHandler with body + parts+-- ===================================================================++type BodyPartsPath = '[ 'Lit "items", 'Capture Int ]+type BodyPartsAPI  = '[ Post BodyPartsPath (Json CreateUser) (Json Text) ]++bodyAndPartsHandler :: PathCapture Int -> JsonBody CreateUser -> IO (Json Text)+bodyAndPartsHandler (PathCapture n) (JsonBody cu) =+  pure (Json (T.pack (show n) <> "-" <> userName cu))++testToHandlerBodyParts :: IO ()+testToHandlerBodyParts = do+  let svc = mkServer @BodyPartsAPI+        ( wrapHandler @(Post BodyPartsPath (Json CreateUser) (Json Text))+            (toHandler bodyAndPartsHandler)+        )++  let body = LBS.toStrict (Aeson.encode (CreateUser "alice"))+  req <- mkReq "POST" ["items", "5"] "/items/5" body+  resp <- runService svc req+  assert "ToHandler body+parts: status 200" (statusCode (responseStatus resp) == 200)+  let decoded = Aeson.decode (LBS.fromStrict (responseBody resp)) :: Maybe Text+  assert "ToHandler body+parts: correct body" (decoded == Just "5-alice")+++-- ===================================================================+-- Test 30: ToHandler error propagation+-- ===================================================================++testToHandlerErrorProp :: IO ()+testToHandlerErrorProp = do+  -- Reuse the ergonomic handler from Test 8 that requires PathCapture Int.+  -- Send a bad capture value to trigger extractor failure.+  handlerRan <- newIORef False+  let badHandler :: PathCapture Int -> IO (Json Text)+      badHandler (PathCapture n) = do+        writeIORef handlerRan True+        pure (Json (T.pack (show n)))++  let svc = mkServer @ErgoAPI+        ( wrapHandler @(Get HealthPath Text) (toHandler healthErgo)+        , wrapHandler @(Get UserByIdPath (Json Text)) (toHandler badHandler)+        )++  -- GET /users/notanumber -> bad capture -> 400+  req <- mkReq "GET" ["users", "notanumber"] "/users/notanumber" ""+  resp <- runService svc req+  assert "ToHandler error prop: status 400" (statusCode (responseStatus resp) == 400)+  ran <- readIORef handlerRan+  assert "ToHandler error prop: handler did not run" (not ran)+++-- ===================================================================+-- Test: Named routes (record-based handler registration)+-- ===================================================================++-- | A named handler record for ErgoAPI.+data NamedHandlers = NamedHandlers+  { nhHealth  :: IO Text+  , nhGetUser :: PathCapture Int -> IO (Json Text)+  }++instance NamedApi ErgoAPI NamedHandlers (IO Text, PathCapture Int -> IO (Json Text)) where+  toHandlerTuple h = (nhHealth h, nhGetUser h)++testNamedRoutes :: IO ()+testNamedRoutes = do+  let svc = mkNamedApi @ErgoAPI NamedHandlers+        { nhHealth  = pure "ok"+        , nhGetUser = \(PathCapture n) -> pure (Json (T.pack ("user-" ++ show n)))+        }++  -- GET /health+  req1 <- mkReq "GET" ["health"] "/health" ""+  resp1 <- runService svc req1+  assert "named: GET /health -> 200" (statusCode (responseStatus resp1) == 200)+  assert "named: GET /health -> 'ok'" (responseBody resp1 == "ok")++  -- GET /users/42 via PathCapture+  req2 <- mkReq "GET" ["users", "42"] "/users/42" ""+  resp2 <- runService svc req2+  assert "named: GET /users/42 -> 200" (statusCode (responseStatus resp2) == 200)+  let decoded2 = Aeson.decode (LBS.fromStrict (responseBody resp2)) :: Maybe Text+  assert "named: GET /users/42 -> 'user-42'" (decoded2 == Just "user-42")++  -- 404+  req3 <- mkReq "GET" ["nope"] "/nope" ""+  resp3 <- runService svc req3+  assert "named: GET /nope -> 404" (statusCode (responseStatus resp3) == 404)++  -- 405+  req4 <- mkReq "POST" ["health"] "/health" ""+  resp4 <- runService svc req4+  assert "named: POST /health -> 405" (statusCode (responseStatus resp4) == 405)+++-- ===================================================================+-- Test: Content negotiation — parseAccept+-- ===================================================================++testParseAccept :: IO ()+testParseAccept = do+  -- Basic parsing with quality values+  let parsed1 = parseAccept "application/json, text/plain;q=0.9, application/xml;q=0.8"+  assert "parseAccept: 3 entries" (length parsed1 == 3)+  assert "parseAccept: json first (q=1.0)" (fst (head parsed1) == "application/json")+  assert "parseAccept: json quality 1.0" (snd (head parsed1) == 1.0)+  assert "parseAccept: text/plain q=0.9" (snd (parsed1 !! 1) == 0.9)+  assert "parseAccept: application/xml q=0.8" (snd (parsed1 !! 2) == 0.8)++  -- Missing quality defaults to 1.0+  let parsed2 = parseAccept "text/html"+  assert "parseAccept: missing q defaults to 1.0" (parsed2 == [("text/html", 1.0)])++  -- Empty header+  let parsed3 = parseAccept ""+  assert "parseAccept: empty header -> []" (null parsed3)++  -- Wildcard+  let parsed4 = parseAccept "*/*"+  assert "parseAccept: wildcard" (parsed4 == [("*/*", 1.0)])++  -- Quality ordering: lower q comes later+  let parsed5 = parseAccept "text/plain;q=0.5, application/json;q=0.9"+  assert "parseAccept: sorted by quality desc" (fst (head parsed5) == "application/json")+++-- ===================================================================+-- Test: Content negotiation — matchFormat+-- ===================================================================++testMatchFormat :: IO ()+testMatchFormat = do+  let jsonEnc :: Text -> ByteString+      jsonEnc = TE.encodeUtf8++      xmlEnc :: Text -> ByteString+      xmlEnc t = TE.encodeUtf8 ("<v>" <> t <> "</v>")++      formats :: [(Text, Text -> ByteString)]+      formats = [("application/json", jsonEnc), ("application/xml", xmlEnc)]++  -- Picks highest quality match+  case matchFormat "application/json, application/xml;q=0.8" formats of+    Just (ct, enc) -> do+      assert "matchFormat: picks json" (ct == "application/json")+      assert "matchFormat: encodes with json encoder" (enc "hello" == "hello")+    Nothing -> assert "matchFormat: picks json" False++  -- Picks xml when json not available+  let xmlOnly = [("application/xml", xmlEnc)]+  case matchFormat "application/json, application/xml;q=0.8" xmlOnly of+    Just (ct, _) -> assert "matchFormat: falls back to xml" (ct == "application/xml")+    Nothing      -> assert "matchFormat: falls back to xml" False++  -- Falls back to first available when no Accept match+  case matchFormat "text/csv" formats of+    Nothing -> assert "matchFormat: no match -> Nothing" True+    Just _  -> assert "matchFormat: no match -> Nothing" False++  -- Wildcard */* matches first available+  case matchFormat "*/*" formats of+    Just (ct, _) -> assert "matchFormat: wildcard picks first" (ct == "application/json")+    Nothing      -> assert "matchFormat: wildcard picks first" False++  -- Empty Accept header -> first available+  case matchFormat "" formats of+    Just (ct, _) -> assert "matchFormat: empty accept -> first" (ct == "application/json")+    Nothing      -> assert "matchFormat: empty accept -> first" False+++-- ===================================================================+-- Test: Content negotiation — negotiate+-- ===================================================================++testNegotiate :: IO ()+testNegotiate = do+  let jsonEnc :: Text -> ByteString+      jsonEnc = TE.encodeUtf8++      xmlEnc :: Text -> ByteString+      xmlEnc t = TE.encodeUtf8 ("<v>" <> t <> "</v>")++      formats :: [(Text, Text -> ByteString)]+      formats = [("application/json", jsonEnc), ("application/xml", xmlEnc)]++  -- Successful negotiation+  let resp1 = negotiate "application/json" formats ("hello" :: Text)+  assert "negotiate: 200 for json match" (responseStatus resp1 == status200)+  assert "negotiate: body is json-encoded" (responseBody resp1 == "hello")+  assert "negotiate: Content-Type set"+    (lookup "Content-Type" (responseHeaders resp1) == Just "application/json")++  -- 406 when no match+  let resp2 = negotiate "text/csv" formats ("hello" :: Text)+  assert "negotiate: 406 for no match" (responseStatus resp2 == status406)+++-- ===================================================================+-- Test: Path helpers compile-time checks+-- ===================================================================++-- These are compile-time tests: if they compile, the type equalities hold.+-- At runtime we just confirm they're reachable.++-- At "x" ~ '[ 'Lit "x" ]+type AtX = At "x"+type AtXExpected = '[ 'Lit "x" ]++-- Param "x" Int ~ '[ 'Lit "x", 'Capture Int ]+type ParamXInt = Param "x" Int+type ParamXIntExpected = '[ 'Lit "x", 'Capture Int ]++-- At2 "a" "b" ~ '[ 'Lit "a", 'Lit "b" ]+type At2AB = At2 "a" "b"+type At2ABExpected = '[ 'Lit "a", 'Lit "b" ]++-- The GHC constraint trick: if these don't hold, we get a compile error.+testPathHelpers :: (AtX ~ AtXExpected, ParamXInt ~ ParamXIntExpected, At2AB ~ At2ABExpected) => IO ()+testPathHelpers = do+  -- If we reach here, all three type equalities compiled successfully.+  assert "At \"x\" ~ '[ 'Lit \"x\" ]" True+  assert "Param \"x\" Int ~ '[ 'Lit \"x\", 'Capture Int ]" True+  assert "At2 \"a\" \"b\" ~ '[ 'Lit \"a\", 'Lit \"b\" ]" True++  -- Additional: verify At/Param/At2 work in endpoint definitions+  let meth = endpointMethod @(Get (At "health") Text)+  assert "At in endpoint: method GET" (meth == "GET")+  let pat = endpointPattern @(Get (At "health") Text)+  assert "At in endpoint: pattern /health" (pat == "/health")++  let pat2 = endpointPattern @(Get (Param "users" Int) (Json Text))+  assert "Param in endpoint: pattern /users/{capture}" (pat2 == "/users/{capture}")++  let pat3 = endpointPattern @(Get (At2 "api" "health") Text)+  assert "At2 in endpoint: pattern /api/health" (pat3 == "/api/health")+++-- ===================================================================+-- Test: Named routes — additional coverage+-- ===================================================================++testNamedRoutesExtended :: IO ()+testNamedRoutesExtended = do+  let svc = mkNamedApi @ErgoAPI NamedHandlers+        { nhHealth  = pure "ok"+        , nhGetUser = \(PathCapture n) -> pure (Json (T.pack ("user-" ++ show n)))+        }++  -- Multiple user IDs work correctly+  req1 <- mkReq "GET" ["users", "1"] "/users/1" ""+  resp1 <- runService svc req1+  let decoded1 = Aeson.decode (LBS.fromStrict (responseBody resp1)) :: Maybe Text+  assert "named-ext: GET /users/1 -> 'user-1'" (decoded1 == Just "user-1")++  req2 <- mkReq "GET" ["users", "999"] "/users/999" ""+  resp2 <- runService svc req2+  let decoded2 = Aeson.decode (LBS.fromStrict (responseBody resp2)) :: Maybe Text+  assert "named-ext: GET /users/999 -> 'user-999'" (decoded2 == Just "user-999")++  -- DELETE /health -> 405 (only GET defined)+  req3 <- mkReq "DELETE" ["health"] "/health" ""+  resp3 <- runService svc req3+  assert "named-ext: DELETE /health -> 405" (statusCode (responseStatus resp3) == 405)++  -- PUT /users/1 -> 405+  req4 <- mkReq "PUT" ["users", "1"] "/users/1" ""+  resp4 <- runService svc req4+  assert "named-ext: PUT /users/1 -> 405" (statusCode (responseStatus resp4) == 405)++  -- 404 for deep unknown paths+  req5 <- mkReq "GET" ["a", "b", "c"] "/a/b/c" ""+  resp5 <- runService svc req5+  assert "named-ext: GET /a/b/c -> 404" (statusCode (responseStatus resp5) == 404)+++-- ===================================================================+-- Test: Content negotiation — additional parseAccept tests+-- ===================================================================++testParseAcceptExtended :: IO ()+testParseAcceptExtended = do+  -- Multiple types with mixed quality+  let parsed1 = parseAccept "text/html;q=0.5, application/json;q=1.0, text/plain;q=0.7"+  assert "parseAccept-ext: 3 entries" (length parsed1 == 3)+  assert "parseAccept-ext: json first (highest q)" (fst (head parsed1) == "application/json")+  assert "parseAccept-ext: plain second" (fst (parsed1 !! 1) == "text/plain")+  assert "parseAccept-ext: html last" (fst (parsed1 !! 2) == "text/html")++  -- Multiple types with same quality: stable ordering+  let parsed2 = parseAccept "text/html, application/json"+  assert "parseAccept-ext: same q, 2 entries" (length parsed2 == 2)++  -- Whitespace handling+  let parsed3 = parseAccept " application/json , text/plain ; q=0.5 "+  assert "parseAccept-ext: whitespace stripped, 2 entries" (length parsed3 == 2)++  -- Wildcard */* with quality+  let parsed4 = parseAccept "*/*;q=0.1, application/json"+  assert "parseAccept-ext: wildcard with q" (length parsed4 == 2)+  assert "parseAccept-ext: json before wildcard" (fst (head parsed4) == "application/json")+++-- ===================================================================+-- Test: negotiate — additional 406 edge cases+-- ===================================================================++testNegotiateExtended :: IO ()+testNegotiateExtended = do+  let jsonEnc :: Text -> ByteString+      jsonEnc = TE.encodeUtf8++      formats :: [(Text, Text -> ByteString)]+      formats = [("application/json", jsonEnc)]++  -- 406 with specific non-matching Accept+  let resp1 = negotiate "application/xml" formats ("hello" :: Text)+  assert "negotiate-ext: 406 for xml-only Accept" (responseStatus resp1 == status406)++  -- Success with exact match+  let resp2 = negotiate "application/json" formats ("world" :: Text)+  assert "negotiate-ext: 200 for exact match" (responseStatus resp2 == status200)+  assert "negotiate-ext: body correct" (responseBody resp2 == "world")++  -- Wildcard Accept matches+  let resp3 = negotiate "*/*" formats ("star" :: Text)+  assert "negotiate-ext: 200 for wildcard" (responseStatus resp3 == status200)++  -- Empty formats list -> 406+  let emptyFormats :: [(Text, Text -> ByteString)]+      emptyFormats = []+  let resp4 = negotiate "application/json" emptyFormats ("test" :: Text)+  assert "negotiate-ext: 406 for empty formats" (responseStatus resp4 == status406)+++-- ===================================================================+-- Test: mkRecordApi (automatic record-based handler binding)+-- ===================================================================++-- | Named API: endpoints wrapped with Named for record-based binding.+-- Deliberately in a different order from the record fields to prove+-- that name matching, not position, determines the binding.+type RecordAPI =+  '[ Named "health"  (Get HealthPath Text)+   , Named "getUser" (Get UserByIdPath (Json Text))+   ]++-- | Handler record with fields in REVERSE order of the API.+data RecordHandlers = RecordHandlers+  { getUser :: PathCapture Int -> IO (Json Text)+  , health  :: IO Text+  }++testRecordApi :: IO ()+testRecordApi = do+  let svc = mkRecordApi @RecordAPI RecordHandlers+        { health  = pure "ok-record"+        , getUser = \(PathCapture n) -> pure (Json (T.pack ("rec-user-" ++ show n)))+        }++  -- GET /health+  req1 <- mkReq "GET" ["health"] "/health" ""+  resp1 <- runService svc req1+  assert "recordApi: GET /health -> 200" (statusCode (responseStatus resp1) == 200)+  assert "recordApi: GET /health -> 'ok-record'" (responseBody resp1 == "ok-record")++  -- GET /users/7+  req2 <- mkReq "GET" ["users", "7"] "/users/7" ""+  resp2 <- runService svc req2+  let decoded2 = Aeson.decode (LBS.fromStrict (responseBody resp2)) :: Maybe Text+  assert "recordApi: GET /users/7 -> 200" (statusCode (responseStatus resp2) == 200)+  assert "recordApi: GET /users/7 -> 'rec-user-7'" (decoded2 == Just "rec-user-7")++  -- 404+  req3 <- mkReq "GET" ["nope"] "/nope" ""+  resp3 <- runService svc req3+  assert "recordApi: GET /nope -> 404" (statusCode (responseStatus resp3) == 404)++  -- 405+  req4 <- mkReq "POST" ["health"] "/health" ""+  resp4 <- runService svc req4+  assert "recordApi: POST /health -> 405" (statusCode (responseStatus resp4) == 405)+++-- | Named API + Describe wrapper stacking.+type DescribedRecordAPI =+  '[ Named "health" (Describe "Health check" (Get HealthPath Text))+   ]++data DescribedHandlers = DescribedHandlers+  { dHealth :: IO Text+  }++testRecordApiWithDescribe :: IO ()+testRecordApiWithDescribe = do+  -- Named composes with other wrappers (Describe in this case)+  -- We can't use 'health' as field name because it conflicts with RecordHandlers+  -- so we use a different API with different field names+  let svc = mkRecordApi @'[ Named "dHealth" (Describe "Health check" (Get HealthPath Text)) ]+        DescribedHandlers { dHealth = pure "described-ok" }++  req1 <- mkReq "GET" ["health"] "/health" ""+  resp1 <- runService svc req1+  assert "recordApi+Describe: GET /health -> 200" (statusCode (responseStatus resp1) == 200)+  assert "recordApi+Describe: GET /health -> 'described-ok'" (responseBody resp1 == "described-ok")+++-- | Named API used with tuples (Named is transparent).+testNamedWithTuples :: IO ()+testNamedWithTuples = do+  let svc = mkApi @RecordAPI+        ( pure "tuple-health" :: IO Text+        , \(PathCapture n) -> pure (Json (T.pack ("tuple-user-" ++ show (n :: Int)))) :: IO (Json Text)+        )++  req1 <- mkReq "GET" ["health"] "/health" ""+  resp1 <- runService svc req1+  assert "namedTuple: GET /health -> 200" (statusCode (responseStatus resp1) == 200)+  assert "namedTuple: GET /health -> 'tuple-health'" (responseBody resp1 == "tuple-health")++  req2 <- mkReq "GET" ["users", "3"] "/users/3" ""+  resp2 <- runService svc req2+  let decoded2 = Aeson.decode (LBS.fromStrict (responseBody resp2)) :: Maybe Text+  assert "namedTuple: GET /users/3 -> 'tuple-user-3'" (decoded2 == Just "tuple-user-3")+++-- ===================================================================+-- Test: Versioned routing+-- ===================================================================++data V1+instance ApiVersion V1 where versionPrefix = "v1"++type VersionedHealthAPI = '[ Versioned V1 (Get HealthPath Text) ]++testVersionedRouting :: IO ()+testVersionedRouting = do+  let svc = mkApi @VersionedHealthAPI (pure "ok" :: IO Text)++  -- GET /v1/health -> 200+  req1 <- mkReq "GET" ["v1", "health"] "/v1/health" ""+  resp1 <- runService svc req1+  assert "versioned: GET /v1/health -> 200" (statusCode (responseStatus resp1) == 200)+  assert "versioned: GET /v1/health -> 'ok'" (responseBody resp1 == "ok")++  -- GET /health -> 404 (version prefix required)+  req2 <- mkReq "GET" ["health"] "/health" ""+  resp2 <- runService svc req2+  assert "versioned: GET /health -> 404" (statusCode (responseStatus resp2) == 404)+++-- ===================================================================+-- Test: ValidatedBody extraction+-- ===================================================================++data NonEmptyValidator++instance Validate NonEmptyValidator Text where+  validate t+    | T.null t  = Left "must not be empty"+    | otherwise = Right t++testValidatedBody :: IO ()+testValidatedBody = do+  let handler :: ValidatedBody NonEmptyValidator Text -> IO (Json Text)+      handler (ValidatedBody t) = pure (Json t)+  let svc = mkApi @'[Post (At "items") (Json Text) (Json Text)] handler++  -- Valid body+  req1 <- mkReq "POST" ["items"] "/items" "\"hello\""+  resp1 <- runService svc req1+  assert "validated: valid body -> 200" (statusCode (responseStatus resp1) == 200)++  -- Invalid body (empty string)+  req2 <- mkReq "POST" ["items"] "/items" "\"\""+  resp2 <- runService svc req2+  assert "validated: empty body -> 422" (statusCode (responseStatus resp2) == 422)+++-- ===================================================================+-- Test: SSE chunk encoding+-- ===================================================================++testSSEChunk :: IO ()+testSSEChunk = do+  let chunk = sseChunk (sseData ("hello" :: Text))+  assert "SSE: chunk contains data:" (BS.isInfixOf "data: " chunk)+  assert "SSE: chunk contains payload" (BS.isInfixOf "hello" chunk)+  assert "SSE: chunk ends with double newline" (BS.isSuffixOf "\n\n" chunk)++  -- With event type+  let chunk2 = sseChunk (sseEvent "update" ("world" :: Text))+  assert "SSE: event type present" (BS.isInfixOf "event: update" chunk2)+++-- ===================================================================+-- Test: Route precedence (literal beats capture, declaration-order+-- independent)+-- ===================================================================++-- Same prefix /articles, then either a literal "feed" or a Text capture.+type ArticlesFeedPath = '[ 'Lit "articles", 'Lit "feed" ]+type ArticlesSlugPath = '[ 'Lit "articles", 'Capture Text ]++-- Order A: literal first, then capture+type RouteOrderA =+  '[ Get ArticlesFeedPath (Json Text)+   , Get ArticlesSlugPath (Json Text)+   ]++-- Order B: capture first, then literal (used to match the wrong route)+type RouteOrderB =+  '[ Get ArticlesSlugPath (Json Text)+   , Get ArticlesFeedPath (Json Text)+   ]++testRoutePrecedence :: IO ()+testRoutePrecedence = do+  let feedH :: RequestParts -> ByteString -> IO (Response ByteString)+      feedH _ _ = pure $ intoResponse (Json ("feed" :: Text))+      slugH :: RequestParts -> ByteString -> IO (Response ByteString)+      slugH parts _ = do+        mCaps <- lookupExtension @CaptureList (rpExtensions parts)+        case mCaps of+          Just (CaptureList (s : _)) -> pure $ intoResponse (Json ("slug-" <> s))+          _ -> pure $ intoResponse (Json ("slug-?" :: Text))++  let svcA = mkServer @RouteOrderA+        ( wrapHandler @(Get ArticlesFeedPath (Json Text)) feedH+        , wrapHandler @(Get ArticlesSlugPath (Json Text)) slugH+        )+      svcB = mkServer @RouteOrderB+        ( wrapHandler @(Get ArticlesSlugPath (Json Text)) slugH+        , wrapHandler @(Get ArticlesFeedPath (Json Text)) feedH+        )++  -- Order A: literal-first declaration. /articles/feed must hit feed.+  reqFeed <- mkReq "GET" ["articles", "feed"] "/articles/feed" ""+  respAFeed <- runService svcA reqFeed+  let decAFeed = Aeson.decode (LBS.fromStrict (responseBody respAFeed)) :: Maybe Text+  assert "RoutePrecedence: order A /articles/feed -> feed"+    (decAFeed == Just "feed")++  reqSlug <- mkReq "GET" ["articles", "hello"] "/articles/hello" ""+  respASlug <- runService svcA reqSlug+  let decASlug = Aeson.decode (LBS.fromStrict (responseBody respASlug)) :: Maybe Text+  assert "RoutePrecedence: order A /articles/hello -> slug-hello"+    (decASlug == Just "slug-hello")++  -- Order B: capture-first declaration. Specificity-based ordering must+  -- still pick the literal first, so /articles/feed hits feed (not slug).+  respBFeed <- runService svcB reqFeed+  let decBFeed = Aeson.decode (LBS.fromStrict (responseBody respBFeed)) :: Maybe Text+  assert "RoutePrecedence: order B /articles/feed -> feed (literal beats capture)"+    (decBFeed == Just "feed")++  respBSlug <- runService svcB reqSlug+  let decBSlug = Aeson.decode (LBS.fromStrict (responseBody respBSlug)) :: Maybe Text+  assert "RoutePrecedence: order B /articles/hello -> slug-hello"+    (decBSlug == Just "slug-hello")+++-- ===================================================================+-- Main+-- ===================================================================++main :: IO ()+main = do+  putStrLn "acolyte-server tests:"+  putStrLn ""+  putStrLn "Endpoint metadata:"+  testMetadata+  putStrLn ""+  putStrLn "IntoResponse:"+  testResponses+  putStrLn ""+  putStrLn "mkServer (automatic wiring):"+  testMkServer+  putStrLn ""+  putStrLn "Spire middleware composition:"+  testWithMiddleware+  putStrLn ""+  putStrLn "EffectfulServer (typed middleware tracking):"+  testEffectfulServer+  putStrLn ""+  putStrLn "Sub-API composition (combineServer):"+  testCombineServer+  putStrLn ""+  putStrLn "Combined effectful server:"+  testCombinedEffects+  putStrLn ""+  putStrLn "ToHandler (ergonomic handlers):"+  testToHandler+  putStrLn ""+  putStrLn "mkApi (ergonomic server construction):"+  testMkApi+  putStrLn ""+  putStrLn "PathCapture FromRequestParts:"+  testPathCapture+  putStrLn ""+  putStrLn "QueryParam extraction:"+  testQueryParam+  putStrLn ""+  putStrLn "JsonBody via FromRequestParts:"+  testJsonBody+  putStrLn ""+  putStrLn "HeaderMap extraction:"+  testHeaderMap+  putStrLn ""+  putStrLn "FullRequest extraction:"+  testFullRequest+  putStrLn ""+  putStrLn "RawQuery extraction:"+  testRawQuery+  putStrLn ""+  putStrLn "RawPathParams extraction:"+  testRawPathParams+  putStrLn ""+  putStrLn "StringBody extraction:"+  testStringBody+  putStrLn ""+  putStrLn "MatchedPath extraction:"+  testMatchedPathExtract+  putStrLn ""+  putStrLn "OriginalUri extraction:"+  testOriginalUri+  putStrLn ""+  putStrLn "NestedPath extraction:"+  testNestedPath+  putStrLn ""+  putStrLn "RawForm extraction:"+  testRawForm+  putStrLn ""+  putStrLn "Form extraction:"+  testForm+  putStrLn ""+  putStrLn "Multipart extraction:"+  testMultipart+  putStrLn ""+  putStrLn "ConnectInfo extractor:"+  testConnectInfo+  putStrLn ""+  putStrLn "ReqMethod extractor:"+  testReqMethod+  putStrLn ""+  putStrLn "Extension extractor:"+  testExtension+  putStrLn ""+  putStrLn "Optional extractor:"+  testOptional+  putStrLn ""+  putStrLn "AppState extractor:"+  testAppState+  putStrLn ""+  putStrLn "ToHandler with two extractors:"+  testToHandlerTwoArgs+  putStrLn ""+  putStrLn "ToHandler with body + parts:"+  testToHandlerBodyParts+  putStrLn ""+  putStrLn "ToHandler error propagation:"+  testToHandlerErrorProp+  putStrLn ""+  putStrLn "Named routes (record-based handlers):"+  testNamedRoutes+  putStrLn ""+  putStrLn "Content negotiation — parseAccept:"+  testParseAccept+  putStrLn ""+  putStrLn "Content negotiation — matchFormat:"+  testMatchFormat+  putStrLn ""+  putStrLn "Content negotiation — negotiate:"+  testNegotiate+  putStrLn ""+  putStrLn "Path helpers (compile-time checks):"+  testPathHelpers+  putStrLn ""+  putStrLn "Named routes (extended):"+  testNamedRoutesExtended+  putStrLn ""+  putStrLn "Content negotiation — parseAccept (extended):"+  testParseAcceptExtended+  putStrLn ""+  putStrLn "Content negotiation — negotiate (extended):"+  testNegotiateExtended+  putStrLn ""+  putStrLn "mkRecordApi (automatic record-based binding):"+  testRecordApi+  putStrLn ""+  putStrLn "mkRecordApi + Describe wrapper:"+  testRecordApiWithDescribe+  putStrLn ""+  putStrLn "Named endpoints with tuples (transparency):"+  testNamedWithTuples+  putStrLn ""+  putStrLn "Versioned routing:"+  testVersionedRouting+  putStrLn ""+  putStrLn "ValidatedBody extraction:"+  testValidatedBody+  putStrLn ""+  putStrLn "SSE chunk encoding:"+  testSSEChunk+  putStrLn ""+  putStrLn "Route precedence (literal beats capture):"+  testRoutePrecedence+  putStrLn ""+  putStrLn "All acolyte-server tests passed."

@@ -0,0 +1,259 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Control.Exception (evaluate, try, SomeException)+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE++import Data.Foldable (for_)+import qualified Data.Aeson as Aeson++import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import Acolyte.Server+  ( parseFormUrlEncoded, parseMultipart, ParseCapture(..)+  , FilePart(..)+  , Json(..), IntoResponse(..), intoResponse, mkError, ServerError(..)+  )+import Acolyte.Server.Negotiate (parseAccept, matchFormat)+import Http.Core (Response(..), responseStatus, responseBody)+import Network.HTTP.Types (status400, status404, status422, status500, statusCode)+++-- ===================================================================+-- Generators+-- ===================================================================++-- | Generate an ASCII alphanumeric ByteString (no encoding issues).+genAlphaBS :: Gen ByteString+genAlphaBS = TE.encodeUtf8 <$> Gen.text (Range.linear 1 20) Gen.alphaNum+++-- ===================================================================+-- Property: Form URL encoding roundtrip+-- ===================================================================++prop_formUrlEncodedRoundtrip :: Property+prop_formUrlEncodedRoundtrip = property $ do+  pairs <- forAll $ Gen.list (Range.linear 0 10) ((,) <$> genAlphaBS <*> genAlphaBS)+  let encoded = BS.intercalate "&" [ k <> "=" <> v | (k, v) <- pairs ]+      decoded = parseFormUrlEncoded encoded+  -- Empty input gives empty output+  if null pairs+    then decoded === []+    else decoded === pairs+++-- ===================================================================+-- Property: Multipart roundtrip+-- ===================================================================++prop_multipartRoundtrip :: Property+prop_multipartRoundtrip = property $ do+  -- Generate (fieldName, bodyContent) pairs with safe ASCII content+  pairs <- forAll $ Gen.list (Range.linear 1 5) $ do+    name <- Gen.text (Range.linear 1 20) Gen.alphaNum+    body <- Gen.text (Range.linear 0 50) Gen.alphaNum+    pure (name, body)++  let boundary = "testboundary123" :: ByteString+      -- Construct multipart wire format+      parts = [ "--" <> boundary <> "\r\n"+                <> "Content-Disposition: form-data; name=\"" <> TE.encodeUtf8 name <> "\"\r\n"+                <> "\r\n"+                <> TE.encodeUtf8 body <> "\r\n"+              | (name, body) <- pairs+              ]+      wire = BS.concat parts <> "--" <> boundary <> "--\r\n"+      parsed = parseMultipart boundary wire+      parsedPairs = [ (fpFieldName fp, TE.decodeUtf8 (fpBody fp))+                    | fp <- parsed+                    ]++  -- Verify field names and bodies match+  map fst parsedPairs === map fst pairs+  map snd parsedPairs === map snd pairs+++-- ===================================================================+-- Property: ParseCapture Int roundtrip+-- ===================================================================++prop_parseCaptureIntRoundtrip :: Property+prop_parseCaptureIntRoundtrip = property $ do+  n <- forAll $ Gen.int (Range.linear 0 maxBound)+  parseCapture (T.pack (show n)) === Just n+++-- ===================================================================+-- Property: ParseCapture Text identity+-- ===================================================================++prop_parseCaptureTextIdentity :: Property+prop_parseCaptureTextIdentity = property $ do+  t <- forAll $ Gen.text (Range.linear 0 100) Gen.unicode+  parseCapture t === Just t+++-- ===================================================================+-- Property: Json IntoResponse roundtrip via aeson+-- ===================================================================++prop_intoResponseJsonRoundtrip :: Property+prop_intoResponseJsonRoundtrip = property $ do+  val <- forAll $ Gen.text (Range.linear 0 100) Gen.unicode+  let resp = intoResponse (Json val)+      decoded = Aeson.decodeStrict' (responseBody resp) :: Maybe Text+  decoded === Just val+++-- ===================================================================+-- Property: Either Left error status is preserved+-- ===================================================================++prop_intoResponseEitherLeft :: Property+prop_intoResponseEitherLeft = property $ do+  s <- forAll $ Gen.element [status400, status404, status422, status500]+  msg <- forAll $ Gen.text (Range.linear 0 50) Gen.alphaNum+  let resp = intoResponse (Left (mkError s msg) :: Either ServerError (Json Text))+  statusCode (responseStatus resp) === statusCode s+++-- ===================================================================+-- Property: Either Right gives status 200+-- ===================================================================++prop_intoResponseEitherRight :: Property+prop_intoResponseEitherRight = property $ do+  val <- forAll $ Gen.text (Range.linear 0 100) Gen.unicode+  let resp = intoResponse (Right (Json val) :: Either ServerError (Json Text))+  statusCode (responseStatus resp) === 200+++-- ===================================================================+-- Property: ServerError status is preserved in response+-- ===================================================================++prop_serverErrorStatusPreserved :: Property+prop_serverErrorStatusPreserved = property $ do+  s <- forAll $ Gen.element [status400, status404, status422, status500]+  msg <- forAll $ Gen.text (Range.linear 0 50) Gen.alphaNum+  let resp = intoResponse (mkError s msg)+  statusCode (responseStatus resp) === statusCode s+++-- ===================================================================+-- Property: matchFormat picks the highest quality available format+-- ===================================================================++prop_negotiatePicksHighestQuality :: Property+prop_negotiatePicksHighestQuality = property $ do+  -- Generate distinct quality values from a fixed set to avoid+  -- floating-point formatting issues. Values are valid HTTP q-values.+  qJson  <- forAll $ Gen.element [0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9, 1.0 :: Double]+  qPlain <- forAll $ Gen.element [0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9, 1.0 :: Double]++  -- Build an Accept header with explicit quality values+  let showQ q = show q+      acceptHdr = TE.encodeUtf8 $ T.pack $+        "application/json;q=" ++ showQ qJson ++ ", text/plain;q=" ++ showQ qPlain++      available :: [(Text, Text -> ByteString)]+      available =+        [ ("application/json", TE.encodeUtf8)+        , ("text/plain",       TE.encodeUtf8)+        ]++  case matchFormat acceptHdr available of+    Nothing -> failure  -- Should always match at least one+    Just (ct, _enc) ->+      if qJson >= qPlain+        then ct === "application/json"+        else ct === "text/plain"+++-- ===================================================================+-- Property: parseAccept roundtrip — extracts correct media types+-- ===================================================================++prop_parseAcceptRoundtrip :: Property+prop_parseAcceptRoundtrip = property $ do+  -- Generate a list of (media-type, quality) pairs+  entries <- forAll $ Gen.list (Range.linear 1 5) $ do+    mtype <- Gen.element+      [ "application/json"+      , "text/plain"+      , "text/html"+      , "application/xml"+      , "image/png"+      ]+    q <- Gen.element [0.1, 0.2, 0.3, 0.5, 0.7, 0.8, 0.9, 1.0]+    pure (mtype :: Text, q :: Double)++  -- Build Accept header string+  let formatEntry (mt, q) =+        if q == 1.0+          then mt+          else mt <> ";q=" <> T.pack (show q)+      acceptStr = TE.encodeUtf8 $ T.intercalate ", " (map formatEntry entries)++  let parsed = parseAccept acceptStr+      -- Extract just the media types from the parsed result+      parsedTypes = map fst parsed++  -- Every media type from the input should appear in the parsed output+  annotateShow parsed+  for_ entries $ \(mt, _q) ->+    assert (TE.encodeUtf8 mt `elem` parsedTypes)+++-- ===================================================================+-- Fuzz: multipart parser never crashes on arbitrary input+-- ===================================================================++-- | Feed random bytes as boundary and body to parseMultipart and assert+-- it returns a result (never throws an uncaught exception).+prop_multipartParserDoesNotCrash :: Property+prop_multipartParserDoesNotCrash = property $ do+  boundary <- forAll $ Gen.bytes (Range.linear 1 50)+  body <- forAll $ Gen.bytes (Range.linear 0 10000)+  let parts = parseMultipart boundary body+  -- Force evaluation of all parts+  _ <- evalIO $ try @SomeException $+    evaluate (length parts `seq` ())+  success+++-- ===================================================================+-- Fuzz: form URL parser never crashes on arbitrary input+-- ===================================================================++-- | Feed random bytes to parseFormUrlEncoded and assert it returns+-- a result (never throws an uncaught exception).+prop_formParserDoesNotCrash :: Property+prop_formParserDoesNotCrash = property $ do+  bs <- forAll $ Gen.bytes (Range.linear 0 5000)+  let pairs = parseFormUrlEncoded bs+  -- Force evaluation of all pairs+  _ <- evalIO $ try @SomeException $+    evaluate (length pairs `seq` ())+  success+++-- ===================================================================+-- Main+-- ===================================================================++tests :: IO Bool+tests = checkParallel $$(discover)++main :: IO ()+main = do+  ok <- tests+  if ok then pure () else error "Property tests failed"

@@ -0,0 +1,86 @@+-- | Compile-time error tests for mkRecordApi and BuildRecordApi.+--+-- Each test case is a separate .hs file in typeerror-cases/ that should+-- fail to compile. This runner invokes GHC (via cabal exec) on each and+-- verifies the compilation fails with the expected error message.+module Main (main) where++import System.Exit (ExitCode (..))+import System.Process (readProcessWithExitCode)+import System.Directory (getCurrentDirectory)+++assert :: String -> Bool -> IO ()+assert label True  = putStrLn $ "  OK: " ++ label+assert label False = error   $ "FAIL: " ++ label+++shouldFailToCompile :: FilePath -> String -> IO Bool+shouldFailToCompile file expectedFragment = do+  cwd <- getCurrentDirectory+  let casePath = cwd ++ "/test/typeerror-cases/" ++ file++  (exitCode, _stdout, stderr) <- readProcessWithExitCode "cabal"+    [ "exec", "--", "ghc"+    , "-fno-code"+    , "-no-keep-hi-files"+    , "-package", "acolyte-core"+    , "-package", "acolyte-server"+    , "-package", "spire"+    , "-package", "http-core"+    , "-package", "bytestring"+    , "-package", "text"+    , casePath+    ] ""+  case exitCode of+    ExitFailure _ ->+      if expectedFragment `isInfixOf'` stderr+        then pure True+        else do+          putStrLn $ "    ERROR (wrong message): " ++ take 500 stderr+          putStrLn $ "    EXPECTED: " ++ expectedFragment+          pure False+    ExitSuccess -> do+      putStrLn $ "    UNEXPECTED: " ++ file ++ " compiled successfully"+      pure False+++isInfixOf' :: String -> String -> Bool+isInfixOf' needle haystack = any (isPrefixOf' needle) (tails' haystack)++isPrefixOf' :: String -> String -> Bool+isPrefixOf' [] _          = True+isPrefixOf' _ []          = False+isPrefixOf' (x:xs) (y:ys) = x == y && isPrefixOf' xs ys++tails' :: [a] -> [[a]]+tails' [] = [[]]+tails' xs@(_:xs') = xs : tails' xs'+++main :: IO ()+main = do+  putStrLn "Named endpoint server compile-time error tests:"+  putStrLn ""++  putStrLn "mkRecordApi with non-Named endpoints (negative):"+  shouldFailToCompile "RecordApiBare.hs" "Expected a Named endpoint"+    >>= assert "mkRecordApi rejects API without Named wrappers"+  putStrLn ""++  putStrLn "mkRecordApi with duplicate names (negative):"+  shouldFailToCompile "RecordApiDupNames.hs" "Duplicate endpoint name"+    >>= assert "mkRecordApi rejects duplicate endpoint names"+  putStrLn ""++  putStrLn "mkRecordApi with missing record field (negative):"+  shouldFailToCompile "RecordApiMissingField.hs" "No instance for"+    >>= assert "mkRecordApi rejects record with wrong/missing fields"+  putStrLn ""++  putStrLn "Protected endpoint without auth argument (negative):"+  shouldFailToCompile "ProtectedWrongAuth.hs" "must be a function"+    >>= assert "Protected rejects handler without auth argument"+  putStrLn ""++  putStrLn "All Named server compile-time error tests passed."