diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,7 @@ +# Revision history for acolyte-test + +## 0.1.0.0 -- 2026-04-27 + +* Initial release. Test helpers for acolyte: in-process request + builders and response assertions that talk directly to a Service + without spinning up a real network stack. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/acolyte-test.cabal b/acolyte-test.cabal new file mode 100644 --- /dev/null +++ b/acolyte-test.cabal @@ -0,0 +1,87 @@ +cabal-version: 3.0 +name: acolyte-test +version: 0.1.0.0 +synopsis: Testing utilities for acolyte APIs +category: Web, Testing +description: + Test helpers for APIs built with acolyte. Direct dispatch + (no network), response assertions, and warp-based integration testing. + +license: BSD-3-Clause +license-file: LICENSE +author: Josh Burgess +maintainer: Josh Burgess +homepage: https://github.com/joshburgess/acolyte +bug-reports: https://github.com/joshburgess/acolyte/issues +build-type: Simple + +extra-doc-files: + CHANGELOG.md + +library + exposed-modules: + Acolyte.Test + Acolyte.Test.Grpc + Acolyte.Test.Property + + build-depends: + base >= 4.20 && < 5 + , acolyte-core >= 0.1 && < 0.2 + , acolyte-server >= 0.1 && < 0.2 + , spire >= 0.1 && < 0.2 + , spire-grpc >= 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 + , QuickCheck >= 2.14 && < 2.17 + + hs-source-dirs: src + default-language: GHC2024 + default-extensions: + DataKinds + TypeFamilies + TypeOperators + OverloadedStrings + AllowAmbiguousTypes + 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 + TypeFamilies + TypeOperators + OverloadedStrings + AllowAmbiguousTypes + ScopedTypeVariables + StrictData + + ghc-options: -Wall -rtsopts "-with-rtsopts=-K1K" + + build-depends: + base >= 4.20 && < 5 + , acolyte-test >= 0.1 && < 0.2 + , acolyte-core >= 0.1 && < 0.2 + , acolyte-server >= 0.1 && < 0.2 + , acolyte-openapi >= 0.1 && < 0.2 + , acolyte-grpc >= 0.1 && < 0.2 + , spire >= 0.1 && < 0.2 + , spire-grpc >= 0.1 && < 0.2 + , spire-server >= 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 + +source-repository head + type: git + location: https://github.com/joshburgess/acolyte.git diff --git a/src/Acolyte/Test.hs b/src/Acolyte/Test.hs new file mode 100644 --- /dev/null +++ b/src/Acolyte/Test.hs @@ -0,0 +1,187 @@ +-- | Testing utilities for acolyte APIs. +-- +-- Test APIs by dispatching requests directly through the spire Service +-- — no network, no warp, no ports. Fast and deterministic. +-- +-- @ +-- import Acolyte.Test +-- +-- test = do +-- let svc = mkServer @MyAPI handlers +-- resp <- request svc "GET" "/health" [] "" +-- resp `shouldHaveStatus` 200 +-- resp `shouldHaveBody` "ok" +-- @ +module Acolyte.Test + ( -- * Making requests + request + , get + , post + , put_ + , delete_ + , patch + -- * Response assertions + , shouldHaveStatus + , shouldHaveHeader + , shouldHaveBody + , shouldHaveJsonBody + , shouldMatchJson + -- * Utilities + , responseBody' + , responseStatus' + , responseHeaders' + ) 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 Network.HTTP.Types (Status, statusCode, RequestHeaders, Header, HeaderName) + +import qualified Data.Aeson as Aeson + +import Spire.Service (Service (..)) +import Http.Core + + +-- =================================================================== +-- Making requests +-- =================================================================== + +-- | Send a request to a spire Service (no network). +request + :: Service IO (Request ByteString) (Response ByteString) + -> ByteString -- ^ HTTP method + -> ByteString -- ^ Path (e.g., "/users/42") + -> RequestHeaders -- ^ Headers + -> ByteString -- ^ Body + -> IO (Response ByteString) +request svc method path headers body = do + exts <- emptyExtensions + let segments = filter (/= "") $ T.splitOn "/" (TE.decodeUtf8 path) + let req = Request + { requestMethod = method + , requestPathRaw = path + , requestPath = segments + , requestQuery = [] + , requestHeaders = headers + , requestBody = body + , requestExtensions = exts + } + runService svc req + + +-- | GET request with no body. +get :: Service IO (Request ByteString) (Response ByteString) + -> ByteString -> IO (Response ByteString) +get svc path = request svc "GET" path [] "" + + +-- | POST request with JSON body. +post :: Aeson.ToJSON a + => Service IO (Request ByteString) (Response ByteString) + -> ByteString -> a -> IO (Response ByteString) +post svc path body = request svc "POST" path + [("Content-Type", "application/json")] + (LBS.toStrict (Aeson.encode body)) + + +-- | PUT request with JSON body. +put_ :: Aeson.ToJSON a + => Service IO (Request ByteString) (Response ByteString) + -> ByteString -> a -> IO (Response ByteString) +put_ svc path body = request svc "PUT" path + [("Content-Type", "application/json")] + (LBS.toStrict (Aeson.encode body)) + + +-- | DELETE request with no body. +delete_ :: Service IO (Request ByteString) (Response ByteString) + -> ByteString -> IO (Response ByteString) +delete_ svc path = request svc "DELETE" path [] "" + + +-- | PATCH request with JSON body. +patch :: Aeson.ToJSON a + => Service IO (Request ByteString) (Response ByteString) + -> ByteString -> a -> IO (Response ByteString) +patch svc path body = request svc "PATCH" path + [("Content-Type", "application/json")] + (LBS.toStrict (Aeson.encode body)) + + +-- =================================================================== +-- Response assertions +-- =================================================================== + +-- | Assert response has the expected status code. +shouldHaveStatus :: Response ByteString -> Int -> IO () +shouldHaveStatus resp expected + | actual == expected = pure () + | otherwise = error $ + "Expected status " ++ show expected ++ " but got " ++ show actual + ++ "\nBody: " ++ show (responseBody resp) + where actual = statusCode (responseStatus resp) + + +-- | Assert response has a specific header with the expected value. +shouldHaveHeader :: Response ByteString -> HeaderName -> ByteString -> IO () +shouldHaveHeader resp name expected = + case lookup name (responseHeaders resp) of + Just actual | actual == expected -> pure () + Just actual -> error $ + "Header " ++ show name ++ ": expected " ++ show expected + ++ " but got " ++ show actual + Nothing -> error $ + "Header " ++ show name ++ " not found in response" + + +-- | Assert response body equals the expected bytes. +shouldHaveBody :: Response ByteString -> ByteString -> IO () +shouldHaveBody resp expected + | responseBody resp == expected = pure () + | otherwise = error $ + "Expected body " ++ show expected + ++ " but got " ++ show (responseBody resp) + + +-- | Assert response body decodes to the expected JSON value. +shouldHaveJsonBody :: (Aeson.FromJSON a, Eq a, Show a) + => Response ByteString -> a -> IO () +shouldHaveJsonBody resp expected = + case Aeson.eitherDecodeStrict' (responseBody resp) of + Right actual | actual == expected -> pure () + Right actual -> error $ + "Expected JSON " ++ show expected ++ " but got " ++ show actual + Left err -> error $ + "Failed to decode JSON: " ++ err ++ "\nBody: " ++ show (responseBody resp) + + +-- | Assert response body is valid JSON matching the expected Value. +shouldMatchJson :: Response ByteString -> Aeson.Value -> IO () +shouldMatchJson resp expected = + case Aeson.eitherDecodeStrict' (responseBody resp) of + Right actual | actual == expected -> pure () + Right actual -> error $ + "JSON mismatch.\nExpected: " ++ show expected + ++ "\nActual: " ++ show actual + Left err -> error $ "Failed to decode JSON: " ++ err + + +-- =================================================================== +-- Utilities +-- =================================================================== + +-- | Extract the status code as Int. +responseStatus' :: Response ByteString -> Int +responseStatus' = statusCode . responseStatus + +-- | Extract the body. +responseBody' :: Response ByteString -> ByteString +responseBody' = responseBody + +-- | Extract headers. +responseHeaders' :: Response ByteString -> [(HeaderName, ByteString)] +responseHeaders' = responseHeaders diff --git a/src/Acolyte/Test/Grpc.hs b/src/Acolyte/Test/Grpc.hs new file mode 100644 --- /dev/null +++ b/src/Acolyte/Test/Grpc.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | gRPC testing utilities for acolyte APIs. +-- +-- Test gRPC services by dispatching requests directly through the spire +-- Service -- no network, no HTTP/2, no ports. Fast and deterministic. +-- +-- @ +-- import Acolyte.Test.Grpc +-- +-- test = do +-- let svc = grpcServer myServiceMap +-- resp <- grpcCall svc "myapp.MySvc" "SayHello" reqBytes +-- resp `shouldHaveGrpcStatus` 0 +-- grpcResponseBody resp `shouldBe` expectedBytes +-- @ +module Acolyte.Test.Grpc + ( -- * Making gRPC requests + grpcCall + -- * Response assertions + , shouldHaveGrpcStatus + , shouldHaveGrpcBody + , grpcResponseBody + ) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +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 Spire.Service (Service (..)) +import Http.Core +import Http.Core.Body (Body, fromBytes, bodyToStrict) +import Spire.Grpc.Codec (encodeMessage, decodeMessage, GrpcMessage(..)) + + +-- =================================================================== +-- Making gRPC requests +-- =================================================================== + +-- | Send a gRPC request to a spire Service (no network). +-- +-- Constructs a proper gRPC request with: +-- +-- * Method: POST +-- * Content-Type: application\/grpc+proto +-- * Path: \/service\/method +-- * Body: payload wrapped in gRPC length-prefixed framing +-- +-- Returns the raw HTTP Response (with Body). +grpcCall + :: Service IO (Request Body) (Response Body) + -> Text -- ^ Service name (e.g., "myapp.Greeter") + -> Text -- ^ Method name (e.g., "SayHello") + -> ByteString -- ^ Request payload bytes (will be gRPC-framed) + -> IO (Response Body) +grpcCall svc service method payload = do + exts <- emptyExtensions + let path = "/" <> TE.encodeUtf8 service <> "/" <> TE.encodeUtf8 method + framedBody = encodeMessage payload + segments = filter (/= "") $ T.splitOn "/" (TE.decodeUtf8 path) + req = Request + { requestMethod = "POST" + , requestPathRaw = path + , requestPath = segments + , requestQuery = [] + , requestHeaders = [("content-type", "application/grpc+proto")] + , requestBody = fromBytes framedBody + , requestExtensions = exts + } + runService svc req + + +-- =================================================================== +-- Response assertions +-- =================================================================== + +-- | Assert that the response has the expected gRPC status code. +-- +-- Checks the @grpc-status@ header/trailer value. gRPC status 0 means OK. +shouldHaveGrpcStatus :: Response Body -> Int -> IO () +shouldHaveGrpcStatus resp expected = + case lookup "grpc-status" (responseHeaders resp) of + Just actual -> + let code = read (BS8.unpack actual) :: Int + in if code == expected + then pure () + else error $ + "Expected grpc-status " ++ show expected + ++ " but got " ++ show code + Nothing -> error + "grpc-status header/trailer not found in response" + + +-- | Assert that the gRPC response body (after removing framing) equals +-- the expected bytes. +shouldHaveGrpcBody :: Response Body -> ByteString -> IO () +shouldHaveGrpcBody resp expected = do + body <- bodyToStrict (responseBody resp) + let payload = stripGrpcFraming body + if payload == expected + then pure () + else error $ + "Expected gRPC body " ++ show expected + ++ " but got " ++ show payload + + +-- | Extract the payload from a gRPC-framed response body. +-- +-- Strips the 5-byte gRPC length-prefixed framing header and returns +-- the raw message bytes. Returns empty bytes if the body is empty +-- or cannot be decoded. +grpcResponseBody :: Response Body -> IO ByteString +grpcResponseBody resp = do + body <- bodyToStrict (responseBody resp) + pure (stripGrpcFraming body) + + +-- =================================================================== +-- Internal helpers +-- =================================================================== + +-- | Strip gRPC length-prefixed framing from a ByteString. +stripGrpcFraming :: ByteString -> ByteString +stripGrpcFraming bs + | BS.null bs = BS.empty + | otherwise = case decodeMessage bs of + Just (msg, _) -> gmPayload msg + Nothing -> bs -- fallback: return raw bytes diff --git a/src/Acolyte/Test/Property.hs b/src/Acolyte/Test/Property.hs new file mode 100644 --- /dev/null +++ b/src/Acolyte/Test/Property.hs @@ -0,0 +1,113 @@ +-- | Property-based testing for acolyte APIs. +-- +-- Generate random valid requests for any endpoint in an API type. +-- +-- @ +-- prop_noCrash :: Property +-- prop_noCrash = forAll (arbitraryApiRequest @MyAPI) $ \req -> ioProperty $ do +-- resp <- runService myServer req +-- pure (responseStatus' resp `elem` [200, 201, 400, 401, 404]) +-- @ +module Acolyte.Test.Property + ( -- * Random request generation + ArbitraryEndpoint (..) + , ArbitraryAPI (..) + -- * Helpers + , randomCapture + , generatePath + , genJsonObject + ) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS8 +import Data.Kind (Type) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import System.IO.Unsafe (unsafePerformIO) + +import Test.QuickCheck + +import Http.Core +import Acolyte.Server.Handler (HasEndpointInfo (..)) + + +-- | Generate a random valid request for a specific endpoint. +class ArbitraryEndpoint endpoint where + arbitraryEndpointRequest :: Gen (Request ByteString) + +instance HasEndpointInfo e => ArbitraryEndpoint e where + arbitraryEndpointRequest = do + let method = endpointMethod @e + pattern = endpointPattern @e + pathSegments <- generatePath pattern + let pathRaw = "/" <> BS8.intercalate "/" (map TE.encodeUtf8 pathSegments) + body <- oneof [pure "", genJsonObject] + let exts = unsafePerformIO emptyExtensions + pure Request + { requestMethod = method + , requestPathRaw = pathRaw + , requestPath = pathSegments + , requestQuery = [] + , requestHeaders = [("Content-Type", "application/json")] + , requestBody = body + , requestExtensions = exts + } + + +-- | Generate a random request for any endpoint in an API. +class ArbitraryAPI (api :: [Type]) where + arbitraryApiRequest :: Gen (Request ByteString) + +instance ArbitraryEndpoint e => ArbitraryAPI '[e] where + arbitraryApiRequest = arbitraryEndpointRequest @e + +instance (ArbitraryEndpoint e, ArbitraryAPI (e2 ': rest)) + => ArbitraryAPI (e ': e2 ': rest) where + arbitraryApiRequest = oneof + [ arbitraryEndpointRequest @e + , arbitraryApiRequest @(e2 ': rest) + ] + + +-- =================================================================== +-- Helpers +-- =================================================================== + +-- | Generate a random capture value (int or short string). +randomCapture :: Gen Text +randomCapture = oneof + [ T.pack . show <$> chooseInt (1, 9999) + , T.pack <$> listOf1 (elements ['a'..'z']) + ] + + +-- | Generate path segments from a pattern, replacing captures with random values. +generatePath :: Text -> Gen [Text] +generatePath pattern = + let parts = filter (not . T.null) (T.splitOn "/" pattern) + in mapM genSegment parts + where + genSegment seg + | "{" `T.isPrefixOf` seg = randomCapture + | otherwise = pure seg + + +-- | Generate a random small JSON object. +genJsonObject :: Gen ByteString +genJsonObject = do + nFields <- chooseInt (0, 3) + fields <- vectorOf nFields genField + pure $ BS8.pack $ "{" ++ intercalateS "," fields ++ "}" + where + genField = do + key <- listOf1 (elements ['a'..'z']) + val <- oneof + [ show <$> chooseInt (0 :: Int, 100) + , (\s -> "\"" ++ s ++ "\"") <$> listOf1 (elements ['a'..'z']) + ] + pure $ "\"" ++ key ++ "\":" ++ val + + intercalateS _ [] = "" + intercalateS _ [x] = x + intercalateS sep (x:xs) = x ++ sep ++ intercalateS sep xs diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,396 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Data.ByteString (ByteString) +import Data.Text (Text) +import qualified Data.Text as T +import Network.HTTP.Types (status400, status500) + +import Spire +import Spire.Service (Service (..)) +import Http.Core +import Http.Core.Body (Body, fromBytes, bodyToStrict) +import Acolyte.Core +import Acolyte.Server +import Acolyte.Test +import Acolyte.Test.Grpc +import Spire.Grpc (grpcServer, grpcServiceMap, unaryHandler, multiplex) +import Spire.Server (adaptToBody) +import Acolyte.OpenApi + ( generateSpec, OpenApiSpec(..), specOps ) +import Acolyte.Grpc + ( mkGrpcServiceMap, GrpcHandlerFn + , generateProto, ProtoMessageName(..) + ) + + +-- =================================================================== +-- Test API and server (original tests) +-- =================================================================== + +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) + ] + +testServer :: Service IO (Request ByteString) (Response ByteString) +testServer = 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 caps") + ) + ) + + +-- =================================================================== +-- Integration API (exercises all layers) +-- =================================================================== + +-- ProtoMessageName instances needed for .proto generation +instance ProtoMessageName Text where + protoMessageName = "StringValue" + +instance ProtoMessageName [Text] where + protoMessageName = "StringList" + + +type IntegrationAPI = + '[ Describe "Health check" (Get (At "health") Text) + , WithParams '[QP "page" Int] + (Get (At "users") (Json [Text])) + , PostCreated (At "users") (Json Text) (Json Text) + , Get (Param "users" Int) (Json Text) + ] + + +-- Handlers for REST server (mkApi style) +healthHandler :: IO Text +healthHandler = pure "ok" + +listUsersHandler :: IO (Json [Text]) +listUsersHandler = pure (Json (["alice", "bob"] :: [Text])) + +createUserHandler :: JsonBody Text -> IO (Json Text) +createUserHandler (JsonBody name) = pure (Json ("created:" <> name)) + +getUserHandler :: PathCapture Int -> IO (Json Text) +getUserHandler (PathCapture uid) = pure (Json (T.pack ("user-" ++ show uid))) + + +-- gRPC handlers +grpcHealthHandler :: GrpcHandlerFn +grpcHealthHandler _req = pure (Right "ok") + +grpcListUsersHandler :: GrpcHandlerFn +grpcListUsersHandler _req = pure (Right "[\"alice\",\"bob\"]") + +grpcCreateUserHandler :: GrpcHandlerFn +grpcCreateUserHandler req = pure (Right ("created:" <> req)) + +grpcGetUserHandler :: GrpcHandlerFn +grpcGetUserHandler _req = pure (Right "user-42") + + +-- =================================================================== +-- Effect-tracked API (compile-time middleware tracking) +-- =================================================================== + +type EffectAPI = + '[ Requires Auth (Get (At "profile") (Json Text)) + , Get (At "public") Text + ] + +authMiddleware :: Middleware IO (Request ByteString) (Response ByteString) +authMiddleware = middleware $ \inner -> Service $ \req -> runService inner req + + +-- =================================================================== +-- Tests +-- =================================================================== + +main :: IO () +main = do + putStrLn "acolyte-test tests:" + putStrLn "" + + -- ================================================================= + -- Original tests + -- ================================================================= + + putStrLn "get helper:" + resp1 <- get testServer "/health" + resp1 `shouldHaveStatus` 200 + resp1 `shouldHaveBody` "ok" + putStrLn " OK: GET /health -> 200, body ok" + + putStrLn "" + putStrLn "JSON response:" + resp2 <- get testServer "/users" + resp2 `shouldHaveStatus` 200 + resp2 `shouldHaveJsonBody` (["alice", "bob"] :: [Text]) + putStrLn " OK: GET /users -> 200, JSON body" + + putStrLn "" + putStrLn "Path captures:" + resp3 <- get testServer "/users/42" + resp3 `shouldHaveStatus` 200 + resp3 `shouldHaveJsonBody` ("user-42" :: Text) + putStrLn " OK: GET /users/42 -> 200, user-42" + + putStrLn "" + putStrLn "404:" + resp4 <- get testServer "/nope" + resp4 `shouldHaveStatus` 404 + putStrLn " OK: GET /nope -> 404" + + putStrLn "" + putStrLn "405:" + resp5 <- request testServer "POST" "/health" [] "" + resp5 `shouldHaveStatus` 405 + putStrLn " OK: POST /health -> 405" + + putStrLn "" + putStrLn "Middleware:" + let svc = testServer |> middleware (\inner -> Service $ \req -> do + resp <- runService inner req + pure resp { responseHeaders = ("X-Test", "yes") : responseHeaders resp }) + resp6 <- get svc "/health" + resp6 `shouldHaveStatus` 200 + resp6 `shouldHaveHeader` "X-Test" $ "yes" + putStrLn " OK: middleware header present" + + -- ================================================================= + -- gRPC testing utilities (original) + -- ================================================================= + + putStrLn "" + putStrLn "gRPC test utilities:" + + let echoHandler = unaryHandler $ \reqBytes -> pure (Right reqBytes) + grpcSvc = grpcServer $ grpcServiceMap + [ ("test.Echo", "Echo", echoHandler) + ] + + putStrLn "" + putStrLn "grpcCall + shouldHaveGrpcStatus:" + grpcResp1 <- grpcCall grpcSvc "test.Echo" "Echo" "hello" + grpcResp1 `shouldHaveGrpcStatus` 0 + putStrLn " OK: grpc-status 0 (OK)" + + putStrLn "" + putStrLn "grpcResponseBody:" + body1 <- grpcResponseBody grpcResp1 + if body1 == "hello" + then putStrLn " OK: response body matches" + else error $ "Expected body \"hello\" but got " ++ show body1 + + putStrLn "" + putStrLn "shouldHaveGrpcBody:" + grpcResp2 <- grpcCall grpcSvc "test.Echo" "Echo" "world" + grpcResp2 `shouldHaveGrpcBody` "world" + putStrLn " OK: gRPC body assertion passed" + + putStrLn "" + putStrLn "gRPC unimplemented method:" + grpcResp3 <- grpcCall grpcSvc "test.Echo" "NoSuchMethod" "" + grpcResp3 `shouldHaveGrpcStatus` 12 -- UNIMPLEMENTED + putStrLn " OK: grpc-status 12 (UNIMPLEMENTED)" + + -- ================================================================= + -- INTEGRATION TESTS: Cross-package end-to-end + -- ================================================================= + + putStrLn "" + putStrLn "============================================" + putStrLn "Integration tests (full stack):" + putStrLn "============================================" + + -- ----------------------------------------------------------------- + -- (a) REST server via mkApi + -- ----------------------------------------------------------------- + putStrLn "" + putStrLn "a) REST server via mkApi @IntegrationAPI:" + + let restSvc = mkApi @IntegrationAPI + (healthHandler, listUsersHandler, createUserHandler, getUserHandler) + + ra1 <- get restSvc "/health" + ra1 `shouldHaveStatus` 200 + ra1 `shouldHaveBody` "ok" + putStrLn " OK: GET /health -> 200" + + ra2 <- get restSvc "/users" + ra2 `shouldHaveStatus` 200 + ra2 `shouldHaveJsonBody` (["alice", "bob"] :: [Text]) + putStrLn " OK: GET /users -> 200, JSON list" + + ra3 <- post restSvc "/users" ("newuser" :: Text) + ra3 `shouldHaveStatus` 200 + ra3 `shouldHaveJsonBody` ("created:newuser" :: Text) + putStrLn " OK: POST /users -> 200, created" + + ra4 <- get restSvc "/users/42" + ra4 `shouldHaveStatus` 200 + ra4 `shouldHaveJsonBody` ("user-42" :: Text) + putStrLn " OK: GET /users/42 -> 200, user-42" + + ra5 <- get restSvc "/notexist" + ra5 `shouldHaveStatus` 404 + putStrLn " OK: GET /notexist -> 404" + + -- ----------------------------------------------------------------- + -- (b) gRPC server via mkGrpcServiceMap + -- ----------------------------------------------------------------- + putStrLn "" + putStrLn "b) gRPC server via mkGrpcServiceMap @IntegrationAPI:" + + let grpcServices = mkGrpcServiceMap @IntegrationAPI "test" "IntegrationSvc" + (grpcHealthHandler, grpcListUsersHandler, grpcCreateUserHandler, grpcGetUserHandler) + grpcSvc2 = grpcServer grpcServices + + gb1 <- grpcCall grpcSvc2 "test.IntegrationSvc" "Health" "ping" + gb1 `shouldHaveGrpcStatus` 0 + gb1body <- grpcResponseBody gb1 + if gb1body == "ok" + then putStrLn " OK: gRPC Health -> status 0, body ok" + else error $ "Expected gRPC body \"ok\" but got " ++ show gb1body + + -- Note: "Users" method name is shared by 3 endpoints (list, create, getById). + -- gRPC dispatches by method name, so the last registered handler wins. + -- This is expected — in real usage, distinct gRPC method names are needed. + gb2 <- grpcCall grpcSvc2 "test.IntegrationSvc" "Users" "" + gb2 `shouldHaveGrpcStatus` 0 + putStrLn " OK: gRPC Users -> status 0 (dispatched)" + + gb4 <- grpcCall grpcSvc2 "test.IntegrationSvc" "NoSuch" "" + gb4 `shouldHaveGrpcStatus` 12 + putStrLn " OK: gRPC NoSuch -> status 12 (UNIMPLEMENTED)" + + -- ----------------------------------------------------------------- + -- (c) Multiplex: REST + gRPC on same service + -- ----------------------------------------------------------------- + putStrLn "" + putStrLn "c) Multiplex REST + gRPC:" + + let combined = multiplex (adaptToBody restSvc) grpcSvc2 + + -- REST request through combined (no content-type or non-grpc) + do + exts <- emptyExtensions + let segments = ["health"] + req = Request + { requestMethod = "GET" + , requestPathRaw = "/health" + , requestPath = segments + , requestQuery = [] + , requestHeaders = [("content-type", "application/json")] + , requestBody = fromBytes "" + , requestExtensions = exts + } + mresp <- runService combined req + mbody <- bodyToStrict (responseBody mresp) + if mbody == "ok" + then putStrLn " OK: REST request through multiplex -> ok" + else error $ "Expected body \"ok\" but got " ++ show mbody + + -- gRPC request through combined + do + mgResp <- grpcCall combined "test.IntegrationSvc" "Health" "ping" + mgResp `shouldHaveGrpcStatus` 0 + mgBody <- grpcResponseBody mgResp + if mgBody == "ok" + then putStrLn " OK: gRPC request through multiplex -> ok" + else error $ "Expected gRPC body \"ok\" but got " ++ show mgBody + + -- ----------------------------------------------------------------- + -- (d) OpenAPI spec generation + -- ----------------------------------------------------------------- + putStrLn "" + putStrLn "d) OpenAPI spec generation:" + + let spec = generateSpec @IntegrationAPI "Integration Test" "1.0.0" + ops = specOps spec + + if length ops == 4 + then putStrLn " OK: generateSpec produced 4 operations" + else error $ "Expected 4 operations but got " ++ show (length ops) + + if specTitle spec == "Integration Test" + then putStrLn " OK: spec title correct" + else error $ "Expected title 'Integration Test' but got " ++ show (specTitle spec) + + if specVersion spec == "1.0.0" + then putStrLn " OK: spec version correct" + else error $ "Expected version '1.0.0' but got " ++ show (specVersion spec) + + -- ----------------------------------------------------------------- + -- (e) .proto generation + -- ----------------------------------------------------------------- + putStrLn "" + putStrLn "e) .proto generation:" + + let proto = generateProto @IntegrationAPI "test" "IntegrationSvc" + rpcLines = filter (T.isPrefixOf " rpc ") (T.lines proto) + + if length rpcLines == 4 + then putStrLn " OK: generateProto produced 4 rpc lines" + else error $ "Expected 4 rpc lines but got " ++ show (length rpcLines) + ++ "\nProto:\n" ++ T.unpack proto + + if T.isInfixOf "syntax = \"proto3\";" proto + then putStrLn " OK: proto3 syntax declaration present" + else error "Expected proto3 syntax declaration" + + if T.isInfixOf "service IntegrationSvc" proto + then putStrLn " OK: service name correct" + else error "Expected service IntegrationSvc in proto" + + if T.isInfixOf "package test;" proto + then putStrLn " OK: package name correct" + else error "Expected package test in proto" + + -- ----------------------------------------------------------------- + -- (g) Effect tracking + -- ----------------------------------------------------------------- + putStrLn "" + putStrLn "g) Effect tracking:" + + let profileHandler :: IO (Json Text) + profileHandler = pure (Json ("profile-data" :: Text)) + + publicHandler :: IO Text + publicHandler = pure ("public-data" :: Text) + + -- Build effectful server, provide Auth, then run + effectSvc = run + $ provide @Auth authMiddleware + $ effectfulApi @EffectAPI (profileHandler, publicHandler) + + eg1 <- get effectSvc "/profile" + eg1 `shouldHaveStatus` 200 + eg1 `shouldHaveJsonBody` ("profile-data" :: Text) + putStrLn " OK: effectful GET /profile -> 200 (Auth provided)" + + eg2 <- get effectSvc "/public" + eg2 `shouldHaveStatus` 200 + eg2 `shouldHaveBody` "public-data" + putStrLn " OK: effectful GET /public -> 200" + + putStrLn "" + putStrLn "============================================" + putStrLn "All acolyte-test tests passed."