Document supported custom OpenAPI routes

Guide/routing.markdown

@@ -36,9 +36,9 @@ instance FrontController WebApplication where
         ]
 ```
 
-`documentRoute` still derives the path, methods and query parameters from `AutoRoute`. Response schemas, request bodies and operation metadata come from the `endpoint` definitions next to the controller handlers.
+`documentRoute` derives paths, methods and parameters from `AutoRoute`. Response schemas, request bodies and operation metadata come from the `endpoint` definitions next to the controller handlers.
 
-Use `documentRoute` only for controllers whose routing is fully described by `AutoRoute`. Controllers that override `customRoutes` or `customPathTo`, or controllers mounted through the lower-level parser APIs, continue to work normally at runtime but are omitted from the generated OpenAPI document on purpose.
+Simple `customRoutes` / `customPathTo` overrides are supported when `customPathTo` returns a path backed by `customRoutes` and all action fields appear in the path. If IHP cannot prove this during OpenAPI generation, `buildOpenApi` fails with an `OpenApiGenerationException` instead of silently generating stale docs. Lower-level parser routes stay undocumented.
 
 You can then build the OpenAPI document from the mounted router tree:
 
@@ -262,7 +262,7 @@ With this setup:
 
 The `customRoutes` parser is tried first, before the auto-generated routes. If it doesn't match, the auto-generated routes are tried as usual. Return `Nothing` from `customPathTo` for any action that should use the default URL generation.
 
-Controllers that use `customRoutes` / `customPathTo` keep working normally at runtime, but they are intentionally omitted from IHP's OpenAPI generation. OpenAPI v1 only documents pure `AutoRoute` controllers so the generated spec cannot diverge from the real routing behavior. If you want OpenAPI output for a controller, keep its routing purely `AutoRoute` and mount it with `documentRoute`.
+When mounted with `documentRoute`, this basic custom route is included in the OpenAPI document as `/posts/{postId}`. IHP verifies that the generated `customPathTo` path is accepted by `customRoutes`; unsupported custom paths fail OpenAPI generation with a clear error.
 
 ## Custom Routing
 

ihp/IHP/OpenApiSupport.hs

@@ -29,7 +29,7 @@ import Control.Monad.State.Strict qualified as State
 import Data.Aeson qualified as JSON
 import Data.Aeson.Key qualified as JSON.Key
 import Data.Aeson.KeyMap qualified as JSON.KeyMap
-import Data.Attoparsec.ByteString.Char8 (string)
+import Data.Attoparsec.ByteString.Char8 (endOfInput, parseOnly, string)
 import Data.ByteString.Char8 qualified as ByteString
 import Data.ByteString.Lazy qualified as LazyByteString
 import Data.Data
@@ -41,14 +41,15 @@ import Data.Text qualified as Text
 import Data.Text.Encoding qualified as Text
 import Data.Typeable qualified as Typeable
 import Data.UUID (nil)
+import Data.UUID qualified as UUID
 import IHP.ModelSupport
 import IHP.OpenApiSupport.ActionDoc
 import IHP.Prelude
 import IHP.Router.Types (UnexpectedMethodException (..))
 import IHP.RouterSupport
 import IHP.ViewSupport (JsonResponse)
 import Network.HTTP.Types.Header (hContentType)
-import Network.HTTP.Types.Method (StdMethod (..), parseMethod)
+import Network.HTTP.Types.Method (StdMethod (..), parseMethod, renderStdMethod)
 import Network.HTTP.Types.Status (status200)
 import Network.Wai (Request, Response, defaultRequest, requestMethod, responseBuilder, responseLBS)
 import Text.Blaze.Html.Renderer.Utf8 qualified as Blaze
@@ -293,19 +294,20 @@ insertActionOperation ::
 insertActionOperation currentPrefix pathState doc@ActionDoc{actionDocName} = do
     OpenApiDocument{pathOperations, componentSchemas} <- pathState
     constructor <- findControllerConstructor @controller actionDocName
-    hasCustomPath <- actionUsesCustomPath @controller constructor
-    if hasCustomPath
-        then pure OpenApiDocument{pathOperations, componentSchemas}
-        else do
-            let actionPath = appendPathPrefix currentPrefix (actionPrefixText @controller <> stripActionSuffixText actionDocName)
-            parameters <- deriveActionParameters @controller constructor
-            let (operation, operationSchemas) = actionDocOperationValue doc parameters
-            let methods = allowedMethodsForAction @controller (Text.encodeUtf8 actionDocName)
-            pure
-                OpenApiDocument
-                    { pathOperations = foldl' (insertMethod actionPath operation) pathOperations methods
-                    , componentSchemas = componentSchemas <> operationSchemas
-                    }
+    (actionPath, parameters) <-
+        deriveCustomPathDocumentation @controller currentPrefix constructor
+            >>= \case
+                Just customPathDocumentation -> pure customPathDocumentation
+                Nothing -> do
+                    parameters <- deriveActionParameters @controller constructor
+                    pure (appendPathPrefix currentPrefix (actionPrefixText @controller <> stripActionSuffixText actionDocName), parameters)
+    let (operation, operationSchemas) = actionDocOperationValue doc parameters
+    let methods = allowedMethodsForAction @controller (Text.encodeUtf8 actionDocName)
+    pure
+        OpenApiDocument
+            { pathOperations = foldl' (insertMethod actionPath operation) pathOperations methods
+            , componentSchemas = componentSchemas <> operationSchemas
+            }
 
 findControllerConstructor :: forall controller. (Data controller) => Text -> Either Text Constr
 findControllerConstructor actionName =
@@ -436,19 +438,24 @@ successResponseValue responseDescription schema =
                 ]
         ]
 
+data ParameterLocation
+    = QueryParameter
+    | PathParameter
+
 data QueryParameterDocumentation = QueryParameterDocumentation
     { parameterName :: Text
+    , parameterLocation :: ParameterLocation
     , parameterRequired :: Bool
     , parameterSchema :: Referenced Schema
     , parameterDefinitions :: Definitions Schema
     , parameterExplode :: Maybe Bool
     }
 
 queryParameterValue :: QueryParameterDocumentation -> JSON.Value
-queryParameterValue QueryParameterDocumentation{parameterName, parameterRequired, parameterSchema, parameterExplode} =
+queryParameterValue QueryParameterDocumentation{parameterName, parameterLocation, parameterRequired, parameterSchema, parameterExplode} =
     JSON.object
         ( [ Just ("name" JSON..= parameterName)
-          , Just ("in" JSON..= ("query" :: Text))
+          , Just ("in" JSON..= parameterLocationValue parameterLocation)
           , Just ("required" JSON..= parameterRequired)
           , Just ("schema" JSON..= parameterSchema)
           , if isJust parameterExplode then Just ("style" JSON..= ("form" :: Text)) else Nothing
@@ -457,6 +464,18 @@ queryParameterValue QueryParameterDocumentation{parameterName, parameterRequired
             |> catMaybes
         )
 
+parameterLocationValue :: ParameterLocation -> Text
+parameterLocationValue QueryParameter = "query"
+parameterLocationValue PathParameter = "path"
+
+toPathParameter :: QueryParameterDocumentation -> QueryParameterDocumentation
+toPathParameter parameter =
+    parameter
+        { parameterLocation = PathParameter
+        , parameterRequired = True
+        , parameterExplode = Nothing
+        }
+
 data SchemaDocumentation = SchemaDocumentation
     { documentedSchema :: Referenced Schema
     , documentedDefinitions :: Definitions Schema
@@ -496,6 +515,7 @@ requiredParameter parameterName =
     let SchemaDocumentation{documentedSchema, documentedDefinitions} = declareSchemaDocumentation (Proxy @a)
      in QueryParameterDocumentation
             { parameterName
+            , parameterLocation = QueryParameter
             , parameterRequired = True
             , parameterSchema = documentedSchema
             , parameterDefinitions = documentedDefinitions
@@ -507,6 +527,7 @@ optionalParameter parameterName =
     let SchemaDocumentation{documentedSchema, documentedDefinitions} = declareSchemaDocumentation (Proxy @a)
      in QueryParameterDocumentation
             { parameterName
+            , parameterLocation = QueryParameter
             , parameterRequired = False
             , parameterSchema = documentedSchema
             , parameterDefinitions = documentedDefinitions
@@ -518,6 +539,7 @@ listParameter parameterName =
     let SchemaDocumentation{documentedSchema, documentedDefinitions} = declareSchemaDocumentation (Proxy @[a])
      in QueryParameterDocumentation
             { parameterName
+            , parameterLocation = QueryParameter
             , parameterRequired = False
             , parameterSchema = documentedSchema
             , parameterDefinitions = documentedDefinitions
@@ -600,8 +622,181 @@ buildDummyAction constructor =
         nextField = State.lift (dummyValueForFieldType @field)
      in fst <$> State.runStateT (fromConstrM nextField constructor :: State.StateT () (Either Text) controller) ()
 
-actionUsesCustomPath :: forall controller. (AutoRoute controller, Data controller) => Constr -> Either Text Bool
-actionUsesCustomPath constructor = isJust . customPathTo <$> buildDummyAction @controller constructor
+data CustomPathFieldMarker = CustomPathFieldMarker
+    { markerFieldName :: Text
+    , markerText :: Text
+    , markerParameter :: QueryParameterDocumentation
+    }
+
+data MarkedAction controller = MarkedAction
+    { markedAction :: controller
+    , markedActionFields :: [CustomPathFieldMarker]
+    }
+
+deriveCustomPathDocumentation :: forall controller. (AutoRoute controller, Data controller) => Text -> Constr -> Either Text (Maybe (Text, [QueryParameterDocumentation]))
+deriveCustomPathDocumentation currentPrefix constructor = do
+    dummyAction <- buildDummyAction @controller constructor
+    case customPathTo dummyAction of
+        Nothing -> pure Nothing
+        Just _ -> do
+            MarkedAction{markedAction, markedActionFields} <- buildMarkedAction @controller constructor
+            customPath <- case customPathTo markedAction of
+                Just path -> pure path
+                Nothing -> Left ("OpenAPI customPathTo returned a path for dummy values but not marker values for action " <> cs (showConstr constructor))
+            validateCustomRouteParser @controller constructor customPath
+            documentCustomPath currentPrefix constructor customPath markedActionFields
+
+buildMarkedAction :: forall controller. (Data controller) => Constr -> Either Text (MarkedAction controller)
+buildMarkedAction constructor =
+    let initialState = (map cs (constrFields constructor), 1, [])
+        nextField :: forall field. (Data field) => State.StateT ([Text], Int, [CustomPathFieldMarker]) (Either Text) field
+        nextField = do
+            (remainingFields, markerIndex, markers) <- State.get
+            case remainingFields of
+                [] -> State.lift (Left ("OpenAPI customPathTo field derivation failed for action " <> cs (showConstr constructor)))
+                (fieldName : restFields) -> do
+                    parameter <- case queryParameterDocumentation @field fieldName of
+                        Just queryParameter -> pure (toPathParameter queryParameter)
+                        Nothing -> State.lift (Left unsupportedTypeMessage)
+                    FieldMarkerValue{fieldMarkerText, fieldMarkerValue} <- State.lift (markerValueForFieldType @field fieldName markerIndex)
+                    State.put
+                        ( restFields
+                        , markerIndex + 1
+                        , markers
+                            <> [ CustomPathFieldMarker
+                                    { markerFieldName = fieldName
+                                    , markerText = fieldMarkerText
+                                    , markerParameter = parameter
+                                    }
+                               ]
+                        )
+                    pure fieldMarkerValue
+                  where
+                    unsupportedTypeMessage =
+                        "OpenAPI customPathTo does not support the field "
+                            <> fieldName
+                            <> " with type "
+                            <> cs (dataTypeName (dataTypeOf (undefined :: field)))
+     in case State.runStateT
+            (fromConstrM nextField constructor :: State.StateT ([Text], Int, [CustomPathFieldMarker]) (Either Text) controller)
+            initialState of
+            Left errorMessage -> Left errorMessage
+            Right (action, ([], _, markers)) -> Right MarkedAction{markedAction = action, markedActionFields = markers}
+            Right (_, (remainingFields, _, _)) ->
+                Left ("OpenAPI customPathTo field derivation did not consume all fields for action " <> cs (showConstr constructor) <> ": " <> cs (show remainingFields) :: Text)
+
+data FieldMarkerValue field = FieldMarkerValue
+    { fieldMarkerText :: Text
+    , fieldMarkerValue :: field
+    }
+
+markerValueForFieldType :: forall field. (Data field) => Text -> Int -> Either Text (FieldMarkerValue field)
+markerValueForFieldType fieldName markerIndex =
+    fromMaybe
+        (Left unsupportedMarkerTypeMessage)
+        (directMarkerValue @field fieldName markerIndex <|> wrappedIdMarkerValue @field fieldName markerIndex)
+  where
+    unsupportedMarkerTypeMessage =
+        "OpenAPI customPathTo marker value is not implemented for type "
+            <> cs (dataTypeName (dataTypeOf (undefined :: field)))
+
+directMarkerValue :: forall field. (Data field) => Text -> Int -> Maybe (Either Text (FieldMarkerValue field))
+directMarkerValue fieldName markerIndex =
+    let textMarker = "__ihp_openapi_" <> fieldName <> "_" <> cs (show markerIndex) <> "__"
+        integerMarker = 900000000 + toInteger markerIndex
+        intMarker :: Int
+        intMarker = fromInteger integerMarker
+        uuidMarkerText = "00000000-0000-0000-0000-" <> Text.justifyRight 12 '0' (cs (show markerIndex))
+        uuidMarker = fromMaybe nil (UUID.fromString (cs uuidMarkerText))
+     in asum
+            [ eqT @field @Text |> fmap (\Refl -> Right FieldMarkerValue{fieldMarkerText = textMarker, fieldMarkerValue = textMarker})
+            , eqT @field @Int |> fmap (\Refl -> Right FieldMarkerValue{fieldMarkerText = cs (show intMarker), fieldMarkerValue = intMarker})
+            , eqT @field @Integer |> fmap (\Refl -> Right FieldMarkerValue{fieldMarkerText = cs (show integerMarker), fieldMarkerValue = integerMarker})
+            , eqT @field @UUID |> fmap (\Refl -> Right FieldMarkerValue{fieldMarkerText = uuidMarkerText, fieldMarkerValue = uuidMarker})
+            , eqT @field @(Maybe Text) |> fmap (\Refl -> Right FieldMarkerValue{fieldMarkerText = textMarker, fieldMarkerValue = Just textMarker})
+            , eqT @field @(Maybe Int) |> fmap (\Refl -> Right FieldMarkerValue{fieldMarkerText = cs (show intMarker), fieldMarkerValue = Just intMarker})
+            , eqT @field @(Maybe Integer) |> fmap (\Refl -> Right FieldMarkerValue{fieldMarkerText = cs (show integerMarker), fieldMarkerValue = Just integerMarker})
+            ]
+
+wrappedIdMarkerValue :: forall field. (Data field) => Text -> Int -> Maybe (Either Text (FieldMarkerValue field))
+wrappedIdMarkerValue fieldName markerIndex
+    | dataTypeName (dataTypeOf (undefined :: field)) /= "IHP.ModelSupport.Types.Id'" = Nothing
+    | otherwise =
+        dataTypeConstrs (dataTypeOf (undefined :: field))
+            |> listToMaybe
+            |> fmap (deriveWrappedIdMarkerValue @field fieldName markerIndex)
+
+deriveWrappedIdMarkerValue :: forall field. (Data field) => Text -> Int -> Constr -> Either Text (FieldMarkerValue field)
+deriveWrappedIdMarkerValue fieldName markerIndex constructor =
+    let nextField :: forall inner. (Data inner) => State.StateT (Maybe Text) (Either Text) inner
+        nextField = do
+            FieldMarkerValue{fieldMarkerText, fieldMarkerValue} <- State.lift (markerValueForFieldType @inner fieldName markerIndex)
+            State.put (Just fieldMarkerText)
+            pure fieldMarkerValue
+     in case State.runStateT (fromConstrM nextField constructor :: State.StateT (Maybe Text) (Either Text) field) Nothing of
+            Right (fieldMarkerValue, Just fieldMarkerText) -> Right FieldMarkerValue{fieldMarkerText, fieldMarkerValue}
+            Right (_, Nothing) -> Left ("OpenAPI customPathTo could not derive the inner primary key marker for " <> fieldName)
+            Left errorMessage -> Left errorMessage
+
+documentCustomPath :: Text -> Constr -> Text -> [CustomPathFieldMarker] -> Either Text (Maybe (Text, [QueryParameterDocumentation]))
+documentCustomPath currentPrefix constructor customPath markers
+    | Text.null customPath = Left ("OpenAPI customPathTo returned an empty path for action " <> actionName)
+    | "?" `Text.isInfixOf` customPath = Left ("OpenAPI customPathTo for action " <> actionName <> " includes a query string. Put all documented route parameters in the path or use AutoRoute.")
+    | otherwise =
+        case filter (\CustomPathFieldMarker{markerText} -> not (markerText `Text.isInfixOf` customPath)) markers of
+            missingMarkers@(_ : _) ->
+                Left
+                    ( "OpenAPI customPathTo for action "
+                        <> actionName
+                        <> " does not include these action fields in the path: "
+                        <> Text.intercalate ", " (map markerFieldName missingMarkers)
+                    )
+            [] ->
+                let openApiPath =
+                        markers
+                            |> foldl'
+                                ( \path CustomPathFieldMarker{markerFieldName, markerText} ->
+                                    Text.replace markerText ("{" <> markerFieldName <> "}") path
+                                )
+                                customPath
+                            |> appendPathPrefix currentPrefix
+                    parameters = map markerParameter markers
+                 in Right (Just (openApiPath, parameters))
+  where
+    actionName = cs (showConstr constructor)
+
+validateCustomRouteParser :: forall controller. (AutoRoute controller, Data controller) => Constr -> Text -> Either Text ()
+validateCustomRouteParser constructor customPath =
+    let actionName = cs (showConstr constructor)
+        method =
+            allowedMethodsForAction @controller (cs actionName)
+                |> listToMaybe
+                |> fromMaybe GET
+        request = defaultRequest{requestMethod = renderStdMethod method}
+        dummyRespond _ = error "validateCustomRouteParser: response callback should never be called"
+        result =
+            let ?request = request
+                ?respond = dummyRespond
+             in parseOnly (customRoutes @controller <* endOfInput) (Text.encodeUtf8 customPath)
+     in case result of
+            Right action
+                | toConstr action == constructor -> Right ()
+                | otherwise ->
+                    Left
+                        ( "OpenAPI customPathTo for action "
+                            <> actionName
+                            <> " is parsed by customRoutes as "
+                            <> cs (showConstr (toConstr action))
+                        )
+            Left parseError ->
+                Left
+                    ( "OpenAPI customPathTo for action "
+                        <> actionName
+                        <> " returned "
+                        <> customPath
+                        <> ", but customRoutes does not parse that path: "
+                        <> cs parseError
+                    )
 
 deriveActionParameters :: forall controller. (Data controller) => Constr -> Either Text [QueryParameterDocumentation]
 deriveActionParameters constr =