Make schema-profunctor schema names derived and avoid name clashes between scopes.

changelog.d/4-docs/swagger-hacking

@@ -0,0 +1 @@
+Make schema-profunctor schema names derived and avoid name clashes between scopes.

hack/bin/generate-clients.sh

@@ -0,0 +1,53 @@
+#!/usr/bin/env bash
+set -euo pipefail
+
+# Simple OpenAPI client generator using openapi-generator
+# Usage: ./generate-clients.sh <swagger-url>
+
+SWAGGER_URL="${1:-https://staging-nginz-https.zinfra.io/v16/api/swagger.json}"
+OUTPUT_DIR="$(pwd)/generated"
+
+echo "==> Generating clients from: $SWAGGER_URL"
+echo "==> Output directory: $OUTPUT_DIR"
+
+# Clean up previous runs
+rm -rf "$OUTPUT_DIR"
+mkdir -p "$OUTPUT_DIR"
+
+# Download the spec
+echo "==> Downloading OpenAPI spec..."
+curl -s "$SWAGGER_URL" > "$OUTPUT_DIR/swagger.json"
+
+# Check if docker is available
+if ! command -v docker &> /dev/null; then
+    echo "Error: docker is not installed. Please install docker to use openapi-generator." >&2
+    echo "Alternative: install openapi-generator-cli via npm: npm install -g @openapitools/openapi-generator-cli"
+    exit 1
+fi
+
+# Generate TypeScript client
+echo ""
+echo "==> Generating TypeScript client..."
+docker run --rm \
+    -v "$OUTPUT_DIR:/local" \
+    openapitools/openapi-generator-cli:latest generate \
+    -i /local/swagger.json \
+    -g typescript-axios \
+    -o /local/typescript \
+    --additional-properties=supportsES6=true,npmName=wire-api-client,npmVersion=1.0.0
+
+# Generate Kotlin client
+echo ""
+echo "==> Generating Kotlin client..."
+docker run --rm \
+    -v "$OUTPUT_DIR:/local" \
+    openapitools/openapi-generator-cli:latest generate \
+    -i /local/swagger.json \
+    -g kotlin \
+    -o /local/kotlin \
+    --additional-properties=packageName=com.wire.api.client,serializationLibrary=gson
+
+echo ""
+echo "==> Done! Generated clients:"
+echo "  TypeScript: $OUTPUT_DIR/typescript"
+echo "  Kotlin:     $OUTPUT_DIR/kotlin"

libs/saml2-web-sso/src/SAML2/WebSSO/Config.hs

@@ -88,7 +88,7 @@ data ConfigRaw = ConfigRaw
 
 instance ToSchema ConfigRaw where
   schema =
-    object "ConfigRaw" $
+    object $
       ConfigRaw
         <$> (_cfgRawLogLevel .= field "logLevel" schema)
         <*> (_cfgRawSPHost .= field "spHost" schema)
@@ -100,7 +100,7 @@ instance ToSchema ConfigRaw where
 
 instance ToSchema MultiIngressDomainConfig where
   schema =
-    object "MultiIngressDomainConfig" $
+    object $
       MultiIngressDomainConfig
         <$> (_cfgSPAppURI .= field "spAppUri" schema)
         <*> (_cfgSPSsoURI .= field "spSsoUri" schema)

libs/saml2-web-sso/src/SAML2/WebSSO/Orphans.hs

@@ -66,7 +66,7 @@ instance ToSchema URI where
           $ (parseURI strictURIParserOptions . Text.encodeUtf8) uriText
 
 instance ToSchema Level where
-  schema = assert exhaustive $ enum @Text "Level" $ mconcat $ el <$> [minBound ..]
+  schema = assert exhaustive $ enum @Text $ mconcat $ el <$> [minBound ..]
     where
       el l = element (Text.pack (show l)) l
 

libs/saml2-web-sso/src/SAML2/WebSSO/Types.hs

@@ -166,6 +166,7 @@ import Data.Aeson
 import Data.Aeson.TH
 import Data.Bifunctor (first)
 import Data.CaseInsensitive qualified as CI
