autodocodec-servant-multipart (empty) → 0.0.0.0

raw patch · 4 files changed

+321/−0 lines, 4 filesdep +aesondep +autodocodecdep +base

Dependencies added: aeson, autodocodec, base, bytestring, servant-multipart, servant-multipart-api, text, unordered-containers, vector

Files

• CHANGELOG.md +5/−0
• LICENSE +21/−0
• autodocodec-servant-multipart.cabal +43/−0
• src/Autodocodec/Multipart.hs +252/−0

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

@@ -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.

@@ -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 >=0.2.0.1+    , base >=4.7 && <5+    , bytestring+    , servant-multipart+    , servant-multipart-api+    , text+    , unordered-containers+    , vector+  default-language: Haskell2010

@@ -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 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+        values <- lookupLInput key mpd+        goValue values vc+      OptionalKeyCodec key vc _ -> do+        values <- lookupLInput key mpd+        case values of+          [] -> pure Nothing+          _ -> Just <$> goValue values vc+      OptionalKeyWithDefaultCodec key vc defaultValue _ -> do+        values <- lookupLInput key mpd+        case values of+          [] -> pure defaultValue+          _ -> goValue values vc+      OptionalKeyWithOmittedDefaultCodec key vc defaultValue _ -> do+        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++    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