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-openapi + +## 0.1.0.0 -- 2026-04-27 + +* Initial release. Generates OpenAPI 3.1 (and 2.0/Swagger) documents + from acolyte-core API types, so the spec stays in lockstep with + the running server and client. 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-openapi.cabal b/acolyte-openapi.cabal new file mode 100644 --- /dev/null +++ b/acolyte-openapi.cabal @@ -0,0 +1,87 @@ +cabal-version: 3.0 +name: acolyte-openapi +version: 0.1.0.0 +synopsis: OpenAPI 3.1 spec generation from acolyte API types +category: Web +description: + Generates OpenAPI specifications from the same API type that drives + the server and client. One type, three interpretations. + +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.OpenApi + Acolyte.OpenApi.Spec + Acolyte.OpenApi.Schema + Acolyte.OpenApi.V2 + Acolyte.OpenApi.V3 + + build-depends: + base >= 4.20 && < 5 + , acolyte-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 + + hs-source-dirs: src + default-language: GHC2024 + default-extensions: + DataKinds + GADTs + TypeFamilies + TypeOperators + OverloadedStrings + AllowAmbiguousTypes + UndecidableInstances + ConstraintKinds + ScopedTypeVariables + MultiParamTypeClasses + FlexibleInstances + FlexibleContexts + StandaloneKindSignatures + DefaultSignatures + DeriveGeneric + 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 + DeriveGeneric + StrictData + + ghc-options: -Wall -rtsopts "-with-rtsopts=-K1K" + + build-depends: + base >= 4.20 && < 5 + , acolyte-openapi >= 0.1 && < 0.2 + , acolyte-core >= 0.1 && < 0.2 + , aeson >= 2.1 && < 2.3 + , bytestring >= 0.11 && < 0.13 + , text >= 2.0 && < 2.2 + +source-repository head + type: git + location: https://github.com/joshburgess/acolyte.git diff --git a/src/Acolyte/OpenApi.hs b/src/Acolyte/OpenApi.hs new file mode 100644 --- /dev/null +++ b/src/Acolyte/OpenApi.hs @@ -0,0 +1,42 @@ +-- | @acolyte-openapi@ — OpenAPI spec generation. +-- +-- Supports both Swagger 2.0 and OpenAPI 3.1 from the same API type. +-- +-- @ +-- -- OpenAPI 3.1 (default) +-- spec3 = generateSpec @MyAPI "My API" "1.0.0" +-- +-- -- Swagger 2.0 +-- spec2 = generateSwagger @MyAPI "My API" "1.0.0" "localhost:3000" "/" +-- @ +module Acolyte.OpenApi + ( -- * OpenAPI 3.1 (default) + OpenApiSpec (..) + , generateSpec + + -- * OpenAPI 3.1 (explicit) + , OpenApi3Spec (..) + , generateOpenApi3 + + -- * Swagger / OpenAPI 2.0 + , SwaggerSpec (..) + , generateSwagger + + -- * Shared: per-endpoint + , EndpointToOperation (..) + , Operation (..) + , Parameter (..) + + -- * Shared: API walking + , ApiToOperations (..) + + -- * Shared: schema + , Schema (..) + , schemaToJson + , ToSchema (..) + ) where + +import Acolyte.OpenApi.Spec +import Acolyte.OpenApi.Schema +import Acolyte.OpenApi.V2 +import Acolyte.OpenApi.V3 diff --git a/src/Acolyte/OpenApi/Schema.hs b/src/Acolyte/OpenApi/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Acolyte/OpenApi/Schema.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +-- | JSON Schema derivation for OpenAPI. +-- +-- 'ToSchema' produces a JSON Schema object for a type, used in +-- request body and response schemas in the OpenAPI spec. +-- +-- For record types, use @deriving Generic@ and the default implementation: +-- +-- @ +-- data User = User { userName :: Text, userAge :: Int } +-- deriving (Generic) +-- +-- instance ToSchema User +-- -- Produces: { "type": "object", "properties": { "userName": { "type": "string" }, "userAge": { "type": "integer" } } } +-- @ +module Acolyte.OpenApi.Schema + ( -- * Schema type + Schema (..) + , schemaToJson + -- * Schema class + , ToSchema (..) + -- * Generic derivation helper + , GToSchema (..) + , GToSchemaCon (..) + , genericToSchema + ) where + +import Data.Aeson (Value (..), object, (.=)) +import qualified Data.Aeson.Key as Key +import Data.Kind (Type) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Proxy (Proxy (..)) +import GHC.Generics +import GHC.TypeLits (KnownSymbol, symbolVal) + +import Acolyte.Core.Endpoint (Json) + + +-- | A simplified JSON Schema representation. +data Schema = Schema + { schemaType :: !Text + , schemaProperties :: ![(Text, Schema)] + , schemaItems :: !(Maybe Schema) + , schemaRef :: !(Maybe Text) + , schemaOneOf :: !(Maybe [Schema]) + , schemaEnum :: !(Maybe [Text]) + , schemaNullable :: !Bool + } deriving (Show, Eq) + + +-- | Convert a schema to an aeson Value. +schemaToJson :: Schema -> Value +schemaToJson s + | Just ref <- schemaRef s = object $ ["$ref" .= ref] ++ nullableField + | Just variants <- schemaOneOf s = object $ ["oneOf" .= map schemaToJson variants] ++ nullableField + | Just values <- schemaEnum s = object $ ["type" .= schemaType s, "enum" .= values] ++ nullableField + | schemaType s == "array" = object $ + ["type" .= schemaType s] + ++ maybe [] (\items -> ["items" .= schemaToJson items]) (schemaItems s) + ++ nullableField + | schemaType s == "object" && not (null (schemaProperties s)) = object $ + [ "type" .= schemaType s + , "properties" .= object + [ Key.fromText k .= schemaToJson v | (k, v) <- schemaProperties s ] + ] ++ nullableField + | otherwise = object $ ["type" .= schemaType s] ++ nullableField + where + nullableField = if schemaNullable s then ["nullable" .= True] else [] + + +-- | Derive a JSON Schema for a type. +-- +-- For record types with a 'Generic' instance, the default implementation +-- uses 'genericToSchema' to produce an object schema with properties +-- derived from field names: +-- +-- @ +-- data User = User { userName :: Text, userAge :: Int } +-- deriving (Generic) +-- +-- instance ToSchema User +-- @ +class ToSchema a where + toSchema :: Schema + default toSchema :: (Generic a, GToSchema (Rep a)) => Schema + toSchema = genericToSchema @a + + +-- | Derive a 'ToSchema' instance from a type's 'Generic' representation. +-- +-- Produces an object schema with properties extracted from record +-- selectors. Field names become property keys, field types become +-- property schemas (via their own 'ToSchema' instances). +genericToSchema :: forall a. (Generic a, GToSchema (Rep a)) => Schema +genericToSchema = gToSchemaFull @(Rep a) + + +-- | Walk a Generic representation to extract (fieldName, schema) pairs. +class GToSchema (f :: Type -> Type) where + gToSchema :: [(Text, Schema)] + gToSchemaFull :: Schema + gToSchemaFull = Schema "object" (gToSchema @f) Nothing Nothing Nothing Nothing False + +-- Metadata wrapper (datatype info) — delegate to inner +instance GToSchema f => GToSchema (D1 meta f) where + gToSchema = gToSchema @f + gToSchemaFull = gToSchemaFull @f + +-- Constructor wrapper — delegate to inner +instance GToSchema f => GToSchema (C1 meta f) where + gToSchema = gToSchema @f + gToSchemaFull = gToSchemaFull @f + +-- Product: combine left and right fields +instance (GToSchema f, GToSchema g) => GToSchema (f :*: g) where + gToSchema = gToSchema @f ++ gToSchema @g + +-- Record selector with a named field +instance (KnownSymbol name, ToSchema t) + => GToSchema (S1 ('MetaSel ('Just name) su ss ds) (Rec0 t)) where + gToSchema = [(T.pack (symbolVal (Proxy @name)), toSchema @t)] + +-- No fields (unit constructor) +instance GToSchema U1 where + gToSchema = [] + +-- Sum types — produce oneOf schema with tagged variants +instance (GToSchemaCon (f :+: g)) => GToSchema (f :+: g) where + gToSchema = [] + gToSchemaFull = Schema "object" [] Nothing Nothing (Just (gToSchemaCon @(f :+: g))) Nothing False + + +-- =================================================================== +-- Sum type constructor schemas +-- =================================================================== + +-- | Per-constructor schema (for oneOf in sum types). +class GToSchemaCon (f :: Type -> Type) where + gToSchemaCon :: [Schema] + +instance (GToSchemaCon f, GToSchemaCon g) => GToSchemaCon (f :+: g) where + gToSchemaCon = gToSchemaCon @f ++ gToSchemaCon @g + +instance (KnownSymbol name, GToSchema f) + => GToSchemaCon (C1 ('MetaCons name fix rec) f) where + gToSchemaCon = + let props = gToSchema @f + tagProp = ("tag", Schema "string" [] Nothing Nothing Nothing + (Just [T.pack (symbolVal (Proxy @name))]) False) + in [Schema "object" (tagProp : props) Nothing Nothing Nothing Nothing False] + + +-- =================================================================== +-- Primitive instances +-- =================================================================== + +instance ToSchema Int where + toSchema = Schema "integer" [] Nothing Nothing Nothing Nothing False + +instance ToSchema Integer where + toSchema = Schema "integer" [] Nothing Nothing Nothing Nothing False + +instance ToSchema Double where + toSchema = Schema "number" [] Nothing Nothing Nothing Nothing False + +instance ToSchema Float where + toSchema = Schema "number" [] Nothing Nothing Nothing Nothing False + +instance ToSchema Bool where + toSchema = Schema "boolean" [] Nothing Nothing Nothing Nothing False + +instance ToSchema Text where + toSchema = Schema "string" [] Nothing Nothing Nothing Nothing False + +instance ToSchema String where + toSchema = Schema "string" [] Nothing Nothing Nothing Nothing False + +instance ToSchema () where + toSchema = Schema "object" [] Nothing Nothing Nothing Nothing False + +instance ToSchema a => ToSchema [a] where + toSchema = Schema "array" [] (Just (toSchema @a)) Nothing Nothing Nothing False + +instance ToSchema a => ToSchema (Maybe a) where + toSchema = (toSchema @a) { schemaNullable = True } + +instance (ToSchema a, ToSchema b) => ToSchema (Either a b) where + toSchema = Schema "object" [] Nothing Nothing (Just [toSchema @a, toSchema @b]) Nothing False + +instance ToSchema a => ToSchema (Json a) where + toSchema = toSchema @a diff --git a/src/Acolyte/OpenApi/Spec.hs b/src/Acolyte/OpenApi/Spec.hs new file mode 100644 --- /dev/null +++ b/src/Acolyte/OpenApi/Spec.hs @@ -0,0 +1,422 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +-- | OpenAPI 3.1 spec generation from API types. +module Acolyte.OpenApi.Spec + ( -- * Spec generation + OpenApiSpec (..) + , generateSpec + -- * Per-endpoint generation + , EndpointToOperation (..) + , Operation (..) + , Parameter (..) + -- * API walking + , ApiToOperations (..) + -- * Capture name reflection + , KnownCaptureName (..) + -- * Helpers + , opMethodLower + ) where + +import Data.Aeson (Value (..), object, (.=), ToJSON (..)) +import qualified Data.Aeson.Key as Key +import Data.Kind (Type) +import Data.Proxy (Proxy (..)) +import Data.Text (Text) +import qualified Data.Text as T +import GHC.TypeLits (KnownSymbol, KnownNat, symbolVal, natVal) +import Network.HTTP.Types (Method) + +import Acolyte.Core.Method (KnownMethod, methodVal) +import qualified Acolyte.Core.Method as Core +import Acolyte.Core.Path (PathSegment (..)) +import Acolyte.Core.Endpoint (Endpoint, NoBody) +import Acolyte.Core.Effect (Requires) +import Data.Typeable (Typeable, typeRep) +import Acolyte.Core.Wrapper + ( Describe, Description, Named, Versioned, ApiVersion (..) + , WithParams, QP, WithHeaders, HH + , ServerStream, ClientStream, BidiStream, RespondsWith + ) +import Acolyte.OpenApi.Schema (Schema (..), ToSchema (..), schemaToJson) + + +-- | A complete OpenAPI 3.1 spec. +data OpenApiSpec = OpenApiSpec + { specTitle :: !Text + , specVersion :: !Text + , specOps :: ![Operation] + } deriving (Show) + +instance ToJSON OpenApiSpec where + toJSON spec = object + [ "openapi" .= ("3.1.0" :: Text) + , "info" .= object + [ "title" .= specTitle spec + , "version" .= specVersion spec + ] + , "paths" .= groupByPath (specOps spec) + ] + + +groupByPath :: [Operation] -> Value +groupByPath ops = object + [ Key.fromText (opPath op) .= object [Key.fromText (opMethodLower op) .= opToJson op] + | op <- ops + ] + + +opToJson :: Operation -> Value +opToJson op = object $ concat + [ case opOperationId op of + Nothing -> [] + Just oid -> ["operationId" .= oid] + , case opSummary op of + Nothing -> [] + Just s -> ["summary" .= s] + , case opDescription op of + Nothing -> [] + Just d -> ["description" .= d] + , [ "responses" .= object + [ Key.fromText (T.pack (show (opStatusCode op))) .= responseObj ] + ] + , if null (opParameters op) then [] + else ["parameters" .= map paramToJson (opParameters op)] + , case opRequestBody op of + Nothing -> [] + Just schema -> + [ "requestBody" .= object + [ "required" .= True + , "content" .= object + [ "application/json" .= object + [ "schema" .= schemaToJson schema ] + ] + ] + ] + ] + where + responseObj = case opResponseSchema op of + Nothing -> object ["description" .= ("Success" :: Text)] + Just schema -> object + [ "description" .= ("Success" :: Text) + , "content" .= object + [ "application/json" .= object + [ "schema" .= schemaToJson schema ] + ] + ] + + +-- | A single API operation. +data Operation = Operation + { opMethod :: !Text + , opPath :: !Text + , opOperationId :: !(Maybe Text) + , opSummary :: !(Maybe Text) + , opDescription :: !(Maybe Text) + , opParameters :: ![Parameter] + , opStatusCode :: !Int + , opResponseSchema :: !(Maybe Schema) + , opRequestBody :: !(Maybe Schema) + } deriving (Show) + +-- | Return the operation's HTTP method in lowercase (e.g. @"get"@, @"post"@). +opMethodLower :: Operation -> Text +opMethodLower = T.toLower . opMethod + + +-- | An API parameter. +data Parameter = Parameter + { paramName :: !Text + , paramIn :: !Text + , paramRequired :: !Bool + , paramSchema :: !Schema + } deriving (Show) + +paramToJson :: Parameter -> Value +paramToJson p = object + [ "name" .= paramName p + , "in" .= paramIn p + , "required" .= paramRequired p + , "schema" .= schemaToJson (paramSchema p) + ] + + +-- =================================================================== +-- Per-endpoint operation generation +-- =================================================================== + +-- | Convert an endpoint type into an OpenAPI 'Operation'. +class EndpointToOperation endpoint where + toOperation :: Operation + +-- GET (no request body) +instance (KnownMethod m, ReflectPathOA path, m ~ 'Core.GET, ToSchema resp) + => EndpointToOperation (Endpoint m path NoBody resp) where + toOperation = Operation + { opMethod = T.pack (show (methodVal @m)) + , opPath = reflectOAPath @path + , opOperationId = Nothing + , opSummary = Nothing + , opDescription = Nothing + , opParameters = reflectOAParams @path + , opStatusCode = 200 + , opResponseSchema = Just (toSchema @resp) + , opRequestBody = Nothing + } + +-- DELETE (no request body) +instance (ReflectPathOA path, ToSchema resp) + => EndpointToOperation (Endpoint 'Core.DELETE path NoBody resp) where + toOperation = Operation + { opMethod = "DELETE" + , opPath = reflectOAPath @path + , opOperationId = Nothing + , opSummary = Nothing + , opDescription = Nothing + , opParameters = reflectOAParams @path + , opStatusCode = 200 + , opResponseSchema = Just (toSchema @resp) + , opRequestBody = Nothing + } + +-- POST (with request body) +instance (ReflectPathOA path, ToSchema req, ToSchema resp) + => EndpointToOperation (Endpoint 'Core.POST path req resp) where + toOperation = Operation + { opMethod = "POST" + , opPath = reflectOAPath @path + , opOperationId = Nothing + , opSummary = Nothing + , opDescription = Nothing + , opParameters = reflectOAParams @path + , opStatusCode = 201 + , opResponseSchema = Just (toSchema @resp) + , opRequestBody = Just (toSchema @req) + } + +-- PUT (with request body) +instance (ReflectPathOA path, ToSchema req, ToSchema resp) + => EndpointToOperation (Endpoint 'Core.PUT path req resp) where + toOperation = Operation + { opMethod = "PUT" + , opPath = reflectOAPath @path + , opOperationId = Nothing + , opSummary = Nothing + , opDescription = Nothing + , opParameters = reflectOAParams @path + , opStatusCode = 200 + , opResponseSchema = Just (toSchema @resp) + , opRequestBody = Just (toSchema @req) + } + +-- PATCH (with request body) +instance (ReflectPathOA path, ToSchema req, ToSchema resp) + => EndpointToOperation (Endpoint 'Core.PATCH path req resp) where + toOperation = Operation + { opMethod = "PATCH" + , opPath = reflectOAPath @path + , opOperationId = Nothing + , opSummary = Nothing + , opDescription = Nothing + , opParameters = reflectOAParams @path + , opStatusCode = 200 + , opResponseSchema = Just (toSchema @resp) + , opRequestBody = Just (toSchema @req) + } + +-- Requires delegates +instance EndpointToOperation inner + => EndpointToOperation (Requires e inner) where + toOperation = toOperation @inner + +-- Describe extracts the endpoint summary from the type-level description +instance (KnownSymbol desc, EndpointToOperation inner) + => EndpointToOperation (Describe desc inner) where + toOperation = + let op = toOperation @inner + in op { opSummary = Just (T.pack (symbolVal (Proxy @desc))) } + +-- Description sets the operation description (longer text, distinct from summary) +instance (KnownSymbol desc, EndpointToOperation inner) + => EndpointToOperation (Description desc inner) where + toOperation = + let op = toOperation @inner + in op { opDescription = Just (T.pack (symbolVal (Proxy @desc))) } + +-- WithParams reflects query parameters into the operation +instance (ReflectParams ps, EndpointToOperation inner) + => EndpointToOperation (WithParams ps inner) where + toOperation = + let op = toOperation @inner + in op { opParameters = opParameters op ++ reflectParams @ps } + +-- WithHeaders reflects header parameters into the operation +instance (ReflectHeaders hs, EndpointToOperation inner) + => EndpointToOperation (WithHeaders hs inner) where + toOperation = + let op = toOperation @inner + in op { opParameters = opParameters op ++ reflectHeaders @hs } + +-- ServerStream delegates (streaming marker) +instance EndpointToOperation inner + => EndpointToOperation (ServerStream inner) where + toOperation = toOperation @inner + +-- ClientStream delegates (streaming marker) +instance EndpointToOperation inner + => EndpointToOperation (ClientStream inner) where + toOperation = toOperation @inner + +-- BidiStream delegates (streaming marker) +instance EndpointToOperation inner + => EndpointToOperation (BidiStream inner) where + toOperation = toOperation @inner + +-- RespondsWith extracts the status code from the type-level Nat +instance (KnownNat s, EndpointToOperation inner) + => EndpointToOperation (RespondsWith s inner) where + toOperation = + let op = toOperation @inner + in op { opStatusCode = fromIntegral (natVal (Proxy @s)) } + +-- Named sets operationId from the type-level name +instance (KnownSymbol name, EndpointToOperation inner) + => EndpointToOperation (Named name inner) where + toOperation = + let op = toOperation @inner + in op { opOperationId = Just (T.pack (symbolVal (Proxy @name))) } + +-- Versioned prepends the version prefix to the path +instance (ApiVersion v, EndpointToOperation inner) + => EndpointToOperation (Versioned v inner) where + toOperation = + let op = toOperation @inner + in op { opPath = "/" <> versionPrefix @v <> opPath op } + + +-- =================================================================== +-- Query parameter reflection +-- =================================================================== + +-- | Reflect type-level query parameter declarations into runtime Parameter values. +class ReflectParams (ps :: [Type]) where + reflectParams :: [Parameter] + +instance ReflectParams '[] where + reflectParams = [] + +instance (KnownSymbol name, ReflectParams rest) + => ReflectParams (QP name a ': rest) where + reflectParams = Parameter + { paramName = T.pack (symbolVal (Proxy @name)) + , paramIn = "query" + , paramRequired = False + , paramSchema = Schema "string" [] Nothing Nothing Nothing Nothing False + } : reflectParams @rest + + +-- =================================================================== +-- Header parameter reflection +-- =================================================================== + +-- | Reflect type-level header declarations into runtime Parameter values. +class ReflectHeaders (hs :: [Type]) where + reflectHeaders :: [Parameter] + +instance ReflectHeaders '[] where + reflectHeaders = [] + +instance (KnownSymbol name, ReflectHeaders rest) + => ReflectHeaders (HH name a ': rest) where + reflectHeaders = Parameter + { paramName = T.pack (symbolVal (Proxy @name)) + , paramIn = "header" + , paramRequired = True + , paramSchema = Schema "string" [] Nothing Nothing Nothing Nothing False + } : reflectHeaders @rest + + +-- =================================================================== +-- Capture name reflection +-- =================================================================== + +-- | Derive a parameter name for a capture type. +-- Override this for custom names; the default lowercases the type name. +class KnownCaptureName (t :: Type) where + captureName :: Text + +instance {-# OVERLAPPABLE #-} Typeable t => KnownCaptureName t where + captureName = T.toLower (T.pack (show (typeRep (Proxy @t)))) + + +-- =================================================================== +-- Path reflection for OpenAPI format +-- =================================================================== + +class ReflectPathOA (path :: [PathSegment]) where + reflectOAPath :: Text + reflectOAParams :: [Parameter] + +instance ReflectPathOA '[] where + reflectOAPath = "" + reflectOAParams = [] + +instance (KnownSymbol s, ReflectPathOA rest) + => ReflectPathOA ('Lit s ': rest) where + reflectOAPath = "/" <> T.pack (symbolVal (Proxy @s)) <> reflectOAPath @rest + reflectOAParams = reflectOAParams @rest + +instance (KnownCaptureName t, ToSchema t, ReflectPathOA rest) + => ReflectPathOA ('Capture t ': rest) where + reflectOAPath = "/{" <> captureName @t <> "}" <> reflectOAPath @rest + reflectOAParams = Parameter + { paramName = captureName @t + , paramIn = "path" + , paramRequired = True + , paramSchema = toSchema @t + } : reflectOAParams @rest + +instance (KnownSymbol name, ToSchema t, ReflectPathOA rest) + => ReflectPathOA ('CaptureNamed name t ': rest) where + reflectOAPath = "/{" <> T.pack (symbolVal (Proxy @name)) <> "}" <> reflectOAPath @rest + reflectOAParams = Parameter + { paramName = T.pack (symbolVal (Proxy @name)) + , paramIn = "path" + , paramRequired = True + , paramSchema = toSchema @t + } : reflectOAParams @rest + + +-- =================================================================== +-- Walk an API type list +-- =================================================================== + +-- | Walk a promoted list of endpoint types, collecting their 'Operation's. +class ApiToOperations (api :: [Type]) where + toOperations :: [Operation] + +instance ApiToOperations '[] where + toOperations = [] + +instance (EndpointToOperation e, ApiToOperations rest) + => ApiToOperations (e ': rest) where + toOperations = toOperation @e : toOperations @rest + + +-- =================================================================== +-- Top-level spec generation +-- =================================================================== + +-- | Generate a complete OpenAPI 3.1 spec from an API type, title, and version. +generateSpec + :: forall api. ApiToOperations api + => Text -> Text -> OpenApiSpec +generateSpec title version = OpenApiSpec + { specTitle = title + , specVersion = version + , specOps = toOperations @api + } diff --git a/src/Acolyte/OpenApi/V2.hs b/src/Acolyte/OpenApi/V2.hs new file mode 100644 --- /dev/null +++ b/src/Acolyte/OpenApi/V2.hs @@ -0,0 +1,137 @@ +-- | Swagger / OpenAPI 2.0 spec rendering. +-- +-- Generates a Swagger 2.0 JSON document from the same internal +-- 'Operation' representation that OpenAPI 3.x uses. The type-level +-- API walking is shared; only the JSON format differs. +-- +-- @ +-- import Acolyte.OpenApi.V2 (generateSwagger) +-- +-- spec = generateSwagger @MyAPI "My API" "1.0.0" "localhost" "/api" +-- @ +module Acolyte.OpenApi.V2 + ( -- * Swagger 2.0 spec + SwaggerSpec (..) + , generateSwagger + ) where + +import Data.Aeson (Value (..), object, (.=), ToJSON (..)) +import qualified Data.Aeson.Key as Key +import Data.Kind (Type) +import Data.Text (Text) +import qualified Data.Text as T + +import Acolyte.OpenApi.Spec + ( Operation (..), Parameter (..), ApiToOperations (..) + , opMethodLower + ) +import Acolyte.OpenApi.Schema (Schema (..), schemaToJson) + + +-- | A Swagger 2.0 spec. +data SwaggerSpec = SwaggerSpec + { swaggerTitle :: !Text + , swaggerVersion :: !Text + , swaggerHost :: !Text + , swaggerBasePath :: !Text + , swaggerOps :: ![Operation] + } deriving (Show) + +instance ToJSON SwaggerSpec where + toJSON spec = object + [ "swagger" .= ("2.0" :: Text) + , "info" .= object + [ "title" .= swaggerTitle spec + , "version" .= swaggerVersion spec + ] + , "host" .= swaggerHost spec + , "basePath" .= swaggerBasePath spec + , "schemes" .= (["https", "http"] :: [Text]) + , "consumes" .= (["application/json"] :: [Text]) + , "produces" .= (["application/json"] :: [Text]) + , "paths" .= swaggerPaths (swaggerOps spec) + ] + + +-- | Group operations by path, Swagger 2.0 format. +swaggerPaths :: [Operation] -> Value +swaggerPaths ops = object + [ Key.fromText (opPath op) .= object + [ Key.fromText (opMethodLower op) .= swaggerOperation op ] + | op <- ops + ] + + +-- | Render a single operation in Swagger 2.0 format. +-- +-- Swagger 2.0 differences from OpenAPI 3.x: +-- * Parameters include body params (not a separate requestBody) +-- * Responses use a simpler schema format +-- * No content negotiation per-operation +swaggerOperation :: Operation -> Value +swaggerOperation op = object $ concat + [ case opOperationId op of + Nothing -> [] + Just oid -> ["operationId" .= oid] + , case opSummary op of + Nothing -> [] + Just s -> ["summary" .= s] + , case opDescription op of + Nothing -> [] + Just d -> ["description" .= d] + , [ "responses" .= object + [ Key.fromText (T.pack (show (opStatusCode op))) .= responseObj ] + ] + , let allParams = map swaggerParam (opParameters op) + ++ bodyParam (opRequestBody op) + in if null allParams then [] + else ["parameters" .= allParams] + ] + where + responseObj = case opResponseSchema op of + Nothing -> object ["description" .= ("Success" :: Text)] + Just schema -> object + [ "description" .= ("Success" :: Text) + , "schema" .= schemaToJson schema + ] + + bodyParam Nothing = [] + bodyParam (Just schema) = + [ object + [ "in" .= ("body" :: Text) + , "name" .= ("body" :: Text) + , "required" .= True + , "schema" .= schemaToJson schema + ] + ] + + +-- | Render a path/query parameter in Swagger 2.0 format. +swaggerParam :: Parameter -> Value +swaggerParam p = object + [ "name" .= paramName p + , "in" .= paramIn p + , "required" .= paramRequired p + , "type" .= schemaType (paramSchema p) + ] + + +-- | Generate a Swagger 2.0 spec from an API type. +-- +-- @ +-- spec = generateSwagger @MyAPI "My API" "1.0.0" "localhost:3000" "/api" +-- @ +generateSwagger + :: forall api. ApiToOperations api + => Text -- ^ Title + -> Text -- ^ Version + -> Text -- ^ Host (e.g., "localhost:3000") + -> Text -- ^ Base path (e.g., "/api" or "/") + -> SwaggerSpec +generateSwagger title version host basePath = SwaggerSpec + { swaggerTitle = title + , swaggerVersion = version + , swaggerHost = host + , swaggerBasePath = basePath + , swaggerOps = toOperations @api + } diff --git a/src/Acolyte/OpenApi/V3.hs b/src/Acolyte/OpenApi/V3.hs new file mode 100644 --- /dev/null +++ b/src/Acolyte/OpenApi/V3.hs @@ -0,0 +1,121 @@ +-- | OpenAPI 3.1 spec rendering. +-- +-- Generates an OpenAPI 3.1 JSON document from the shared internal +-- 'Operation' representation. +-- +-- @ +-- import Acolyte.OpenApi.V3 (generateOpenApi3) +-- +-- spec = generateOpenApi3 @MyAPI "My API" "1.0.0" +-- @ +module Acolyte.OpenApi.V3 + ( -- * OpenAPI 3.1 spec + OpenApi3Spec (..) + , generateOpenApi3 + ) where + +import Data.Aeson (Value (..), object, (.=), ToJSON (..)) +import qualified Data.Aeson.Key as Key +import Data.Kind (Type) +import Data.Text (Text) +import qualified Data.Text as T + +import Acolyte.OpenApi.Spec + ( Operation (..), Parameter (..), ApiToOperations (..) + , opMethodLower + ) +import Acolyte.OpenApi.Schema (Schema (..), schemaToJson) + + +-- | An OpenAPI 3.1 spec. +data OpenApi3Spec = OpenApi3Spec + { oa3Title :: !Text + , oa3Version :: !Text + , oa3Ops :: ![Operation] + } deriving (Show) + +instance ToJSON OpenApi3Spec where + toJSON spec = object + [ "openapi" .= ("3.1.0" :: Text) + , "info" .= object + [ "title" .= oa3Title spec + , "version" .= oa3Version spec + ] + , "paths" .= oa3Paths (oa3Ops spec) + ] + + +-- | Group operations by path, OpenAPI 3.x format. +oa3Paths :: [Operation] -> Value +oa3Paths ops = object + [ Key.fromText (opPath op) .= object + [ Key.fromText (opMethodLower op) .= oa3Operation op ] + | op <- ops + ] + + +-- | Render a single operation in OpenAPI 3.x format. +-- +-- OpenAPI 3.x differences from Swagger 2.0: +-- * requestBody is a separate field (not a body parameter) +-- * Response content uses media type keys +-- * Richer content negotiation support +oa3Operation :: Operation -> Value +oa3Operation op = object $ concat + [ case opOperationId op of + Nothing -> [] + Just oid -> ["operationId" .= oid] + , case opSummary op of + Nothing -> [] + Just s -> ["summary" .= s] + , case opDescription op of + Nothing -> [] + Just d -> ["description" .= d] + , [ "responses" .= object + [ Key.fromText (T.pack (show (opStatusCode op))) .= responseObj ] + ] + , if null (opParameters op) then [] + else ["parameters" .= map oa3Param (opParameters op)] + , case opRequestBody op of + Nothing -> [] + Just schema -> + [ "requestBody" .= object + [ "required" .= True + , "content" .= object + [ "application/json" .= object + [ "schema" .= schemaToJson schema ] + ] + ] + ] + ] + where + responseObj = case opResponseSchema op of + Nothing -> object ["description" .= ("Success" :: Text)] + Just schema -> object + [ "description" .= ("Success" :: Text) + , "content" .= object + [ "application/json" .= object + [ "schema" .= schemaToJson schema ] + ] + ] + + +-- | Render a parameter in OpenAPI 3.x format. +oa3Param :: Parameter -> Value +oa3Param p = object + [ "name" .= paramName p + , "in" .= paramIn p + , "required" .= paramRequired p + , "schema" .= schemaToJson (paramSchema p) + ] + + +-- | Generate an OpenAPI 3.1 spec from an API type. +generateOpenApi3 + :: forall api. ApiToOperations api + => Text -> Text -> OpenApi3Spec +generateOpenApi3 title version = OpenApi3Spec + { oa3Title = title + , oa3Version = version + , oa3Ops = toOperations @api + } diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,462 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeApplications #-} +module Main (main) where + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.KeyMap as KM +import qualified Data.ByteString.Lazy as LBS +import GHC.Generics (Generic) + +import Acolyte.Core +import Acolyte.OpenApi + + +assert :: String -> Bool -> IO () +assert label True = putStrLn $ " OK: " ++ label +assert label False = error $ "FAIL: " ++ label + + +-- =================================================================== +-- API types +-- =================================================================== + +type HealthPath = '[ 'Lit "health" ] +type UsersPath = '[ 'Lit "users" ] +type UserByIdPath = '[ 'Lit "users", 'Capture Int ] + +type TestAPI = + '[ Get HealthPath Text + , Get UsersPath Text + , Get UserByIdPath Text + , Post UsersPath Text Text + ] + + +-- =================================================================== +-- Tests +-- =================================================================== + +testGenerateSpec :: IO () +testGenerateSpec = do + let spec = generateSpec @TestAPI "Test API" "1.0.0" + assert "spec title" (specTitle spec == "Test API") + assert "spec version" (specVersion spec == "1.0.0") + assert "spec has 4 operations" (length (specOps spec) == 4) + +testOperations :: IO () +testOperations = do + let ops = toOperations @TestAPI + assert "4 operations" (length ops == 4) + + let op1 = ops !! 0 + assert "op1 method GET" (opMethod op1 == "GET") + assert "op1 path /health" (opPath op1 == "/health") + assert "op1 no params" (null (opParameters op1)) + + let op3 = ops !! 2 + assert "op3 method GET" (opMethod op3 == "GET") + assert "op3 path /users/{int}" (opPath op3 == "/users/{int}") + assert "op3 has path param" (length (opParameters op3) == 1) + + let param = head (opParameters op3) + assert "param name 'int'" (paramName param == "int") + assert "param in 'path'" (paramIn param == "path") + assert "param required" (paramRequired param) + +testJsonOutput :: IO () +testJsonOutput = do + let spec = generateSpec @TestAPI "Test API" "1.0.0" + json = Aeson.toJSON spec + -- Should produce valid JSON + case json of + Aeson.Object obj -> do + assert "has openapi field" (KM.member "openapi" obj) + assert "has info field" (KM.member "info" obj) + assert "has paths field" (KM.member "paths" obj) + _ -> error "FAIL: spec is not a JSON object" + +testEndpointToOperation :: IO () +testEndpointToOperation = do + let op = toOperation @(Get UserByIdPath Text) + assert "endpoint op: GET" (opMethod op == "GET") + assert "endpoint op: /users/{int}" (opPath op == "/users/{int}") + assert "endpoint op: 1 param" (length (opParameters op) == 1) + assert "endpoint op: status 200" (opStatusCode op == 200) + + -- POST gets 201 + let op2 = toOperation @(Post UsersPath Text Text) + assert "POST status 201" (opStatusCode op2 == 201) + +testRequiresDelegate :: IO () +testRequiresDelegate = do + let op = toOperation @(Requires Auth (Get UserByIdPath Text)) + assert "Requires delegates: GET" (opMethod op == "GET") + assert "Requires delegates: /users/{int}" (opPath op == "/users/{int}") + +testSchema :: IO () +testSchema = do + assert "Int schema" (schemaType (toSchema @Int) == "integer") + assert "Text schema" (schemaType (toSchema @Text) == "string") + assert "Bool schema" (schemaType (toSchema @Bool) == "boolean") + assert "[Int] schema" (schemaType (toSchema @[Int]) == "array") + + +-- =================================================================== +-- Swagger 2.0 tests +-- =================================================================== + +testSwagger :: IO () +testSwagger = do + let spec = generateSwagger @TestAPI "Test API" "1.0.0" "localhost:3000" "/api" + json = Aeson.toJSON spec + case json of + Aeson.Object obj -> do + assert "swagger: has swagger field" (KM.member "swagger" obj) + assert "swagger: has host field" (KM.member "host" obj) + assert "swagger: has basePath field" (KM.member "basePath" obj) + assert "swagger: has paths field" (KM.member "paths" obj) + assert "swagger: has consumes" (KM.member "consumes" obj) + -- Verify swagger version + case KM.lookup "swagger" obj of + Just (Aeson.String v) -> assert "swagger: version 2.0" (v == "2.0") + _ -> error "FAIL: swagger field not a string" + _ -> error "FAIL: swagger spec is not a JSON object" + +-- =================================================================== +-- OpenAPI 3.1 explicit tests +-- =================================================================== + +testOpenApi3 :: IO () +testOpenApi3 = do + let spec = generateOpenApi3 @TestAPI "Test API" "1.0.0" + json = Aeson.toJSON spec + case json of + Aeson.Object obj -> do + assert "oa3: has openapi field" (KM.member "openapi" obj) + assert "oa3: has paths field" (KM.member "paths" obj) + case KM.lookup "openapi" obj of + Just (Aeson.String v) -> assert "oa3: version 3.1.0" (v == "3.1.0") + _ -> error "FAIL: openapi field not a string" + _ -> error "FAIL: openapi3 spec is not a JSON object" + + +-- =================================================================== +-- Named endpoint operationId tests +-- =================================================================== + +testNamedOperationId :: IO () +testNamedOperationId = do + -- Named endpoint produces operationId + let op = toOperation @(Named "getUser" (Get UserByIdPath Text)) + assert "Named: operationId set" (opOperationId op == Just "getUser") + assert "Named: method delegated" (opMethod op == "GET") + assert "Named: path delegated" (opPath op == "/users/{int}") + + -- Unnamed endpoint has no operationId + let op2 = toOperation @(Get HealthPath Text) + assert "Unnamed: no operationId" (opOperationId op2 == Nothing) + + -- Named + Describe stacking + let op3 = toOperation @(Named "health" (Describe "Health check" (Get HealthPath Text))) + assert "Named+Describe: operationId set" (opOperationId op3 == Just "health") + assert "Named+Describe: method GET" (opMethod op3 == "GET") + + -- Named + Requires stacking + let op4 = toOperation @(Named "secureGet" (Requires Auth (Get HealthPath Text))) + assert "Named+Requires: operationId set" (opOperationId op4 == Just "secureGet") + +testNamedApiSpec :: IO () +testNamedApiSpec = do + -- Full API with Named endpoints generates operationIds + let ops = toOperations @'[ Named "listUsers" (Get UsersPath Text) + , Named "getUser" (Get UserByIdPath Text) + , Named "createUser" (Post UsersPath Text Text) + ] + assert "named API: 3 operations" (length ops == 3) + assert "named API: op1 id" (opOperationId (ops !! 0) == Just "listUsers") + assert "named API: op2 id" (opOperationId (ops !! 1) == Just "getUser") + assert "named API: op3 id" (opOperationId (ops !! 2) == Just "createUser") + + -- JSON output includes operationId + let spec = generateSpec @'[ Named "health" (Get HealthPath Text) ] "Test" "1.0" + json = Aeson.toJSON spec + bs = LBS.toStrict (Aeson.encode json) + assert "named spec JSON contains operationId" (T.isInfixOf "operationId" (T.pack (show bs))) + + +-- =================================================================== +-- Describe test +-- =================================================================== + +testDescribe :: IO () +testDescribe = do + let op = toOperation @(Describe "Health check" (Get HealthPath Text)) + assert "Describe: summary set" (opSummary op == Just "Health check") + assert "Describe: method delegated" (opMethod op == "GET") + assert "Describe: path delegated" (opPath op == "/health") + + +-- =================================================================== +-- RespondsWith test +-- =================================================================== + +testRespondsWith :: IO () +testRespondsWith = do + let op = toOperation @(RespondsWith 204 (Post (At "items") Text Text)) + assert "RespondsWith: status 204" (opStatusCode op == 204) + assert "RespondsWith: method POST" (opMethod op == "POST") + assert "RespondsWith: path /items" (opPath op == "/items") + + +-- =================================================================== +-- WithParams test +-- =================================================================== + +testWithParams :: IO () +testWithParams = do + let op = toOperation @(WithParams '[QP "page" Int, QP "limit" Int] (Get (At "users") Text)) + assert "WithParams: 2 query params" (length (opParameters op) == 2) + assert "WithParams: first param 'page'" (paramName (opParameters op !! 0) == "page") + assert "WithParams: second param 'limit'" (paramName (opParameters op !! 1) == "limit") + assert "WithParams: params are query" (all (\p -> paramIn p == "query") (opParameters op)) + + +-- =================================================================== +-- WithHeaders test +-- =================================================================== + +testWithHeaders :: IO () +testWithHeaders = do + let op = toOperation @(WithHeaders '[HH "Authorization" Text] (Get (At "users") Text)) + assert "WithHeaders: 1 header param" (length (opParameters op) == 1) + assert "WithHeaders: header name 'Authorization'" (paramName (head (opParameters op)) == "Authorization") + assert "WithHeaders: param in 'header'" (paramIn (head (opParameters op)) == "header") + + +-- =================================================================== +-- Versioned test +-- =================================================================== + +data V1 +instance ApiVersion V1 where versionPrefix = "v1" + +testVersionedOpenApi :: IO () +testVersionedOpenApi = do + let op = toOperation @(Versioned V1 (Get HealthPath Text)) + assert "Versioned: path starts with /v1" (T.isPrefixOf "/v1" (opPath op)) + assert "Versioned: full path /v1/health" (opPath op == "/v1/health") + assert "Versioned: method delegated" (opMethod op == "GET") + + +-- =================================================================== +-- Stacking wrappers test +-- =================================================================== + +testStackedWrappers :: IO () +testStackedWrappers = do + let op = toOperation @(Named "x" (Describe "y" (WithParams '[QP "p" Int] (Get (At "z") Text)))) + assert "Stacked: operationId set" (opOperationId op == Just "x") + assert "Stacked: summary set" (opSummary op == Just "y") + assert "Stacked: has query param" (length (opParameters op) == 1) + assert "Stacked: param name 'p'" (paramName (head (opParameters op)) == "p") + assert "Stacked: method GET" (opMethod op == "GET") + assert "Stacked: path /z" (opPath op == "/z") + + +-- =================================================================== +-- Generic ToSchema derivation test +-- =================================================================== + +data TestUser = TestUser { userName :: Text, userAge :: Int } + deriving (Generic) + +instance ToSchema TestUser + +testGenericSchema :: IO () +testGenericSchema = do + let schema = toSchema @TestUser + assert "Generic: type is object" (schemaType schema == "object") + assert "Generic: has 2 properties" (length (schemaProperties schema) == 2) + let props = schemaProperties schema + assert "Generic: has userName" (any (\(k, _) -> k == "userName") props) + assert "Generic: has userAge" (any (\(k, _) -> k == "userAge") props) + case lookup "userName" props of + Just s -> assert "Generic: userName is string" (schemaType s == "string") + Nothing -> error "FAIL: userName property missing" + case lookup "userAge" props of + Just s -> assert "Generic: userAge is integer" (schemaType s == "integer") + Nothing -> error "FAIL: userAge property missing" + + +-- =================================================================== +-- Body schema tests +-- =================================================================== + +testBodySchemas :: IO () +testBodySchemas = do + -- GET response schema + let op1 = toOperation @(Get HealthPath Text) + assert "body: GET has response schema" (opResponseSchema op1 /= Nothing) + case opResponseSchema op1 of + Just s -> assert "body: GET response is string" (schemaType s == "string") + Nothing -> error "FAIL: no response schema" + assert "body: GET has no request body" (opRequestBody op1 == Nothing) + + -- POST request + response schemas + let op2 = toOperation @(Post (At "users") Text Text) + assert "body: POST has response schema" (opResponseSchema op2 /= Nothing) + assert "body: POST has request body" (opRequestBody op2 /= Nothing) + + -- Json unwrapping + let op3 = toOperation @(Get HealthPath (Json [Int])) + case opResponseSchema op3 of + Just s -> assert "body: Json [Int] is array" (schemaType s == "array") + Nothing -> error "FAIL: no response schema for Json" + + -- Generic type in endpoint + let op4 = toOperation @(Post (At "users") (Json TestUser) (Json TestUser)) + case opRequestBody op4 of + Just s -> assert "body: Generic type in request" (schemaType s == "object") + Nothing -> error "FAIL: no request body for Generic type" + case opResponseSchema op4 of + Just s -> assert "body: Generic type in response" (length (schemaProperties s) == 2) + Nothing -> error "FAIL: no response schema for Generic type" + + +-- =================================================================== +-- CaptureNamed test +-- =================================================================== + +testCaptureNamed :: IO () +testCaptureNamed = do + let op = toOperation @(Get (ParamNamed "userId" "users" Int) Text) + assert "CaptureNamed: path has named param" (opPath op == "/users/{userId}") + assert "CaptureNamed: param name is userId" (paramName (head (opParameters op)) == "userId") + + +-- =================================================================== +-- Description test +-- =================================================================== + +testDescription :: IO () +testDescription = do + let op = toOperation @(Description "Detailed docs here" (Get HealthPath Text)) + assert "Description: opDescription set" (opDescription op == Just "Detailed docs here") + assert "Description: summary unset" (opSummary op == Nothing) + -- Describe + Description stacking + let op2 = toOperation @(Describe "Short" (Description "Long" (Get HealthPath Text))) + assert "Describe+Description: summary" (opSummary op2 == Just "Short") + assert "Describe+Description: description" (opDescription op2 == Just "Long") + + +-- =================================================================== +-- Sum type / enum schema test +-- =================================================================== + +data Color = Red | Green | Blue deriving (Generic) +instance ToSchema Color + +data Shape = Circle { radius :: Double } | Rectangle { width :: Double, height :: Double } + deriving (Generic) +instance ToSchema Shape + +testSumTypeSchema :: IO () +testSumTypeSchema = do + -- Sum type with constructors produces oneOf + let schema = toSchema @Shape + assert "Sum type: has oneOf" (schemaOneOf schema /= Nothing) + case schemaOneOf schema of + Just variants -> assert "Sum type: 2 variants" (length variants == 2) + Nothing -> error "FAIL: expected oneOf" + + -- Either produces oneOf + let eitherSchema = toSchema @(Either Text Int) + assert "Either: has oneOf" (schemaOneOf eitherSchema /= Nothing) + + +-- =================================================================== +-- CaptureNamed body schema test +-- =================================================================== + +testCaptureNamedBodySchema :: IO () +testCaptureNamedBodySchema = do + let op = toOperation @(Post (ParamNamed "userId" "users" Int) (Json Text) (Json Text)) + assert "CaptureNamed POST: has request body" (opRequestBody op /= Nothing) + assert "CaptureNamed POST: has response schema" (opResponseSchema op /= Nothing) + + +main :: IO () +main = do + putStrLn "acolyte-openapi tests:" + putStrLn "" + putStrLn "Spec generation (default = 3.1):" + testGenerateSpec + putStrLn "" + putStrLn "Operations:" + testOperations + putStrLn "" + putStrLn "JSON output:" + testJsonOutput + putStrLn "" + putStrLn "EndpointToOperation:" + testEndpointToOperation + putStrLn "" + putStrLn "Requires delegation:" + testRequiresDelegate + putStrLn "" + putStrLn "Schema:" + testSchema + putStrLn "" + putStrLn "Swagger 2.0:" + testSwagger + putStrLn "" + putStrLn "OpenAPI 3.1 (explicit):" + testOpenApi3 + putStrLn "" + putStrLn "Named endpoint operationId:" + testNamedOperationId + putStrLn "" + putStrLn "Named API spec generation:" + testNamedApiSpec + putStrLn "" + putStrLn "Describe wrapper:" + testDescribe + putStrLn "" + putStrLn "RespondsWith wrapper:" + testRespondsWith + putStrLn "" + putStrLn "WithParams wrapper:" + testWithParams + putStrLn "" + putStrLn "WithHeaders wrapper:" + testWithHeaders + putStrLn "" + putStrLn "Versioned wrapper (OpenAPI):" + testVersionedOpenApi + putStrLn "" + putStrLn "Stacked wrappers:" + testStackedWrappers + putStrLn "" + putStrLn "Generic ToSchema derivation:" + testGenericSchema + putStrLn "" + putStrLn "Body schemas:" + testBodySchemas + putStrLn "" + putStrLn "CaptureNamed:" + testCaptureNamed + putStrLn "" + putStrLn "Description wrapper:" + testDescription + putStrLn "" + putStrLn "Sum type / enum schema:" + testSumTypeSchema + putStrLn "" + putStrLn "CaptureNamed body schema:" + testCaptureNamedBodySchema + putStrLn "" + putStrLn "All acolyte-openapi tests passed."