+import Data.Data (Typeable)
 import Data.List qualified as L
 import Data.List.NonEmpty (NonEmpty ((:|)))
 import Data.List.NonEmpty qualified as NL
@@ -271,7 +272,7 @@ data ContactPerson = ContactPerson
 -- (We may want to replace old template-haskell'ed ToJSON and FromJSON instances in hsaml2, but how?)
 instance Schema.ToSchema ContactPerson where
   schema =
-    Schema.object "ContactPerson" $
+    Schema.object $
       ContactPerson
         <$> (_cntType Schema..= Schema.field "type" Schema.schema)
         <*> (_cntCompany Schema..= Schema.maybe_ (Schema.optField "company" Schema.schema))
@@ -291,7 +292,7 @@ data ContactType
 -- (We may want to replace old template-haskell'ed ToJSON and FromJSON instances in hsaml2, but how?)
 instance Schema.ToSchema ContactType where
   schema =
-    Schema.enum @ST.Text "ContactType" $
+    Schema.enum @ST.Text $
       mconcat
         [ Schema.element "ContactTechnical" ContactTechnical,
           Schema.element "ContactSupport" ContactSupport,
@@ -312,7 +313,7 @@ data IdPMetadata = IdPMetadata
 
 instance Schema.ToSchema IdPMetadata where
   schema =
-    Schema.object "IdPMetadata" $
+    Schema.object $
       IdPMetadata
         <$> (_edIssuer Schema..= Schema.field "issuer" Schema.schema)
         <*> (_edRequestURI Schema..= Schema.field "requestURI" Schema.schema)
@@ -346,9 +347,9 @@ data IdPConfig extra = IdPConfig
   deriving (Eq, Show, Generic)
   deriving (FromJSON, ToJSON, S.ToSchema) via (Schema.Schema (IdPConfig extra))
 
-instance (Schema.ToSchema extra) => Schema.ToSchema (IdPConfig extra) where
+instance (Typeable (IdPConfig extra), Schema.ToSchema extra) => Schema.ToSchema (IdPConfig extra) where
   schema =
-    Schema.object "IdPConfig" $
+    Schema.object $
       IdPConfig
         <$> (_idpId Schema..= Schema.field "id" Schema.schema)
         <*> (_idpMetadata Schema..= Schema.field "metadata" Schema.schema)

libs/schema-profunctor/schema-profunctor.cabal

@@ -73,6 +73,7 @@ library
     , profunctors
     , text
     , transformers
+    , uuid
     , vector
 
   default-language:   GHC2021
@@ -83,6 +84,7 @@ test-suite schemas-tests
   other-modules:
     Paths_schema_profunctor
     Test.Data.Schema
+    Test.Data.Schema.Names
 
   hs-source-dirs:     test/unit
   default-extensions:

libs/schema-profunctor/src/Data/Schema.hs

@@ -50,8 +50,13 @@ module Data.Schema
     declareSwaggerSchema,
     getName,
     object,
+    namedObject,
     objectWithDocModifier,
+    namedObjectWithDocModifier,
     objectOver,
+    namedObjectOver,
+    mkSchemaName,
+    mkSchemaNameWith,
     jsonObject,
     jsonValue,
     field,
@@ -67,6 +72,7 @@ module Data.Schema
     map_,
     mapWithKeys,
     enum,
+    namedEnum,
     maybe_,
     maybeWithDefault,
     bind,
@@ -104,13 +110,19 @@ import Data.Monoid hiding (Product)
 import Data.OpenApi qualified as S
 import Data.OpenApi.Declare qualified as S
 import Data.Profunctor (Star (..))
-import Data.Proxy (Proxy (..))
 import Data.Set qualified as Set
 import Data.Text qualified as T
 import Data.Text.Lazy qualified as TL
+import Data.Typeable (Proxy (..), typeRep)
+import Data.UUID qualified as UUID
+import Data.UUID.V4 qualified as UUID
 import Data.Vector qualified as V
+import Debug.Trace
 import Imports hiding (Product)
 import Numeric.Natural
+import System.IO.Unsafe
+import Type.Reflection (SomeTypeRep (..), tyConModule, tyConName)
+import Type.Reflection qualified as TR
 
 type Declare = S.Declare (S.Definitions S.Schema)
 
@@ -401,38 +413,138 @@ tag f = rmap runIdentity . f . rmap Identity
 --
 -- This can be used to convert a combination of schemas obtained using
 -- 'field' into a single schema for a JSON object.
+-- Uses the Typeable instance to automatically generate the schema name.
 object ::
+  forall doc doc' a b.
+  (Typeable a, HasObject doc doc') =>
+  SchemaP doc A.Object [A.Pair] a b ->
+  SchemaP doc' A.Value A.Value a b
+object = namedObject (mkSchemaName @a)
+
+-- | Version of 'object' that takes an explicit name.
+namedObject ::
   (HasObject doc doc') =>
   Text ->
   SchemaP doc A.Object [A.Pair] a b ->
   SchemaP doc' A.Value A.Value a b
-object = objectOver id
+namedObject name = namedObjectOver id name
 
 -- | A version of 'object' for more general input values.
+-- Uses the Typeable instance to automatically generate the schema name.
 --
 -- Just like 'fieldOver', but for 'object'.
 objectOver ::
+  forall doc doc' v' a b v.
+  (Typeable a, HasObject doc doc') =>
+  Lens v v' A.Value A.Object ->
+  SchemaP doc v' [A.Pair] a b ->
+  SchemaP doc' v A.Value a b
+objectOver l = namedObjectOver l (mkSchemaName @a)
+
+-- | Version of 'objectOver' that takes an explicit name.
+namedObjectOver ::
   (HasObject doc doc') =>
   Lens v v' A.Value A.Object ->
   Text ->
   SchemaP doc v' [A.Pair] a b ->
   SchemaP doc' v A.Value a b
-objectOver l name sch = SchemaP (SchemaDoc s) (SchemaIn r) (SchemaOut w)
+namedObjectOver l name sch = SchemaP (SchemaDoc s) (SchemaIn r) (SchemaOut w)
   where
     parseObject val = ContT $ \k -> A.withObject (T.unpack name) k val
     r v = runContT (l parseObject v) (schemaIn sch)
     w x = A.object <$> schemaOut sch x
     s = mkObject name (schemaDoc sch)
 
+-- | Object and enum schema names by default are the fully qualified
+-- name of the haskell type, including type parameters.  If that's not
+-- unique, we should probably change those type names.  This will avoid
+-- collisions in the hash table keeping track of all the schema references
+-- in the openapi3 package.
+--
+-- See test suite for examples.
+mkSchemaName :: forall a. (Typeable a) => Text
+mkSchemaName = traceShow ("***************** " :: String, (mkSchemaNameInternal @a), result) $ result
+  where
+    result = T.pack $ sanitizeSchemaName $ UUID.toString $ unsafePerformIO UUID.nextRandom
+
+{-
+
+# Two problems:
+
+## internal galley and public api
+
+without commit [stash] (this commit), these two (not others) get this error:
+
+Unable to process spec '/tmp/swagger665666/swagger.json': unable to parse specification: yaml: did not find expected ',' or '}'
+
+it's completely unclear where this is coming from.  vacuum bug?
+
+## public api
+
+(with this stash)
+
+curl -X 'GET' 'http://127.0.0.1:8082/v16/api/swagger.json' -H 'Z-Connection: conn' -H 'Z-User: example.com' | jq . > swagger3.json && vacuum lint -a -d -e swagger3.json
+[...]
+swagger3.json:21258:32  ✗ error    component `#/components/schemas/6f9654bc-22a0-44f9-84e7-787c49115a98` does not exist in the specification                      resolving-references        Schemas       $.components.schemas['6f9654bc-22a0-44f9-84e7-787c49115a98']
+
+[brig@example.com] ("***************** ","Qualified (Id IdTag 'User) (Data.Qualified.Qualified Data.Id.Id Data.Id.'User)","6f9654bc-22a0-44f9-84e7-787c49115a98")
+
+so it looks like this one data type does not make it into the openapi3 hashtable of schema declarations.  what's different about it?
+
+-}
+
+mkSchemaNameWith :: forall a. (Typeable a) => Text -> Text
+mkSchemaNameWith extra = T.pack $ sanitizeSchemaName $ T.unpack extra <> " " <> (mkSchemaNameInternal @a)
+
+-- | Vacuum's yaml parser chokes on '/', ':' etc in schema names.
+-- Let's indulge it, and use a conservative positive filter.
+sanitizeSchemaName :: String -> String
+sanitizeSchemaName =
+  mconcat
+    . map
+      ( \c ->
+          if c `elem` (['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] ++ " _-,.!?:()[]@$^&*" :: [Char])
+            then [c]
+            else "_" ++ show (ord c) ++ "_"
+      )
+
+mkSchemaNameInternal :: forall a. (Typeable a) => String
+mkSchemaNameInternal = humanReadable ++ " (" <> unique ++ ")"
+  where
+    humanReadable = show $ typeRep (Proxy @a)
+    unique = renderTypeRep (TR.typeRep @a)
+
+    renderTypeRep :: forall t. TR.TypeRep t -> String
+    renderTypeRep tr =
+      case TR.splitApps tr of
+        (tyCon, []) ->
+          -- Simple type with no arguments
+          tyConModule tyCon <> "." <> tyConName tyCon
+        (tyCon, args) ->
+          -- Type constructor applied to arguments
+          let conName = tyConModule tyCon <> "." <> tyConName tyCon
+              argNames = map (\(SomeTypeRep arg) -> renderTypeRep arg) args
+           in conName <> " " <> intercalate " " argNames
+
 -- | Like 'object', but apply an arbitrary function to the
 -- documentation of the resulting object.
+-- Uses the Typeable instance to automatically generate the schema name.
 objectWithDocModifier ::
+  forall doc doc' a.
+  (Typeable a, HasObject doc doc') =>
+  (doc' -> doc') ->
+  ObjectSchema doc a ->
+  ValueSchema doc' a
+objectWithDocModifier = namedObjectWithDocModifier (mkSchemaName @a)
+
+-- | Version of 'objectWithDocModifier' that takes an explicit name.
+namedObjectWithDocModifier ::
   (HasObject doc doc') =>
   Text ->
   (doc' -> doc') ->
   ObjectSchema doc a ->
   ValueSchema doc' a
-objectWithDocModifier name modify sch = over doc modify (object name sch)
+namedObjectWithDocModifier name modify sch = over doc modify (namedObject name sch)
 
 -- | Turn a named schema into an unnamed one.
 --
@@ -557,13 +669,23 @@ element label value = SchemaP (SchemaDoc d) (SchemaIn i) (SchemaOut o)
 --
 -- This is used to convert a combination of schemas obtained using
 -- 'element' into a single schema for a JSON string.
+-- | A schema for an enumeration.
+-- Uses the Typeable instance to automatically generate the schema name.
 enum ::
+  forall v doc a b.
+  (Typeable a, With v, HasEnum v doc) =>
+  SchemaP [A.Value] v (Alt Maybe v) a b ->
+  SchemaP doc A.Value A.Value a b
+enum = namedEnum (mkSchemaName @a)
+
+-- | Version of 'enum' that takes an explicit name.
+namedEnum ::
   forall v doc a b.
   (With v, HasEnum v doc) =>
   Text ->
   SchemaP [A.Value] v (Alt Maybe v) a b ->
   SchemaP doc A.Value A.Value a b
-enum name sch = SchemaP (SchemaDoc d) (SchemaIn i) (SchemaOut o)
+namedEnum name sch = SchemaP (SchemaDoc d) (SchemaIn i) (SchemaOut o)
   where
     d = mkEnum @v name (schemaDoc sch)
     i x =
@@ -653,7 +775,7 @@ parsedTextWithDoc desc name parser = appendDescr (text name) `withParser` (eithe
 -- | A schema for an arbitrary JSON object.
 jsonObject :: ValueSchema SwaggerDoc A.Object
 jsonObject =
-  unnamed . object "Object" $
+  unnamed . object $
     mkSchema (pure (mempty & S.type_ ?~ S.OpenApiObject)) pure (pure . (^.. ifolded . withIndex))
 
 -- | A schema for an arbitrary JSON value.