NorfairKing/autodocodec
1
1
Fork 0
mirror of https://github.com/NorfairKing/autodocodec.git synced 2024-09-11 14:36:05 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #26 from NorfairKing/servant-multipart-bug

Browse Source 
Servant multipart bug
This commit is contained in:
Tom Sydney Kerckhove 2022-10-06 08:42:38 +02:00 committed by GitHub
commit 122ff64058
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
16 changed files with 353 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
autodocodec-api-usage/autodocodec-api-usage.cabal
View File

@ -55,6 +55,7 @@ extra-source-files:
test_resources/json-schema/legacy-object.json
test_resources/json-schema/legacy-value.json
test_resources/json-schema/list-text.json
test_resources/json-schema/lists-example.json
test_resources/json-schema/local-time.json
test_resources/json-schema/map-text-ind.json
test_resources/json-schema/maybe-text.json
@ -91,6 +92,7 @@ extra-source-files:
test_resources/openapi-schema/declareSchemaRef/fruit.json
test_resources/openapi-schema/declareSchemaRef/legacy-object.json
test_resources/openapi-schema/declareSchemaRef/legacy-value.json
test_resources/openapi-schema/declareSchemaRef/lists-example.json
test_resources/openapi-schema/declareSchemaRef/mutually-recursive.json
test_resources/openapi-schema/declareSchemaRef/null.json
test_resources/openapi-schema/declareSchemaRef/recursive.json
@ -113,6 +115,7 @@ extra-source-files:
test_resources/openapi-schema/legacy-object.json
test_resources/openapi-schema/legacy-value.json
test_resources/openapi-schema/list-text.json
test_resources/openapi-schema/lists-example.json
test_resources/openapi-schema/local-time.json
test_resources/openapi-schema/map-text-int.json
test_resources/openapi-schema/maybe-text.json
@ -157,6 +160,7 @@ extra-source-files:
test_resources/show-codec/legacy-object.txt
test_resources/show-codec/legacy-value.txt
test_resources/show-codec/list-text.txt
test_resources/show-codec/lists-example.txt
test_resources/show-codec/local-time.txt
test_resources/show-codec/map-text-int.txt
test_resources/show-codec/maybe-text.txt
@ -202,6 +206,7 @@ extra-source-files:
test_resources/swagger-schema/legacy-object.json
test_resources/swagger-schema/legacy-value.json
test_resources/swagger-schema/list-text.json
test_resources/swagger-schema/lists-example.json
test_resources/swagger-schema/local-time.json
test_resources/swagger-schema/map-text-int.json
test_resources/swagger-schema/maybe-text.json
@ -247,6 +252,7 @@ extra-source-files:
test_resources/yaml-schema/legacy-object.txt
test_resources/yaml-schema/legacy-value.txt
test_resources/yaml-schema/list-text.txt
test_resources/yaml-schema/lists-example.txt
test_resources/yaml-schema/local-time.txt
test_resources/yaml-schema/map-text-int.txt
test_resources/yaml-schema/maybe-text.txt

52
autodocodec-api-usage/src/Autodocodec/Usage.hs
View File

