@@ -45,6 +45,23 @@ module Yoga.HTTP.API.Route.OpenAPI
45 , ServerObject
45 , ServerObject
46 , OpenAPISpec
46 , OpenAPISpec
47 , ResponseHeaderObject
47 , ResponseHeaderObject
48+ , class CollectSchemas
50+ , class CollectSchemasRL
52+ , class CollectVariantSchemasRL
53+ , collectVariantSchemasRL
54+ , class CollectRouteSchemas
55+ , collectRouteSchemas
56+ , class CollectRouteSchemasRL
57+ , collectRouteSchemasRL
58+ , class CollectSchemaNames
59+ , class CollectSchemaNamesRL
60+ , class CollectVariantSchemaNames
61+ , class CollectRouteSchemaNames
62+ , class CollectRouteSchemaNameRL
63+ , class ValidateNoDuplicatesRL
64+ , class ValidateSchemaNames
50import Prelude
67import Prelude
@@ -66,7 +83,7 @@ import Unsafe.Coerce (unsafeCoerce)
66import Yoga.HTTP.API.Route.BearerToken (BearerToken)
83import Yoga.HTTP.API.Route.BearerToken (BearerToken)
67import Yoga.HTTP.API.Route.Encoding (JSON, FormData, NoBody)
84import Yoga.HTTP.API.Route.Encoding (JSON, FormData, NoBody)
68import Yoga.HTTP.API.Route.HeaderValue (class HeaderValueType, headerValueType)
85import Yoga.HTTP.API.Route.HeaderValue (class HeaderValueType, headerValueType)
69−import Yoga.HTTP.API.Route.OpenAPIMetadata (Description, Example, Format, Minimum, Maximum, Pattern, MinLength, MaxLength, Title, Nullable, Default, Deprecated, Enum, class HasDescription, description, class HasExample, example, class HasFormat, format, class HasDeprecated, deprecated, class HasMinimum, minimum, class HasMaximum, maximum, class HasPattern, pattern, class HasMinLength, minLength, class HasMaxLength, maxLength, class HasTitle, title, class HasNullable, nullable, class HasDefault, default, class HasEnum, enum, class HasOperationMetadata, operationMetadata)
86+import Yoga.HTTP.API.Route.OpenAPIMetadata (Description, Example, Format, Minimum, Maximum, Pattern, MinLength, MaxLength, Title, Nullable, Default, Deprecated, Enum, Schema, class HasDescription, description, class HasExample, example, class HasFormat, format, class HasDeprecated, deprecated, class HasMinimum, minimum, class HasMaximum, maximum, class HasPattern, pattern, class HasMinLength, minLength, class HasMaxLength, maxLength, class HasTitle, title, class HasNullable, nullable, class HasDefault, default, class HasEnum, enum, class HasOperationMetadata, operationMetadata)
70import Yoga.HTTP.API.Route.Response (class ToResponse)
87import Yoga.HTTP.API.Route.Response (class ToResponse)
71import Yoga.HTTP.API.Route.StatusCode (class StatusCodeMap, statusCodeFor, statusCodeToString)
88import Yoga.HTTP.API.Route.StatusCode (class StatusCodeMap, statusCodeFor, statusCodeToString)
72import Yoga.JSON (class WriteForeign, writeImpl)
89import Yoga.JSON (class WriteForeign, writeImpl)
@@ -604,6 +621,14 @@ instance (RenderJSONSchema a, HasEnum (Enum a)) => RenderJSONSchema (Enum a) whe
605 unsafeCoerce withEnum
622 unsafeCoerce withEnum
624+-- Schema wrapper: generates $ref instead of inline schema
625+instance (IsSymbol name, RenderJSONSchema a) => RenderJSONSchema (Schema name a) where
626+ renderJSONSchema _ =
628+ schemaName = reflectSymbol (Proxy :: Proxy name)
630+ unsafeCoerce $ FObject.singleton "$ref" (unsafeCoerce $ "#/components/schemas/" <> schemaName)
607-- Other metadata wrappers (Minimum, Maximum, Pattern, MinLength, MaxLength, Title, Default)
632-- Other metadata wrappers (Minimum, Maximum, Pattern, MinLength, MaxLength, Title, Default)
608-- are similar but require more complex constraints, so we'll skip them for now in body schemas
633-- are similar but require more complex constraints, so we'll skip them for now in body schemas
@@ -863,6 +888,282 @@ class ToOpenAPI (route :: Type) where
863toOpenAPI :: forall @a. ToOpenAPI a => String
888toOpenAPI :: forall @a. ToOpenAPI a => String
864toOpenAPI = toOpenAPIImpl (Proxy :: Proxy a)
889toOpenAPI = toOpenAPIImpl (Proxy :: Proxy a)
891+--------------------------------------------------------------------------------
892+-- CollectSchemas: Collect all Schema wrappers for component extraction
893+--------------------------------------------------------------------------------
895+-- | Collects all Schema wrappers found in a type and returns their definitions
896+class CollectSchemas (ty :: Type) where
897+ collectSchemas :: Proxy ty -> FObject.Object Foreign
899+-- Base cases: primitives don't contain schemas
900+instance CollectSchemas String where
901+ collectSchemas _ = FObject.empty
903+instance CollectSchemas Int where
904+ collectSchemas _ = FObject.empty
906+instance CollectSchemas Number where
907+ collectSchemas _ = FObject.empty
909+instance CollectSchemas Boolean where
910+ collectSchemas _ = FObject.empty
912+instance CollectSchemas Unit where
913+ collectSchemas _ = FObject.empty
915+-- Array: recurse into item type
916+instance CollectSchemas a => CollectSchemas (Array a) where
917+ collectSchemas _ = collectSchemas (Proxy :: Proxy a)
919+-- Maybe: recurse into inner type
920+instance CollectSchemas a => CollectSchemas (Maybe a) where
921+ collectSchemas _ = collectSchemas (Proxy :: Proxy a)
923+-- Record: recurse through all fields
924+instance (RowToList row rl, CollectSchemasRL rl) => CollectSchemas (Record row) where
925+ collectSchemas _ = collectSchemasRL (Proxy :: Proxy rl)
927+-- JSON wrapper: unwrap and recurse
928+instance CollectSchemas a => CollectSchemas (JSON a) where
929+ collectSchemas _ = collectSchemas (Proxy :: Proxy a)
931+-- FormData wrapper: unwrap and recurse
932+instance CollectSchemas a => CollectSchemas (FormData a) where
933+ collectSchemas _ = collectSchemas (Proxy :: Proxy a)
935+-- NoBody: no schemas
936+instance CollectSchemas NoBody where
937+ collectSchemas _ = FObject.empty
939+-- Schema wrapper: COLLECT THIS + recurse into inner type
940+instance (IsSymbol name, RenderJSONSchema inner, CollectSchemas inner) => CollectSchemas (Schema name inner) where
943+ schemaName = reflectSymbol (Proxy :: Proxy name)
944+ -- Render the INNER type (not the Schema wrapper) for the component definition
945+ innerSchema = renderJSONSchema (Proxy :: Proxy inner)
946+ -- Also collect any nested schemas
947+ nestedSchemas = collectSchemas (Proxy :: Proxy inner)
949+ FObject.insert schemaName innerSchema nestedSchemas
951+-- Metadata wrappers: recurse through to find schemas
952+instance CollectSchemas a => CollectSchemas (Description desc a) where
953+ collectSchemas _ = collectSchemas (Proxy :: Proxy a)
955+instance CollectSchemas a => CollectSchemas (Example ex a) where
956+ collectSchemas _ = collectSchemas (Proxy :: Proxy a)
958+instance CollectSchemas a => CollectSchemas (Format fmt a) where
959+ collectSchemas _ = collectSchemas (Proxy :: Proxy a)
961+instance CollectSchemas a => CollectSchemas (Minimum v a) where
962+ collectSchemas _ = collectSchemas (Proxy :: Proxy a)
964+instance CollectSchemas a => CollectSchemas (Maximum v a) where
965+ collectSchemas _ = collectSchemas (Proxy :: Proxy a)
967+instance CollectSchemas a => CollectSchemas (Pattern pat a) where
968+ collectSchemas _ = collectSchemas (Proxy :: Proxy a)
970+instance CollectSchemas a => CollectSchemas (MinLength v a) where
971+ collectSchemas _ = collectSchemas (Proxy :: Proxy a)
973+instance CollectSchemas a => CollectSchemas (MaxLength v a) where
974+ collectSchemas _ = collectSchemas (Proxy :: Proxy a)
976+instance CollectSchemas a => CollectSchemas (Title t a) where
977+ collectSchemas _ = collectSchemas (Proxy :: Proxy a)
979+instance CollectSchemas a => CollectSchemas (Nullable a) where
980+ collectSchemas _ = collectSchemas (Proxy :: Proxy a)
982+instance CollectSchemas a => CollectSchemas (Default val a) where
983+ collectSchemas _ = collectSchemas (Proxy :: Proxy a)
985+instance CollectSchemas a => CollectSchemas (Deprecated a) where
986+ collectSchemas _ = collectSchemas (Proxy :: Proxy a)
988+instance CollectSchemas a => CollectSchemas (Enum a) where
989+ collectSchemas _ = collectSchemas (Proxy :: Proxy a)
991+-- | Helper class to collect schemas from record fields
992+class CollectSchemasRL (rl :: RowList Type) where
993+ collectSchemasRL :: Proxy rl -> FObject.Object Foreign
995+instance CollectSchemasRL Nil where
996+ collectSchemasRL _ = FObject.empty
998+instance (IsSymbol name, CollectSchemas ty, CollectSchemasRL tail) => CollectSchemasRL (Cons name ty tail) where
999+ collectSchemasRL _ =
1001+ fieldSchemas = collectSchemas (Proxy :: Proxy ty)
1002+ restSchemas = collectSchemasRL (Proxy :: Proxy tail)
1004+ FObject.union fieldSchemas restSchemas
1006+-- | Collects schemas from all response bodies in a variant
1007+class CollectVariantSchemasRL (rl :: RowList Type) where
1008+ collectVariantSchemasRL :: Proxy rl -> FObject.Object Foreign
1010+instance CollectVariantSchemasRL Nil where
1011+ collectVariantSchemasRL _ = FObject.empty
1014+ ( ToResponse recordType headers body
1015+ , CollectSchemas body
1016+ , CollectVariantSchemasRL tail
1018+ CollectVariantSchemasRL (Cons label recordType tail) where
1019+ collectVariantSchemasRL _ =
1021+ bodySchemas = collectSchemas (Proxy :: Proxy body)
1022+ restSchemas = collectVariantSchemasRL (Proxy :: Proxy tail)
1024+ FObject.union bodySchemas restSchemas
1026+-- | Collects schemas from a route's request and response types
1027+class CollectRouteSchemas (route :: Type) where
1028+ collectRouteSchemas :: Proxy route -> FObject.Object Foreign
1030+-- | Helper class for collecting schemas from a record of routes
1031+class CollectRouteSchemasRL (rl :: RowList Type) where
1032+ collectRouteSchemasRL :: Proxy rl -> FObject.Object Foreign
1034+instance CollectRouteSchemasRL Nil where
1035+ collectRouteSchemasRL _ = FObject.empty
1038+ ( CollectRouteSchemas routeType
1039+ , CollectRouteSchemasRL tail
1041+ CollectRouteSchemasRL (Cons label routeType tail) where
1042+ collectRouteSchemasRL _ =
1044+ routeSchemas = collectRouteSchemas (Proxy :: Proxy routeType)
1045+ restSchemas = collectRouteSchemasRL (Proxy :: Proxy tail)
1047+ FObject.union routeSchemas restSchemas
1049+-- Record instance: iterate record fields via RowList
1050+instance (RowToList row rl, CollectRouteSchemasRL rl) => CollectRouteSchemas (Record row) where
1051+ collectRouteSchemas _ = collectRouteSchemasRL (Proxy :: Proxy rl)
1053+--------------------------------------------------------------------------------
1054+-- CollectSchemaNames: Type-level collision detection
1055+--------------------------------------------------------------------------------
1057+-- | Collects schema names at the type level as a Row.
1058+-- | Used with Row.Union + Row.Nub to detect name collisions at compile time.
1059+-- | Two Schema wrappers with the same name but different types cause a compile error.
1060+class CollectSchemaNames (ty :: Type) (names :: Row Type) | ty -> names
1062+instance CollectSchemaNames String ()
1063+instance CollectSchemaNames Int ()
1064+instance CollectSchemaNames Number ()
1065+instance CollectSchemaNames Boolean ()
1066+instance CollectSchemaNames Unit ()
1068+instance CollectSchemaNames a names => CollectSchemaNames (Array a) names
1069+instance CollectSchemaNames a names => CollectSchemaNames (Maybe a) names
1071+instance (RowToList row rl, CollectSchemaNamesRL rl names) => CollectSchemaNames (Record row) names
1073+instance CollectSchemaNames a names => CollectSchemaNames (JSON a) names
1074+instance CollectSchemaNames a names => CollectSchemaNames (FormData a) names
1075+instance CollectSchemaNames NoBody ()
1078+ ( CollectSchemaNames inner innerNames
1079+ , Row.Cons name inner innerNames names
1080+ , Row.Lacks name innerNames
1082+ CollectSchemaNames (Schema name inner) names
1084+-- Metadata wrappers: recurse through
1085+instance CollectSchemaNames a names => CollectSchemaNames (Description desc a) names
1086+instance CollectSchemaNames a names => CollectSchemaNames (Example ex a) names
1087+instance CollectSchemaNames a names => CollectSchemaNames (Format fmt a) names
1088+instance CollectSchemaNames a names => CollectSchemaNames (Minimum v a) names
1089+instance CollectSchemaNames a names => CollectSchemaNames (Maximum v a) names
1090+instance CollectSchemaNames a names => CollectSchemaNames (Pattern pat a) names
1091+instance CollectSchemaNames a names => CollectSchemaNames (MinLength v a) names
1092+instance CollectSchemaNames a names => CollectSchemaNames (MaxLength v a) names
1093+instance CollectSchemaNames a names => CollectSchemaNames (Title t a) names
1094+instance CollectSchemaNames a names => CollectSchemaNames (Nullable a) names
1095+instance CollectSchemaNames a names => CollectSchemaNames (Default val a) names
1096+instance CollectSchemaNames a names => CollectSchemaNames (Deprecated a) names
1097+instance CollectSchemaNames a names => CollectSchemaNames (Enum a) names
1099+-- | Helper class to collect schema names from record fields
1100+class CollectSchemaNamesRL (rl :: RowList Type) (names :: Row Type) | rl -> names
1102+instance CollectSchemaNamesRL Nil ()
1105+ ( CollectSchemaNames ty fieldNames
1106+ , CollectSchemaNamesRL tail tailNames
1107+ , Row.Union fieldNames tailNames names
1109+ CollectSchemaNamesRL (Cons name ty tail) names
1111+-- | Collects schema names from all response bodies in a variant
1112+class CollectVariantSchemaNames (rl :: RowList Type) (names :: Row Type) | rl -> names
1114+instance CollectVariantSchemaNames Nil ()
1117+ ( ToResponse recordType headers body
1118+ , CollectSchemaNames body bodyNames
1119+ , CollectVariantSchemaNames tail tailNames
1120+ , Row.Union bodyNames tailNames names
1122+ CollectVariantSchemaNames (Cons label recordType tail) names
1124+-- | Collects schema names from a route's request and response types
1125+class CollectRouteSchemaNames (route :: Type) (names :: Row Type) | route -> names
1127+-- | Helper for collecting schema names from a record of routes
1128+class CollectRouteSchemaNameRL (rl :: RowList Type) (names :: Row Type) | rl -> names
1130+instance CollectRouteSchemaNameRL Nil ()
1133+ ( CollectRouteSchemaNames routeType routeNames
1134+ , CollectRouteSchemaNameRL tail tailNames
1135+ , Row.Union routeNames tailNames names
1137+ CollectRouteSchemaNameRL (Cons label routeType tail) names
1140+instance (RowToList row rl, CollectRouteSchemaNameRL rl names) => CollectRouteSchemaNames (Record row) names
1142+-- | Walks a RowList and checks each entry against the full row.
1143+-- | If the RowList has duplicate labels from Union, Cons will unify their types.
1144+-- | Same name + same type: Cons succeeds. Same name + different type: Cons fails.
1145+class ValidateNoDuplicatesRL (rl :: RowList Type) (full :: Row Type)
1147+instance ValidateNoDuplicatesRL Nil full
1150+ ( Row.Cons name ty _rest full
1151+ , ValidateNoDuplicatesRL tail full
1153+ ValidateNoDuplicatesRL (Cons name ty tail) full
1155+-- | Validates that all Schema wrappers in a route collection have unique names.
1156+-- | Same name with same type is allowed (deduplication).
1157+-- | Same name with different types is a compile error.
1158+class ValidateSchemaNames (routes :: Type)
1161+ ( CollectRouteSchemaNames routes names
1162+ , RowToList names rl
1163+ , ValidateNoDuplicatesRL rl names
1165+ ValidateSchemaNames routes
866--------------------------------------------------------------------------------
1167--------------------------------------------------------------------------------
867-- CollectOperations: Walk a type-level structure of routes
1168-- CollectOperations: Walk a type-level structure of routes
868--------------------------------------------------------------------------------
1169--------------------------------------------------------------------------------
@@ -972,6 +1273,8 @@ type ServerObject =
972buildOpenAPISpec
1273buildOpenAPISpec
973 :: forall @routes
1274 :: forall @routes
974 . CollectOperations routes
1275 . CollectOperations routes
1276+ => CollectRouteSchemas routes
1277+ => ValidateSchemaNames routes
975 => { title :: String, version :: String }
1278 => { title :: String, version :: String }
976 -> OpenAPISpec
1279 -> OpenAPISpec
977buildOpenAPISpec info = buildOpenAPISpec' @routes info { servers: Nothing }
1280buildOpenAPISpec info = buildOpenAPISpec' @routes info { servers: Nothing }
@@ -980,6 +1283,8 @@ buildOpenAPISpec info = buildOpenAPISpec' @routes info { servers: Nothing }
980buildOpenAPISpec'
1283buildOpenAPISpec'
981 :: forall @routes
1284 :: forall @routes
982 . CollectOperations routes
1285 . CollectOperations routes
1286+ => CollectRouteSchemas routes
1287+ => ValidateSchemaNames routes
983 => { title :: String, version :: String }
1288 => { title :: String, version :: String }
984 -> { servers :: Maybe (Array ServerObject) }
1289 -> { servers :: Maybe (Array ServerObject) }
985 -> OpenAPISpec
1290 -> OpenAPISpec
@@ -988,9 +1293,15 @@ buildOpenAPISpec' info config =
988 ops = collectOperations (Proxy :: Proxy routes)
1293 ops = collectOperations (Proxy :: Proxy routes)
989 paths = groupByPath ops
1294 paths = groupByPath ops
990 securitySchemes = buildSecuritySchemes ops
1295 securitySchemes = buildSecuritySchemes ops
1296+ schemas = collectRouteSchemas (Proxy :: Proxy routes)
1298+ -- Build components object with both schemas and securitySchemes
991 components =
1299 components =
992− if FObject.isEmpty securitySchemes then Nothing
1300+ if FObject.isEmpty schemas && FObject.isEmpty securitySchemes then Nothing
993− else Just { securitySchemes }
1301+ else Just $ unsafeCoerce $ FObject.fromFoldable $
1302+ (if FObject.isEmpty schemas then [] else [ Tuple "schemas" (unsafeCoerce schemas) ])
1303+ <> (if FObject.isEmpty securitySchemes then [] else [ Tuple "securitySchemes" (unsafeCoerce securitySchemes) ])
994 baseSpec = FObject.fromFoldable
1305 baseSpec = FObject.fromFoldable
995 [ Tuple "openapi" (unsafeCoerce "3.0.0")
1306 [ Tuple "openapi" (unsafeCoerce "3.0.0")
996 , Tuple "info" (unsafeCoerce { title: info.title, version: info.version })
1307 , Tuple "info" (unsafeCoerce { title: info.title, version: info.version })
@@ -998,7 +1309,7 @@ buildOpenAPISpec' info config =
999 withComponents = case components of
1310 withComponents = case components of
1000 Nothing -> baseSpec
1311 Nothing -> baseSpec
1001− Just c -> FObject.insert "components" (unsafeCoerce c) baseSpec
1312+ Just c -> FObject.insert "components" c baseSpec
1002 withServers = case config.servers of
1313 withServers = case config.servers of
1003 Nothing -> withComponents
1314 Nothing -> withComponents
1004 Just servers -> FObject.insert "servers" (writeImpl servers) withComponents
1315 Just servers -> FObject.insert "servers" (writeImpl servers) withComponents