Use decodeUtf8' instead of throwing

servant-multipart-api/src/Servant/Multipart/API.hs

@@ -129,9 +129,22 @@ import qualified Data.ByteString.Lazy as LBS
 --   after your handler has run, if they are still there. It is
 --   therefore recommended to move or copy them somewhere in your
 --   handler code if you need to keep the content around.
+--
+--   __Important__: the input names, input values, file names and file
+--   content types of the submitted form must all be valid UTF-8, including
+--   those of the parts that your 'FromMultipart' instance ignores. A form
+--   that carries any other encoding is rejected with a 400 response before
+--   your handler runs, unless 'Servant.API.Modifiers.Lenient' is used. The
+--   contents of the uploaded files are not decoded and may be arbitrary
+--   bytes.
 type MultipartForm tag a = MultipartForm' '[] tag a
 
 -- | 'MultipartForm' which can be modified with 'Servant.API.Modifiers.Lenient'.
+--
+--   Under 'Servant.API.Modifiers.Lenient', the handler is passed an
+--   @'Either' 'String' a@ rather than the request being rejected, so it is
+--   handed the message from a failed 'fromMultipart' call, or from a form
+--   whose text is not valid UTF-8.
 data MultipartForm' (mods :: [*]) tag a
 
 -- | What servant gets out of a @multipart/form-data@ form submission.

servant-multipart/src/Servant/Multipart.hs

@@ -47,7 +47,7 @@ import Control.Monad.IO.Class
 import Control.Monad.Trans.Resource
 import Data.Maybe
 import Data.Text (Text, unpack)
-import Data.Text.Encoding (decodeUtf8)
+import Data.Text.Encoding (decodeUtf8')
 import Data.Typeable
 import Network.Wai
 import Network.Wai.Parse
@@ -62,20 +62,32 @@ import qualified Data.ByteString          as SBS
 import qualified Data.Text.Lazy           as TL
 import qualified Data.Text.Lazy.Encoding  as TLE
 fromRaw :: forall tag. ([Network.Wai.Parse.Param], [File (MultipartResult tag)])
-        -> MultipartData tag
-fromRaw (inputs, files) = MultipartData is fs
+        -> Either String (MultipartData tag)
+fromRaw (inputs, files) =
+  MultipartData <$> traverse toInput inputs <*> traverse toFile files
 
-  where is = map (\(name, val) -> Input (dec name) (dec val)) inputs
-        fs = map toFile files
+  where toInput (iname, val) =
+          Input <$> decInput "name" iname iname
+                <*> decInput "value" iname val
 
-        toFile :: File (MultipartResult tag) -> FileData tag
+        toFile :: File (MultipartResult tag) -> Either String (FileData tag)
         toFile (iname, fileinfo) =
-          FileData (dec iname)
-                   (dec $ fileName fileinfo)
-                   (dec $ fileContentType fileinfo)
-                   (fileContent fileinfo)
-
-        dec = decodeUtf8
+          FileData <$> decFile "name" iname iname
+                   <*> decFile "file name" iname (fileName fileinfo)
+                   <*> decFile "content type" iname (fileContentType fileinfo)
+                   <*> pure (fileContent fileinfo)
+
+        decInput = dec "input"
+        decFile  = dec "file input"
+
+        dec :: String -> String -> SBS.ByteString -> SBS.ByteString
+            -> Either String Text
+        dec kind part iname raw =
+          case decodeUtf8' raw of
+            Right text -> Right text
+            Left _     -> Left $
+              part <> " of " <> kind <> " " <> show iname
+                   <> " is not valid UTF-8"
 
 class MultipartBackend tag where
     type MultipartBackendOptions tag :: *
@@ -93,7 +105,9 @@ class MultipartBackend tag where
 -- | Upon seeing @MultipartForm a :> ...@ in an API type,
 ---  servant-server will hand a value of type @a@ to your handler
 --   assuming the request body's content type is
---   @multipart/form-data@ and the call to 'fromMultipart' succeeds.
+--   @multipart/form-data@, the form's names, values, file names and
+--   content types are valid UTF-8, and the call to 'fromMultipart'
+--   succeeds.
 instance ( FromMultipart tag a
          , MultipartBackend tag
          , LookupContext config (MultipartOptions tag)
@@ -124,7 +138,7 @@ instance ( FromMultipart tag a
 check :: MultipartBackend tag
       => Proxy tag
       -> MultipartOptions tag
-      -> DelayedIO (MultipartData tag)
+      -> DelayedIO (Either String (MultipartData tag))
 check pTag tag = withRequest $ \request -> do
   st <- liftResourceT getInternalState
   rawData <- liftIO
@@ -154,8 +168,8 @@ addMultipartHandling pTag opts config subserver =
       fuzzyMultipartCTCheck (contentTypeH request)
 
     bodyCheck () = withRequest $ \ request -> do
-      mpd <- check pTag opts :: DelayedIO (MultipartData tag)
-      case (sbool :: SBool (FoldLenient mods), fromMultipart @tag @multipart mpd) of
+      mpd <- check pTag opts :: DelayedIO (Either String (MultipartData tag))
+      case (sbool :: SBool (FoldLenient mods), mpd >>= fromMultipart @tag @multipart) of
         (SFalse, Left msg) -> liftRouteResult $ FailFatal $ formatError request msg
         (SFalse, Right x) -> return x
         (STrue, res) -> return res