autodocodec-servant-multipart

.hlint.yaml

@@ -4,5 +4,6 @@
 - ignore: { name: "Use fmap" }
 - ignore: { name: "Use tuple-section" }
 - ignore: { name: "Use ++" }
+- ignore: { name: "Use if" }
 - ignore: { name: "Avoid lambda using `infix`" }
 - ignore: { name: "Replace case with maybe" }

autodocodec-api-usage/autodocodec-api-usage.cabal

@@ -293,6 +293,7 @@ library
     , autodocodec >=0.2.0.0
     , autodocodec-openapi3
     , autodocodec-schema
+    , autodocodec-servant-multipart
     , autodocodec-swagger2
     , autodocodec-yaml
     , base >=4.7 && <5
@@ -304,6 +305,8 @@ library
     , genvalidity-text
     , openapi3
     , scientific
+    , servant-multipart
+    , servant-multipart-api
     , swagger2
     , text
     , unordered-containers
@@ -316,6 +319,7 @@ test-suite autodocodec-api-usage-test
   other-modules:
       Autodocodec.Aeson.SchemaSpec
       Autodocodec.AesonSpec
+      Autodocodec.MultipartSpec
       Autodocodec.OpenAPISpec
       Autodocodec.ShowSpec
       Autodocodec.SwaggerSpec
@@ -334,6 +338,7 @@ test-suite autodocodec-api-usage-test
     , autodocodec-api-usage
     , autodocodec-openapi3
     , autodocodec-schema
+    , autodocodec-servant-multipart
     , autodocodec-swagger2
     , autodocodec-yaml
     , base >=4.7 && <5
@@ -351,6 +356,7 @@ test-suite autodocodec-api-usage-test
     , pretty-show
     , safe-coloured-text
     , scientific
+    , servant-multipart-api
     , swagger2
     , sydtest
     , sydtest-aeson

autodocodec-api-usage/package.yaml

@@ -22,6 +22,7 @@ library:
   - autodocodec >=0.2.0.0
   - autodocodec-openapi3
   - autodocodec-schema
+  - autodocodec-servant-multipart
   - autodocodec-swagger2
   - autodocodec-yaml
   - bytestring
@@ -32,6 +33,8 @@ library:
   - genvalidity-text
   - openapi3
   - scientific
+  - servant-multipart
+  - servant-multipart-api
   - swagger2
   - text
   - unordered-containers
@@ -55,6 +58,7 @@ tests:
     - autodocodec-api-usage
     - autodocodec-openapi3
     - autodocodec-schema
+    - autodocodec-servant-multipart
     - autodocodec-swagger2
     - autodocodec-yaml
     - bytestring
@@ -71,6 +75,7 @@ tests:
     - pretty-show
     - safe-coloured-text
     - scientific
+    - servant-multipart-api
     - swagger2
     - sydtest
     - sydtest-aeson

autodocodec-api-usage/src/Autodocodec/Usage.hs

@@ -1,6 +1,8 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TypeApplications #-}
@@ -14,6 +16,7 @@ module Autodocodec.Usage where
 
 import Autodocodec
 import Autodocodec.Aeson ()
+import Autodocodec.Multipart
 import Autodocodec.OpenAPI ()
 import Autodocodec.Swagger ()
 import Control.Applicative
@@ -30,8 +33,11 @@ import Data.OpenApi (ToSchema)
 import qualified Data.OpenApi as OpenAPI
 import qualified Data.Swagger as Swagger
 import Data.Text (Text)
+import qualified Data.Text as T
 import Data.Word
 import GHC.Generics (Generic)
+import Servant.Multipart
+import Servant.Multipart.API as Servant
 import Test.QuickCheck
 
 -- | A type that's encoded as @null@.
@@ -106,18 +112,20 @@ instance GenValid Example where
   shrinkValid = shrinkValidStructurally
 
 instance HasCodec Example where
-  codec =
-    object "Example" $
-      Example
-        <$> requiredField "text" "a text" .= exampleText
-        <*> requiredField "bool" "a bool" .= exampleBool
-        <*> requiredField "maybe" "a maybe text" .= exampleRequiredMaybe
-        <*> optionalField "optional" "an optional text" .= exampleOptional
-        <*> optionalFieldOrNull "optional-or-null" "an optional-or-null text" .= exampleOptionalOrNull
-        <*> optionalFieldWithDefault "optional-with-default" "foobar" "an optional text with a default" .= exampleOptionalWithDefault
-        <*> optionalFieldWithOmittedDefault "optional-with-null-default" [] "an optional list of texts with a default empty list where the empty list would be omitted" .= exampleOptionalWithNullDefault
-        <*> optionalFieldWithOmittedDefaultWith "single-or-list" (singleOrListCodec codec) [] "an optional list that can also be specified as a single element" .= exampleSingleOrList
-        <*> requiredField "fruit" "fruit!!" .= exampleFruit
+  codec = object "Example" objectCodec
+
+instance HasObjectCodec Example where
+  objectCodec =
+    Example
+      <$> requiredField "text" "a text" .= exampleText
+      <*> requiredField "bool" "a bool" .= exampleBool
+      <*> requiredField "maybe" "a maybe text" .= exampleRequiredMaybe
+      <*> optionalField "optional" "an optional text" .= exampleOptional
+      <*> optionalFieldOrNull "optional-or-null" "an optional-or-null text" .= exampleOptionalOrNull
+      <*> optionalFieldWithDefault "optional-with-default" "foobar" "an optional text with a default" .= exampleOptionalWithDefault
+      <*> optionalFieldWithOmittedDefault "optional-with-null-default" [] "an optional list of texts with a default empty list where the empty list would be omitted" .= exampleOptionalWithNullDefault
+      <*> optionalFieldWithOmittedDefaultWith "single-or-list" (singleOrListCodec codec) [] "an optional list that can also be specified as a single element" .= exampleSingleOrList
+      <*> requiredField "fruit" "fruit!!" .= exampleFruit
 
 instance ToJSON Example where
   toJSON Example {..} =