@ -28,6 +28,7 @@ import Data.GenValidity.Aeson ()
import Data.GenValidity.Scientific ()
import Data.GenValidity.Text ()
import qualified Data.HashMap.Strict as HashMap
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe
import Data.OpenApi (ToSchema)
import qualified Data.OpenApi as OpenAPI
@ -216,6 +217,57 @@ instance ToMultipart tag Example where
)
[]
data ListsExample = ListsExample
{ listsExamplePossiblyEmptyWithOmittedDefault :: [Int],
listsExamplePossiblyEmptyWithDefault :: [Int],
listsExampleRequiredNonEmpty :: NonEmpty Text,
listsExampleOptionalNonEmpty :: Maybe (NonEmpty Text)
}
deriving (Show, Eq, Generic)
deriving
( OpenAPI.ToSchema,
Swagger.ToSchema,
Servant.FromMultipart tag,
Servant.ToMultipart tag
)
via Autodocodec ListsExample
instance Validity ListsExample
instance NFData ListsExample
instance GenValid ListsExample
instance ToJSON ListsExample where
toJSON ListsExample {..} =
JSON.object $
concat
[ ["possibly-empty-with-omitted-default" JSON..= listsExamplePossiblyEmptyWithOmittedDefault | listsExamplePossiblyEmptyWithOmittedDefault /= []],
[ "possibly-empty-with-default" JSON..= listsExamplePossiblyEmptyWithDefault,
"required-non-empty" JSON..= listsExampleRequiredNonEmpty
],
["optional-non-empty" JSON..= ne | ne <- maybeToList listsExampleOptionalNonEmpty]
]
instance FromJSON ListsExample where
parseJSON = JSON.withObject "ListsExample" $ \o ->
ListsExample
<$> o JSON..:? "possibly-empty-with-omitted-default" JSON..!= []
<*> o JSON..:? "possibly-empty-with-default" JSON..!= []
<*> o JSON..: "required-non-empty"
<*> o JSON..:? "optional-non-empty"
instance HasCodec ListsExample where
codec = object "ListsExample" objectCodec
instance HasObjectCodec ListsExample where
objectCodec =
ListsExample
<$> optionalFieldWithOmittedDefault "possibly-empty-with-omitted-default" [] "possibly empty list with omitted default empty list" .= listsExamplePossiblyEmptyWithOmittedDefault
<*> optionalFieldWithDefault "possibly-empty-with-default" [] "possibly empty list with default empty list" .= listsExamplePossiblyEmptyWithDefault
<*> requiredField "required-non-empty" "required non-empty list" .= listsExampleRequiredNonEmpty
<*> optionalField "optional-non-empty" "optional non-empty list" .= listsExampleOptionalNonEmpty
-- | A simple Recursive type
--
-- We use this example to make sure that:

1
autodocodec-api-usage/test/Autodocodec/Aeson/SchemaSpec.hs
View File

@ -71,6 +71,7 @@ spec = do
jsonSchemaSpec @Fruit "fruit"
jsonSchemaSpec @Example "example"
jsonSchemaSpec @Recursive "recursive"
jsonSchemaSpec @ListsExample "lists-example"
jsonSchemaSpec @MutuallyRecursiveA "mutually-recursive"
jsonSchemaSpec @Via "via"
jsonSchemaSpec @VeryComment "very-comment"

1
autodocodec-api-usage/test/Autodocodec/AesonSpec.hs
View File

@ -87,6 +87,7 @@ spec = do
aesonCodecErrorSpec @Example "example-error-bool-number" "{\"text\": \"hello\", \"bool\": 5}"
aesonCodecErrorSpec @Example "example-error-fruit-number" "{\"text\": \"hello\", \"bool\": true, \"maybe\": null, \"fruit\": 5}"
aesonCodecSpec @Recursive
aesonCodecSpec @ListsExample
aesonCodecErrorSpec @Recursive "recursive-error-recurse-string" "{\"recurse\": {\"recurse\": {\"recurse\": \"hello\"}}}"
aesonCodecSpec @MutuallyRecursiveA
aesonCodecSpec @Via

1
autodocodec-api-usage/test/Autodocodec/MultipartSpec.hs
View File

@ -39,6 +39,7 @@ spec = do
multipartCodecSpec @LegacyObject
multipartCodecSpec @These
multipartCodecSpec @Expression
multipartCodecSpec @ListsExample
multipartCodecSpec ::
forall a.

2
autodocodec-api-usage/test/Autodocodec/OpenAPISpec.hs
View File

@ -78,6 +78,8 @@ spec = do
openAPISchemaSpecViaDeclareSchemaRef @Fruit "fruit"
openAPISchemaSpec @Example "example"
openAPISchemaSpecViaDeclareSchemaRef @Example "example"
openAPISchemaSpec @ListsExample "lists-example"
openAPISchemaSpecViaDeclareSchemaRef @ListsExample "lists-example"
openAPISchemaSpec @Recursive "recursive"
openAPISchemaSpecViaDeclareSchemaRef @Recursive "recursive"
openAPISchemaSpec @MutuallyRecursiveA "mutually-recursive"

1
autodocodec-api-usage/test/Autodocodec/ShowSpec.hs
View File

@ -59,6 +59,7 @@ spec = do
showCodecSpec @Fruit "fruit"
showCodecSpec @Example "example"
showCodecSpec @Recursive "recursive"
showCodecSpec @ListsExample "lists-example"
showCodecSpec @MutuallyRecursiveA "mutually-recursive"
showCodecSpec @Via "via"
showCodecSpec @VeryComment "very-comment"

1
autodocodec-api-usage/test/Autodocodec/SwaggerSpec.hs
View File