@@ -160,6 +168,54 @@ instance FromJSON Example where
           )
       <*> o JSON..: "fruit"
 
+instance FromMultipart tag Example where
+  fromMultipart form =
+    Example
+      <$> lookupInput "text" form
+      <*> ( lookupInput "bool" form >>= \case
+              "True" -> Right True
+              "False" -> Right False
+              _ -> Left "Unknown bool"
+          )
+      <*> ( lookupInput "maybe" form >>= \case
+              "null" -> Right Nothing
+              t -> Right (Just t)
+          )
+      <*> lookupMInput "optional" form
+      <*> ( lookupMInput "optional-or-null" form >>= \case
+              Nothing -> Right Nothing
+              Just "null" -> Right Nothing
+              Just t -> Right (Just t)
+          )
+      <*> (fromMaybe "foobar" <$> lookupMInput "optional-with-default" form)
+      <*> lookupLInput "optional-with-null-default" form
+      <*> lookupLInput "single-or-list" form
+      <*> ( lookupInput "fruit" form >>= \case
+              "Apple" -> Right Apple
+              "Orange" -> Right Orange
+              "Banana" -> Right Banana
+              "Melon" -> Right Melon
+              _ -> Left "unknown fruit"
+          )
+
+instance ToMultipart tag Example where
+  toMultipart Example {..} =
+    MultipartData
+      ( concat
+          [ [ Input "text" exampleText,
+              Input "bool" $ T.pack $ show exampleBool,
+              Input "maybe" $ fromMaybe "null" exampleRequiredMaybe
+            ],
+            [Input "optional" o | o <- maybeToList exampleOptional],
+            [Input "optional-or-null" o | o <- maybeToList exampleOptionalOrNull],
+            [Input "optional-with-default" exampleOptionalWithDefault],
+            map (Input "optional-with-null-default") exampleOptionalWithNullDefault,
+            map (Input "single-or-list") exampleSingleOrList,
+            [Input "fruit" $ T.pack $ show exampleFruit]
+          ]
+      )
+      []
+
 -- | A simple Recursive type
 --
 -- We use this example to make sure that:
@@ -271,16 +327,20 @@ data Via = Via
     ( FromJSON,
       ToJSON,
       Swagger.ToSchema,
-      OpenAPI.ToSchema
+      OpenAPI.ToSchema,
+      Servant.FromMultipart tag,
+      Servant.ToMultipart tag
     )
     via (Autodocodec Via)
 
 instance HasCodec Via where
-  codec =
-    object "Via" $
-      Via
-        <$> requiredField "one" "first field" .= viaOne
-        <*> requiredField "two" "second field" .= viaTwo
+  codec = object "Via" objectCodec
+
+instance HasObjectCodec Via where
+  objectCodec =
+    Via
+      <$> requiredField "one" "first field" .= viaOne
+      <*> requiredField "two" "second field" .= viaTwo
 
 instance Validity Via
 
@@ -329,7 +389,9 @@ data LegacyValue = LegacyValue
     ( FromJSON,
       ToJSON,
       Swagger.ToSchema,
-      OpenAPI.ToSchema
+      OpenAPI.ToSchema,
+      Servant.FromMultipart tag,
+      Servant.ToMultipart tag
     )
     via (Autodocodec LegacyValue)
 
@@ -342,20 +404,21 @@ instance GenValid LegacyValue where
   shrinkValid = shrinkValidStructurallyWithoutExtraFiltering
 
 instance HasCodec LegacyValue where
-  codec =
-    parseAlternatives
-      ( object "LegacyValue" $
-          LegacyValue
-            <$> requiredField "1" "text 1" .= legacyValueText1
-            <*> requiredField "2" "text 2" .= legacyValueText2
-            <*> requiredField "3" "text 3" .= legacyValueText3
+  codec = object "LegacyValue" objectCodec
+
+instance HasObjectCodec LegacyValue where
+  objectCodec =
+    parseAlternative
+      ( LegacyValue
+          <$> requiredField "1" "text 1" .= legacyValueText1
+          <*> requiredField "2" "text 2" .= legacyValueText2
+          <*> requiredField "3" "text 3" .= legacyValueText3
+      )
+      ( LegacyValue
+          <$> requiredField "1old" "text 1" .= legacyValueText1
+          <*> requiredField "2old" "text 2" .= legacyValueText2
+          <*> requiredField "3old" "text 3" .= legacyValueText3
       )
-      [ object "LegacyValueOld" $
-          LegacyValue
-            <$> requiredField "1old" "text 1" .= legacyValueText1
-            <*> requiredField "2old" "text 2" .= legacyValueText2
-            <*> requiredField "3old" "text 3" .= legacyValueText3
-      ]
 
 data LegacyObject = LegacyObject
   { legacyObjectText1 :: Text,
@@ -368,7 +431,9 @@ data LegacyObject = LegacyObject
     ( FromJSON,
       ToJSON,
       Swagger.ToSchema,
-      OpenAPI.ToSchema
+      OpenAPI.ToSchema,
+      Servant.FromMultipart tag,
+      Servant.ToMultipart tag
     )
     via (Autodocodec LegacyObject)
 
@@ -381,21 +446,23 @@ instance GenValid LegacyObject where
   shrinkValid = shrinkValidStructurallyWithoutExtraFiltering
 
 instance HasCodec LegacyObject where
-  codec =
-    object "LegacyObject" $
-      LegacyObject
-        <$> parseAlternative (requiredField "1" "text 1") (requiredField "1old" "text 1") .= legacyObjectText1
-        <*> parseAlternative (requiredField "2" "text 2") (requiredField "2old" "text 2") .= legacyObjectText2
-        <*> parseAlternative (requiredField "3" "text 3") (requiredField "3old" "text 3") .= legacyObjectText3
-        <*> parseAlternatives
-          (requiredField "newest" "newest key")
-          [ requiredField "newer" "newer key",
-            requiredField "new" "new key",
-            requiredField "old" "old key",
-            requiredField "older" "older key",
-            requiredField "oldest" "oldest key"
-          ]
-          .= legacyObjectWithHistory
+  codec = object "LegacyObject" objectCodec
+
+instance HasObjectCodec LegacyObject where
+  objectCodec =
+    LegacyObject
+      <$> parseAlternative (requiredField "1" "text 1") (requiredField "1old" "text 1") .= legacyObjectText1
+      <*> parseAlternative (requiredField "2" "text 2") (requiredField "2old" "text 2") .= legacyObjectText2
+      <*> parseAlternative (requiredField "3" "text 3") (requiredField "3old" "text 3") .= legacyObjectText3
+      <*> parseAlternatives
+        (requiredField "newest" "newest key")
+        [ requiredField "newer" "newer key",
+          requiredField "new" "new key",
+          requiredField "old" "old key",
+          requiredField "older" "older key",
+          requiredField "oldest" "oldest key"
+        ]
+        .= legacyObjectWithHistory
 
 data Ainur
   = Valar !Text !Text
@@ -504,7 +571,9 @@ data These
     ( FromJSON,
       ToJSON,
       Swagger.ToSchema,
-      OpenAPI.ToSchema
+      OpenAPI.ToSchema,
+      Servant.FromMultipart tag,
+      Servant.ToMultipart tag
     )
     via (Autodocodec These)
 
@@ -517,9 +586,10 @@ instance GenValid These where
   shrinkValid = shrinkValidStructurallyWithoutExtraFiltering
 
 instance HasCodec These where
-  codec =
-    object "These" $
-      discriminatedUnionCodec "type" enc dec
+  codec = object "These" objectCodec
+
+instance HasObjectCodec These where
+  objectCodec = discriminatedUnionCodec "type" enc dec
     where
       textFieldCodec = requiredField' "text"
       intFieldCodec = requiredField' "int"
@@ -544,7 +614,9 @@ data Expression
     ( FromJSON,
       ToJSON,
       Swagger.ToSchema,
-      OpenAPI.ToSchema
+      OpenAPI.ToSchema,
+      Servant.FromMultipart tag,
+      Servant.ToMultipart tag
     )
     via (Autodocodec Expression)
 
@@ -567,8 +639,10 @@ instance GenValid Expression where
   shrinkValid = shrinkValidStructurallyWithoutExtraFiltering
 
 instance HasCodec Expression where
-  codec =
-    named "Expression" $ object "Expression" $ discriminatedUnionCodec "type" enc dec
+  codec = named "Expression" $ object "Expression" objectCodec
+
+instance HasObjectCodec Expression where
+  objectCodec = discriminatedUnionCodec "type" enc dec
     where
       valueFieldCodec = requiredField' "value"
       lrFieldsCodec = (,) <$> requiredField' "left" .= fst <*> requiredField' "right" .= snd

autodocodec-api-usage/test/Autodocodec/MultipartSpec.hs

@@ -0,0 +1,103 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Autodocodec.MultipartSpec (spec) where
+
+import Autodocodec
+import Autodocodec.Multipart
+import Autodocodec.Usage
+import Data.Data
+import Servant.Multipart.API
+import Test.Syd
+import Test.Syd.Validity
+import Test.Syd.Validity.Utils
+
+deriving instance Show Tmp
+
+deriving instance Show Mem
+
+deriving instance Show (MultipartResult tag) => Show (MultipartData tag)
+
+deriving instance Eq Tmp
+
+deriving instance Eq Mem
+
+deriving instance Eq (MultipartResult tag) => Eq (MultipartData tag)
+
+spec :: Spec
+spec = do
+  xdescribe "does not hold." $ multipartCodecSpec @Example
+  multipartCodecSpec @Via
+  multipartCodecSpec @LegacyValue
+  multipartCodecSpec @LegacyObject
+  multipartCodecSpec @These
+  multipartCodecSpec @Expression
+
+multipartCodecSpec ::
+  forall a.
+  ( Show a,
+    Eq a,
+    Typeable a,
+    GenValid a,
+    ToMultipart Tmp a,
+    FromMultipart Tmp a,
+    HasObjectCodec a
+  ) =>
+  Spec
+multipartCodecSpec =
+  describe ("multipartCodecSpec " <> nameOf @a) $ do
+    it "matches the encoding" $
+      forAllValid $ \(a :: a) ->
+        let ctx =
+              unlines
+                [ "Encoded with this codec",
+                  showCodecABit (objectCodec @a)
+                ]
+            encodedViaInstance = toMultipart a :: MultipartData Tmp
+            encodedViaCodec = toMultipartViaCodec a :: MultipartData Tmp
+         in context ctx $ encodedViaCodec `shouldBe` encodedViaInstance
+    it "matches the decoding" $
+      forAllValid $ \(a :: a) ->
+        let encoded = toMultipart a :: MultipartData Tmp
+            ctx =
+              unlines
+                [ "Encoded to this value:",
+                  ppShow encoded,
+                  "with this codec",
+                  showCodecABit (objectCodec @a)
+                ]
+            decodedWithAeson = fromMultipart encoded :: Either String a
+            decodedWithAutodocodec = fromMultipartViaCodec encoded :: Either String a
+         in context ctx $ decodedWithAutodocodec `shouldBe` decodedWithAeson
+    codecSpec @a
+
+codecSpec ::
+  forall a.
+  ( Show a,
+    Eq a,
+    GenValid a,
+    HasObjectCodec a
+  ) =>
+  Spec
+codecSpec = do
+  it "roundtrips through MultiPartData Tmp via the codec" $
+    forAllValid $ \(a :: a) ->
+      let encoded = toMultipartViaCodec a :: MultipartData Tmp
+          errOrDecoded = fromMultipartViaCodec encoded
+          ctx =
+            unlines
+              [ "Encoded to this value:",
+                ppShow encoded,
+                "with this codec",
+                showCodecABit (objectCodec @a)
+              ]
+       in context ctx $ case errOrDecoded of
+            Left err -> expectationFailure err
+            Right actual -> actual `shouldBe` a

autodocodec-api-usage/test_resources/json-schema/legacy-value.json

@@ -1,13 +1,7 @@
 {
+    "$comment": "LegacyValue",
     "anyOf": [
         {
-            "$comment": "LegacyValue",
-            "required": [
-                "3",
-                "2",
-                "1"
-            ],
-            "type": "object",
             "properties": {
                 "1": {
                     "$comment": "text 1",
@@ -21,21 +15,16 @@
                     "$comment": "text 3",
                     "type": "string"
                 }
-            }
+            },
+            "required": [
+                "3",
+                "2",
+                "1"
+            ],
+            "type": "object"
         },
         {
-            "$comment": "LegacyValueOld",
-            "required": [
-                "3old",
-                "2old",
-                "1old"
-            ],
-            "type": "object",
             "properties": {
-                "3old": {
-                    "$comment": "text 3",
-                    "type": "string"
-                },
                 "1old": {
                     "$comment": "text 1",
                     "type": "string"
@@ -43,8 +32,19 @@
                 "2old": {
                     "$comment": "text 2",
                     "type": "string"
+                },
+                "3old": {
+                    "$comment": "text 3",
+                    "type": "string"
                 }
-            }
+            },
+            "required": [
+                "3old",
+                "2old",
+                "1old"
+            ],
+            "type": "object"
         }
-    ]
+    ],
+    "type": "object"
 }