@ -76,6 +76,7 @@ spec = do
swaggerSchemaSpec @Fruit "fruit"
swaggerSchemaSpec @Example "example"
swaggerSchemaSpec @Recursive "recursive"
swaggerSchemaSpec @ListsExample "lists-example"
swaggerSchemaSpec @MutuallyRecursiveA "mutually-recursive"
swaggerSchemaSpec @Via "via"
swaggerSchemaSpec @VeryComment "very-comment"

1
autodocodec-api-usage/test/Autodocodec/Yaml/SchemaSpec.hs
View File

@ -62,6 +62,7 @@ spec = do
yamlSchemaSpec @Fruit "fruit"
yamlSchemaSpec @Example "example"
yamlSchemaSpec @Recursive "recursive"
yamlSchemaSpec @ListsExample "lists-example"
yamlSchemaSpec @MutuallyRecursiveA "mutually-recursive"
yamlSchemaSpec @Via "via"
yamlSchemaSpec @VeryComment "very-comment"

41
autodocodec-api-usage/test_resources/json-schema/lists-example.json Normal file
View File

@ -0,0 +1,41 @@
{
"$comment": "ListsExample",
"properties": {
"optional-non-empty": {
"$comment": "optional non-empty list",
"items": {
"type": "string"
},
"type": "array"
},
"possibly-empty-with-default": {
"$comment": "possibly empty list with default empty list",
"items": {
"maximum": 9223372036854775807,
"minimum": -9223372036854775808,
"type": "number"
},
"type": "array"
},
"possibly-empty-with-omitted-default": {
"$comment": "possibly empty list with omitted default empty list",
"items": {
"maximum": 9223372036854775807,
"minimum": -9223372036854775808,
"type": "number"
},
"type": "array"
},
"required-non-empty": {
"$comment": "required non-empty list",
"items": {
"type": "string"
},
"type": "array"
}
},
"required": [
"required-non-empty"
],
"type": "object"
}

49
autodocodec-api-usage/test_resources/openapi-schema/declareSchemaRef/lists-example.json Normal file
View File

@ -0,0 +1,49 @@
{
"definitions": {
"ListsExample": {
"properties": {
"optional-non-empty": {
"description": "optional non-empty list",
"items": {
"type": "string"
},
"type": "array"
},
"possibly-empty-with-default": {
"default": [],
"description": "possibly empty list with default empty list",
"items": {
"maximum": 9223372036854775807,
"minimum": -9223372036854775808,
"type": "number"
},
"type": "array"
},
"possibly-empty-with-omitted-default": {
"default": [],
"description": "possibly empty list with omitted default empty list",
"items": {
"maximum": 9223372036854775807,
"minimum": -9223372036854775808,
"type": "number"
},
"type": "array"
},
"required-non-empty": {
"description": "required non-empty list",
"items": {
"type": "string"
},
"type": "array"
}
},
"required": [
"required-non-empty"
],
"type": "object"
}
},
"reference": {
"$ref": "#/components/schemas/ListsExample"
}
}

54
autodocodec-api-usage/test_resources/openapi-schema/lists-example.json Normal file
View File

@ -0,0 +1,54 @@
{
"components": {
"schemas": {
"ListsExample": {
"properties": {
"optional-non-empty": {
"description": "optional non-empty list",
"items": {
"type": "string"
},
"type": "array"
},
"possibly-empty-with-default": {
"default": [],
"description": "possibly empty list with default empty list",
"items": {
"maximum": 9223372036854775807,
"minimum": -9223372036854775808,
"type": "number"
},
"type": "array"
},
"possibly-empty-with-omitted-default": {
"default": [],
"description": "possibly empty list with omitted default empty list",
"items": {
"maximum": 9223372036854775807,
"minimum": -9223372036854775808,
"type": "number"
},
"type": "array"
},
"required-non-empty": {
"description": "required non-empty list",
"items": {
"type": "string"
},
"type": "array"
}
},
"required": [
"required-non-empty"
],
"type": "object"
}
}
},
"info": {
"title": "",
"version": ""
},
"openapi": "3.0.0",
"paths": {}
}

63
autodocodec-api-usage/test_resources/show-codec/lists-example.txt Normal file
View File

@ -0,0 +1,63 @@
ObjectOfCodec
(Just "ListsExample")
(ApCodec
(ApCodec
(ApCodec
(BimapCodec
_
_
(OptionalKeyWithOmittedDefaultCodec
"possibly-empty-with-omitted-default"
(BimapCodec
_
_
(ArrayOfCodec
Nothing
(BimapCodec
_
_
(NumberCodec
Nothing
(Just
NumberBounds
{ numberBoundsLower = -9.223372036854775808e18
, numberBoundsUpper = 9.223372036854775807e18
})))))
_
(Just "possibly empty list with omitted default empty list")))
(BimapCodec
_
_
(OptionalKeyWithDefaultCodec
"possibly-empty-with-default"
(BimapCodec
_
_
(ArrayOfCodec
Nothing
(BimapCodec
_
_
(NumberCodec
Nothing
(Just
NumberBounds
{ numberBoundsLower = -9.223372036854775808e18
, numberBoundsUpper = 9.223372036854775807e18
})))))
_
(Just "possibly empty list with default empty list"))))
(BimapCodec
_
_
(RequiredKeyCodec
"required-non-empty"
(Just "required non-empty list")
(BimapCodec _ _ (ArrayOfCodec Nothing (StringCodec Nothing))))))
(BimapCodec
_
_
(OptionalKeyCodec
"optional-non-empty"
(Just "optional non-empty list")
(BimapCodec _ _ (ArrayOfCodec Nothing (StringCodec Nothing))))))

51
autodocodec-api-usage/test_resources/swagger-schema/lists-example.json Normal file
View File

@ -0,0 +1,51 @@
{
"definitions": {
"ListsExample": {
"default": [],
"properties": {
"optional-non-empty": {
"description": "optional non-empty list",
"items": {
"type": "string"
},
"type": "array"
},
"possibly-empty-with-default": {
"description": "possibly empty list with default empty list",
"items": {
"maximum": 9223372036854775807,
"minimum": -9223372036854775808,
"type": "number"
},
"type": "array"
},
"possibly-empty-with-omitted-default": {
"description": "possibly empty list with omitted default empty list",
"items": {
"maximum": 9223372036854775807,
"minimum": -9223372036854775808,
"type": "number"
},
"type": "array"
},
"required-non-empty": {
"description": "required non-empty list",
"items": {
"type": "string"
},
"type": "array"
}
},
"required": [
"required-non-empty"
],
"type": "object"
}
},
"info": {
"title": "",
"version": ""
},
"paths": {},
"swagger": "2.0"
}

15
autodocodec-api-usage/test_resources/yaml-schema/lists-example.txt Normal file
View File

@ -0,0 +1,15 @@
# ListsExample
possibly-empty-with-omitted-default: # optional
# default: []
# possibly empty list with omitted default empty list
- <number> # between -9223372036854775808 and 9223372036854775807
possibly-empty-with-default: # optional
# default: []
# possibly empty list with default empty list
- <number> # between -9223372036854775808 and 9223372036854775807
required-non-empty: # required
# required non-empty list
- <string>
optional-non-empty: # optional
# optional non-empty list
- <string>

28
autodocodec-servant-multipart/src/Autodocodec/Multipart.hs
View File

@ -11,7 +11,6 @@
module Autodocodec.Multipart where
import Autodocodec
import Control.Monad
import Data.Aeson as JSON
import Data.Aeson.Types as JSON
import qualified Data.ByteString.Lazy as LB
@ -154,22 +153,23 @@ fromMultipartVia = flip go
Nothing -> Left $ "Unexpected discriminator value: " <> show discriminatorValue
Just (_, c) -> go mpd c
RequiredKeyCodec key vc _ -> do
value <- lookupInput key mpd
goValue [value] vc
values <- lookupLInput key mpd
goValue values vc
OptionalKeyCodec key vc _ -> do
mValue <- lookupMInput key mpd
forM mValue $ \value ->
goValue [value] vc
values <- lookupLInput key mpd
case values of
[] -> pure Nothing
_ -> Just <$> goValue values vc
OptionalKeyWithDefaultCodec key vc defaultValue _ -> do
mValue <- lookupMInput key mpd
case mValue of
Nothing -> pure defaultValue
Just value -> goValue [value] vc
values <- lookupLInput key mpd
case values of
[] -> pure defaultValue
_ -> goValue values vc
OptionalKeyWithOmittedDefaultCodec key vc defaultValue _ -> do
mValue <- lookupMInput key mpd
case mValue of
Nothing -> pure defaultValue
Just value -> goValue [value] vc
values <- lookupLInput key mpd
case values of
[] -> pure defaultValue
_ -> goValue values vc
PureCodec v -> pure v
ApCodec ocf oca -> go mpd ocf <*> go mpd oca