autodocodec-api-usage/test_resources/openapi-schema/declareSchemaRef/legacy-value.json

@@ -1,59 +1,56 @@
 {
-    "reference": {
-        "anyOf": [
-            {
-                "$ref": "#/components/schemas/LegacyValue"
-            },
-            {
-                "$ref": "#/components/schemas/LegacyValueOld"
-            }
-        ],
-        "additionalProperties": true
-    },
     "definitions": {
         "LegacyValue": {
-            "type": "object",
-            "properties": {
-                "1": {
-                    "type": "string",
-                    "description": "text 1"
+            "additionalProperties": true,
+            "anyOf": [
+                {
+                    "properties": {
+                        "1": {
+                            "description": "text 1",
+                            "type": "string"
+                        },
+                        "2": {
+                            "description": "text 2",
+                            "type": "string"
+                        },
+                        "3": {
+                            "description": "text 3",
+                            "type": "string"
+                        }
+                    },
+                    "required": [
+                        "1",
+                        "2",
+                        "3"
+                    ],
+                    "type": "object"
                 },
-                "3": {
-                    "type": "string",
-                    "description": "text 3"
-                },
-                "2": {
-                    "type": "string",
-                    "description": "text 2"
+                {
+                    "properties": {
+                        "1old": {
+                            "description": "text 1",
+                            "type": "string"
+                        },
+                        "2old": {
+                            "description": "text 2",
+                            "type": "string"
+                        },
+                        "3old": {
+                            "description": "text 3",
+                            "type": "string"
+                        }
+                    },
+                    "required": [
+                        "1old",
+                        "2old",
+                        "3old"
+                    ],
+                    "type": "object"
                 }
-            },
-            "required": [
-                "1",
-                "2",
-                "3"
-            ]
-        },
-        "LegacyValueOld": {
-            "type": "object",
-            "properties": {
-                "1old": {
-                    "type": "string",
-                    "description": "text 1"
-                },
-                "2old": {
-                    "type": "string",
-                    "description": "text 2"
-                },
-                "3old": {
-                    "type": "string",
-                    "description": "text 3"
-                }
-            },
-            "required": [
-                "1old",
-                "2old",
-                "3old"
             ]
         }
+    },
+    "reference": {
+        "$ref": "#/components/schemas/LegacyValue"
     }
 }

autodocodec-api-usage/test_resources/openapi-schema/legacy-value.json

@@ -2,55 +2,60 @@
     "components": {
         "schemas": {
             "LegacyValue": {
-                "required": [
-                    "1",
-                    "2",
-                    "3"
-                ],
-                "type": "object",
-                "properties": {
-                    "1": {
-                        "type": "string",
-                        "description": "text 1"
+                "additionalProperties": true,
+                "anyOf": [
+                    {
+                        "properties": {
+                            "1": {
+                                "description": "text 1",
+                                "type": "string"
+                            },
+                            "2": {
+                                "description": "text 2",
+                                "type": "string"
+                            },
+                            "3": {
+                                "description": "text 3",
+                                "type": "string"
+                            }
+                        },
+                        "required": [
+                            "1",
+                            "2",
+                            "3"
+                        ],
+                        "type": "object"
                     },
-                    "2": {
-                        "type": "string",
-                        "description": "text 2"
-                    },
-                    "3": {
-                        "type": "string",
-                        "description": "text 3"
+                    {
+                        "properties": {
+                            "1old": {
+                                "description": "text 1",
+                                "type": "string"
+                            },
+                            "2old": {
+                                "description": "text 2",
+                                "type": "string"
+                            },
+                            "3old": {
+                                "description": "text 3",
+                                "type": "string"
+                            }
+                        },
+                        "required": [
+                            "1old",
+                            "2old",
+                            "3old"
+                        ],
+                        "type": "object"
                     }
-                }
-            },
-            "LegacyValueOld": {
-                "type": "object",
-                "properties": {
-                    "1old": {
-                        "type": "string",
-                        "description": "text 1"
-                    },
-                    "2old": {
-                        "type": "string",
-                        "description": "text 2"
-                    },
-                    "3old": {
-                        "type": "string",
-                        "description": "text 3"
-                    }
-                },
-                "required": [
-                    "1old",
-                    "2old",
-                    "3old"
                 ]
             }
         }
     },
-    "openapi": "3.0.0",
     "info": {
-        "version": "",
-        "title": ""
+        "title": "",
+        "version": ""
     },
+    "openapi": "3.0.0",
     "paths": {}
 }

autodocodec-api-usage/test_resources/show-codec/legacy-value.txt

@@ -1,10 +1,10 @@
-BimapCodec
-  _
-  _
-  (EitherCodec
-     PossiblyJointUnion
-     (ObjectOfCodec
-        (Just "LegacyValue")
+ObjectOfCodec
+  (Just "LegacyValue")
+  (BimapCodec
+     _
+     _
+     (EitherCodec
+        PossiblyJointUnion
         (ApCodec
            (ApCodec
               (BimapCodec
@@ -12,9 +12,7 @@ BimapCodec
               (BimapCodec
                  _ _ (RequiredKeyCodec "2" (Just "text 2") (StringCodec Nothing))))
            (BimapCodec
-              _ _ (RequiredKeyCodec "3" (Just "text 3") (StringCodec Nothing)))))
-     (ObjectOfCodec
-        (Just "LegacyValueOld")
+              _ _ (RequiredKeyCodec "3" (Just "text 3") (StringCodec Nothing))))
         (ApCodec
            (ApCodec
               (BimapCodec

autodocodec-api-usage/test_resources/yaml-schema/legacy-value.txt

@@ -1,6 +1,6 @@
+# LegacyValue
 # any of
-[ # LegacyValue
-  1: # required
+[ 1: # required
     # text 1
     <string>
   2: # required
@@ -9,8 +9,7 @@
   3: # required
     # text 3
     <string>
-, # LegacyValueOld
-  1old: # required
+, 1old: # required
     # text 1
     <string>
   2old: # required

autodocodec-servant-multipart/.gitignore

@@ -0,0 +1,2 @@
+.stack-work/
+*~

autodocodec-servant-multipart/CHANGELOG.md

@@ -0,0 +1,5 @@
+# Changelog
+
+## [0.0.0.0] - 2022-07-27
+
+First version

autodocodec-servant-multipart/LICENSE

@@ -0,0 +1,21 @@
+MIT License
+
+Copyright (c) 2022 Tom Sydney Kerckhove
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.

autodocodec-servant-multipart/autodocodec-servant-multipart.cabal

@@ -0,0 +1,43 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.34.7.
+--
+-- see: https://github.com/sol/hpack
+
+name:           autodocodec-servant-multipart
+version:        0.0.0.0
+synopsis:       Autodocodec interpreters for Servant Multipart
+homepage:       https://github.com/NorfairKing/autodocodec#readme
+bug-reports:    https://github.com/NorfairKing/autodocodec/issues
+author:         Tom Sydney Kerckhove
+maintainer:     syd@cs-syd.eu
+copyright:      2022 Tom Sydney Kerckhove
+license:        MIT
+license-file:   LICENSE
+build-type:     Simple
+extra-source-files:
+    LICENSE
+    CHANGELOG.md
+
+source-repository head
+  type: git
+  location: https://github.com/NorfairKing/autodocodec
+
+library
+  exposed-modules:
+      Autodocodec.Multipart
+  other-modules:
+      Paths_autodocodec_servant_multipart
+  hs-source-dirs:
+      src
+  build-depends:
+      aeson
+    , autodocodec
+    , base >=4.7 && <5
+    , bytestring
+    , servant-multipart
+    , servant-multipart-api
+    , text
+    , unordered-containers
+    , vector
+  default-language: Haskell2010

autodocodec-servant-multipart/package.yaml

@@ -0,0 +1,27 @@
+name: autodocodec-servant-multipart
+version: 0.0.0.0
+github: "NorfairKing/autodocodec"
+license: MIT
+author: "Tom Sydney Kerckhove"
+maintainer: "syd@cs-syd.eu"
+copyright: "2022 Tom Sydney Kerckhove"
+synopsis: Autodocodec interpreters for Servant Multipart
+
+extra-source-files:
+- LICENSE
+- CHANGELOG.md
+
+dependencies:
+- base >= 4.7 && < 5
+
+library:
+  source-dirs: src
+  dependencies:
+  - aeson
+  - autodocodec
+  - bytestring
+  - servant-multipart
+  - servant-multipart-api
+  - text
+  - unordered-containers
+  - vector

autodocodec-servant-multipart/src/Autodocodec/Multipart.hs

@@ -0,0 +1,252 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+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
+import Data.Foldable
+import qualified Data.HashMap.Strict as HashMap
+import Data.Maybe
+import Data.Text (Text)
+import qualified Data.Text.Encoding as TE
+import qualified Data.Vector as V
+import Servant.Multipart as Servant
+import Servant.Multipart.API as Servant
+
+toMultipartViaCodec :: forall a tag. HasObjectCodec a => a -> MultipartData tag
+toMultipartViaCodec = toMultipartVia (objectCodec @a)
+
+toMultipartVia :: ObjectCodec a void -> a -> MultipartData tag
+toMultipartVia = flip go
+  where
+    go :: a -> ObjectCodec a void -> MultipartData tag
+    go a = \case
+      BimapCodec _ to c -> go (to a) c
+      EitherCodec _ c1 c2 -> case a of
+        Left a1 -> go a1 c1
+        Right a2 -> go a2 c2
+      DiscriminatedUnionCodec discriminator encoding _ ->
+        let (discriminatorValue, c) = encoding a
+         in mappendMultipartData
+              ( MultipartData
+                  { inputs = [Input discriminator discriminatorValue],
+                    files = []
+                  }
+              )
+              (go a c)
+      RequiredKeyCodec key vc _ ->
+        MultipartData
+          { inputs = map (Input key) (goValue a vc),
+            files = []
+          }
+      OptionalKeyCodec key vc _ ->
+        MultipartData
+          { inputs = do
+              a' <- maybeToList a
+              v <- goValue a' vc
+              pure $ Input key v,
+            files = []
+          }
+      OptionalKeyWithDefaultCodec key vc _ _ ->
+        MultipartData
+          { inputs = map (Input key) (goValue a vc),
+            files = []
+          }
+      OptionalKeyWithOmittedDefaultCodec key vc defaultValue _ ->
+        MultipartData
+          { inputs =
+              if a == defaultValue
+                then []
+                else map (Input key) (goValue a vc),
+            files = []
+          }
+      PureCodec _ -> memptyMultipartData
+      ApCodec oc1 oc2 -> mappendMultipartData (go a oc1) (go a oc2)
+
+    goValue :: a -> ValueCodec a void -> [Text]
+    goValue a = \case
+      BimapCodec _ to vc -> goValue (to a) vc
+      EitherCodec _ c1 c2 -> case a of
+        Left a1 -> goValue a1 c1
+        Right a2 -> goValue a2 c2
+      CommentCodec _ vc -> goValue a vc
+      ArrayOfCodec _ vc -> map (`goSingleValue` vc) (toList a)
+      vc -> [goSingleValue a vc]
+
+    goSingleValue :: a -> ValueCodec a void -> Text
+    goSingleValue a = \case
+      BimapCodec _ to vc -> goSingleValue (to a) vc
+      EitherCodec _ c1 c2 -> case a of
+        Left a1 -> goSingleValue a1 c1
+        Right a2 -> goSingleValue a2 c2
+      CommentCodec _ vc -> goSingleValue a vc
+      NullCodec -> "null"
+      BoolCodec _ ->
+        case a of
+          True -> "True"
+          False -> "False"
+      StringCodec _ -> a
+      vc ->
+        let value = toJSONVia vc a
+         in case value of
+              JSON.String t -> t
+              _ -> TE.decodeUtf8 (LB.toStrict (JSON.encode value))
+
+memptyMultipartData :: MultipartData tag
+memptyMultipartData =
+  MultipartData
+    { inputs = [],
+      files = []
+    }
+
+mappendMultipartData :: MultipartData tag -> MultipartData tag -> MultipartData tag
+mappendMultipartData mpd1 mpd2 =
+  MultipartData
+    { inputs = inputs mpd1 ++ inputs mpd2,
+      files = files mpd1 ++ files mpd2
+    }
+
+instance HasObjectCodec a => Servant.ToMultipart tag (Autodocodec a) where
+  toMultipart = toMultipartViaCodec . unAutodocodec
+
+fromMultipartViaCodec :: forall a tag. HasObjectCodec a => MultipartData tag -> Either String a
+fromMultipartViaCodec = fromMultipartVia (objectCodec @a)
+
+fromMultipartVia :: ObjectCodec void a -> MultipartData tag -> Either String a
+fromMultipartVia = flip go
+  where
+    go :: MultipartData tag -> ObjectCodec void a -> Either String a
+    go mpd = \case
+      BimapCodec from _ c -> go mpd c >>= from
+      EitherCodec u c1 c2 -> case u of
+        PossiblyJointUnion ->
+          case go mpd c1 of
+            Right l -> pure (Left l)
+            Left err1 -> case go mpd c2 of
+              Left err2 -> Left $ "  Previous branch failure: " <> err1 <> "\n" <> err2
+              Right r -> pure (Right r)
+        DisjointUnion ->
+          case (go mpd c1, go mpd c2) of
+            (Left _, Right r) -> pure (Right r)
+            (Right l, Left _) -> pure (Left l)
+            (Right _, Right _) -> Left "Both branches of a disjoint union succeeded."
+            (Left lErr, Left rErr) ->
+              Left $
+                unlines
+                  [ "Both branches of a disjoint union failed: ",
+                    unwords ["Left:  ", lErr],
+                    unwords ["Right: ", rErr]
+                  ]
+      DiscriminatedUnionCodec discriminator _ m -> do
+        discriminatorValue <- lookupInput discriminator mpd
+        case HashMap.lookup discriminatorValue m of
+          Nothing -> Left $ "Unexpected discriminator value: " <> show discriminatorValue
+          Just (_, c) -> go mpd c
+      RequiredKeyCodec key vc _ -> do
+        value <- lookupInput key mpd
+        goValue [value] vc
+      OptionalKeyCodec key vc _ -> do
+        mValue <- lookupMInput key mpd
+        forM mValue $ \value ->
+          goValue [value] vc
+      OptionalKeyWithDefaultCodec key vc defaultValue _ -> do
+        mValue <- lookupMInput key mpd
+        case mValue of
+          Nothing -> pure defaultValue
+          Just value -> goValue [value] vc
+      OptionalKeyWithOmittedDefaultCodec key vc defaultValue _ -> do
+        mValue <- lookupMInput key mpd
+        case mValue of
+          Nothing -> pure defaultValue
+          Just value -> goValue [value] vc
+      PureCodec v -> pure v
+      ApCodec ocf oca -> go mpd ocf <*> go mpd oca
+
+    goValue :: [Text] -> ValueCodec void a -> Either String a
+    goValue ts = \case
+      BimapCodec from _ c -> goValue ts c >>= from
+      EitherCodec u c1 c2 -> case u of
+        PossiblyJointUnion ->
+          case goValue ts c1 of
+            Right l -> pure (Left l)
+            Left err1 -> case goValue ts c2 of
+              Left err2 -> Left $ "  Previous branch failure: " <> err1 <> "\n" <> err2
+              Right r -> pure (Right r)
+        DisjointUnion ->
+          case (goValue ts c1, goValue ts c2) of
+            (Left _, Right r) -> pure (Right r)
+            (Right l, Left _) -> pure (Left l)
+            (Right _, Right _) -> Left "Both branches of a disjoint union succeeded."
+            (Left lErr, Left rErr) ->
+              Left $
+                unlines
+                  [ "Both branches of a disjoint union failed: ",
+                    unwords ["Left:  ", lErr],
+                    unwords ["Right: ", rErr]
+                  ]
+      ReferenceCodec _ vc -> goValue ts vc
+      CommentCodec _ c -> goValue ts c
+      ArrayOfCodec _ vc -> V.fromList <$> mapM (`goSingleValue` vc) (toList ts)
+      vc -> case ts of
+        [t] -> goSingleValue t vc
+        _ -> Left "Expected exactly one value."
+
+    goSingleValue :: Text -> ValueCodec void a -> Either String a
+    goSingleValue t = \case
+      BimapCodec from _ c -> goSingleValue t c >>= from
+      EitherCodec u c1 c2 -> case u of
+        PossiblyJointUnion ->
+          case goSingleValue t c1 of
+            Right l -> pure (Left l)
+            Left err1 -> case goSingleValue t c2 of
+              Left err2 -> Left $ "  Previous branch failure: " <> err1 <> "\n" <> err2
+              Right r -> pure (Right r)
+        DisjointUnion ->
+          case (goSingleValue t c1, goSingleValue t c2) of
+            (Left _, Right r) -> pure (Right r)
+            (Right l, Left _) -> pure (Left l)
+            (Right _, Right _) -> Left "Both branches of a disjoint union succeeded."
+            (Left lErr, Left rErr) ->
+              Left $
+                unlines
+                  [ "Both branches of a disjoint union failed: ",
+                    unwords ["Left:  ", lErr],
+                    unwords ["Right: ", rErr]
+                  ]
+      CommentCodec _ c -> goSingleValue t c
+      ReferenceCodec _ vc -> goSingleValue t vc
+      NullCodec -> case t of
+        "null" -> Right ()
+        _ -> Left $ "not 'null': " <> show t
+      BoolCodec _ -> case t of
+        "false" -> Right False
+        "False" -> Right False
+        "true" -> Right True
+        "True" -> Right True
+        _ -> Left $ "Unknown bool: " <> show t
+      StringCodec _ -> Right t
+      vc -> case JSON.parseEither (parseJSONVia vc) (JSON.String t) of
+        Right a -> Right a
+        Left _ -> do
+          value <- JSON.eitherDecode (LB.fromStrict (TE.encodeUtf8 t))
+          JSON.parseEither (parseJSONVia vc) value
+
+lookupMInput :: Text -> MultipartData tag -> Either String (Maybe Text)
+lookupMInput iname = Right . fmap iValue . find ((== iname) . iName) . inputs
+
+lookupLInput :: Text -> MultipartData tag -> Either String [Text]
+lookupLInput iname = Right . map iValue . filter ((== iname) . iName) . inputs
+
+instance HasObjectCodec a => Servant.FromMultipart tag (Autodocodec a) where
+  fromMultipart = fmap Autodocodec . fromMultipartViaCodec

autodocodec/src/Autodocodec.hs

@@ -19,6 +19,7 @@ module Autodocodec
     JSONCodec,
     JSONObjectCodec,
     HasCodec (..),
+    HasObjectCodec (..),
 
     -- * Writing a codec
     object,

autodocodec/src/Autodocodec/Aeson/Decode.hs

@@ -112,7 +112,7 @@ parseJSONContextVia codec_ context_ =
       DiscriminatedUnionCodec propertyName _ m -> do
         discriminatorValue <- (value :: JSON.Object) JSON..: Compat.toKey propertyName
         case HashMap.lookup discriminatorValue m of
-          Nothing -> fail $ "Unexpected discriminator value: " <> T.unpack discriminatorValue
+          Nothing -> fail $ "Unexpected discriminator value: " <> show discriminatorValue
           Just (_, c) ->
             go value c
       CommentCodec _ c -> go value c

autodocodec/src/Autodocodec/Class.hs

@@ -153,6 +153,16 @@ instance HasCodec NominalDiffTime where
 instance HasCodec DiffTime where
   codec = dimapCodec realToFrac realToFrac (codec :: JSONCodec Scientific)
 
+-- | A class for values which have a canonical object codec.
+--
+-- There are no formal laws for this class.
+-- If you really want a law, it should be "Whomever uses the 'codec' from your instance should not be surprised."
+class HasObjectCodec object where
+  -- | A object codec for the value
+  --
+  -- See the sections on helper functions for implementing this for plenty of examples.
+  objectCodec :: JSONObjectCodec object
+
 -- | A required field
 --
 -- During decoding, the field must be in the object.

nix/overlay.nix

@@ -34,6 +34,7 @@ with final.haskell.lib;
       "autodocodec-api-usage"
       "autodocodec-openapi3"
       "autodocodec-schema"
+      "autodocodec-servant-multipart"
       "autodocodec-swagger2"
       "autodocodec-yaml"
     ]

stack.yaml

@@ -4,6 +4,7 @@ packages:
 - autodocodec-api-usage
 - autodocodec-openapi3
 - autodocodec-schema
+- autodocodec-servant-multipart
 - autodocodec-swagger2
 - autodocodec-yaml
 extra-deps: