diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,10 @@ +0.11.6 +------ + +- relax bounds for ghc810 #38 +- update haskell-ci #37 +- better parse errors #36 + 0.11.5 ------ diff --git a/exe/Upload.hs b/exe/Upload.hs --- a/exe/Upload.hs +++ b/exe/Upload.hs @@ -8,7 +8,6 @@ import Control.Monad.IO.Class import Network.Socket (withSocketsDo) import Network.HTTP.Client hiding (Proxy) -import Network.Wai import Network.Wai.Handler.Warp import Servant import Servant.Multipart @@ -66,14 +65,14 @@ args <- getArgs case args of ("run":_) -> withSocketsDo $ do - forkIO startServer + _ <- forkIO startServer -- we fork the server in a separate thread and send a test -- request to it from the main thread. manager <- newManager defaultManagerSettings boundary <- genBoundary let burl = BaseUrl Http "localhost" 8080 "" - run cli = runClientM cli (mkClientEnv manager burl) - resp <- run $ client clientApi (boundary, form) + runC cli = runClientM cli (mkClientEnv manager burl) + resp <- runC $ client clientApi (boundary, form) print resp _ -> putStrLn "Pass run to run" diff --git a/servant-multipart.cabal b/servant-multipart.cabal --- a/servant-multipart.cabal +++ b/servant-multipart.cabal @@ -1,10 +1,10 @@ name: servant-multipart -version: 0.11.5 +version: 0.11.6 synopsis: multipart/form-data (e.g file upload) support for servant description: This package adds support for file upload to the servant ecosystem. It draws - on ideas and code from several people who participated in the (in)famous - [ticket #133](https://github.com/haskell-servant/servant/issues/133) on + on ideas and code from several people who participated in the + (in)famous [ticket #133](https://github.com/haskell-servant/servant/issues/133) on servant's issue tracker. homepage: https://github.com/haskell-servant/servant-multipart#readme @@ -17,7 +17,7 @@ build-type: Simple cabal-version: >=1.10 extra-source-files: CHANGELOG.md -tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.1 +tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.3 library default-language: Haskell2010 @@ -37,18 +37,18 @@ -- other dependencies build-depends: http-media >=0.7.1.3 && <0.9 - , lens >=4.17 && <4.19 + , lens >=4.17 && <4.20 , resourcet >=1.2.2 && <1.3 , servant >=0.16 && <0.18 , servant-client-core >=0.16 && <0.18 - , servant-docs >=0.10 && <0.15 + , servant-docs >=0.10 && <0.16 , servant-foreign >=0.15 && <0.16 , servant-server >=0.16 && <0.18 + , string-conversions >=0.4.0.1 && <0.5 , wai >=3.2.1.2 && <3.3 , wai-extra >=3.0.24.3 && <3.1 -test-suite upload - type: exitcode-stdio-1.0 +executable upload hs-source-dirs: exe main-is: Upload.hs default-language: Haskell2010 @@ -67,6 +67,22 @@ , wai , warp +test-suite servant-multipart-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Test.hs + default-language: Haskell2010 + build-depends: + base + , bytestring + , http-types + , servant-multipart + , servant-server + , string-conversions + , tasty + , tasty-wai + , text + source-repository head type: git - location: https://github.com/haskell-servent/servant-multipart + location: https://github.com/haskell-servant/servant-multipart diff --git a/src/Servant/Multipart.hs b/src/Servant/Multipart.hs --- a/src/Servant/Multipart.hs +++ b/src/Servant/Multipart.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE InstanceSigs #-} @@ -19,6 +20,7 @@ -- an API. See haddocks of 'MultipartForm' for an introduction. module Servant.Multipart ( MultipartForm + , MultipartForm' , MultipartData(..) , FromMultipart(..) , lookupInput @@ -45,20 +47,21 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Resource import Data.Array (listArray, (!)) -import Data.Foldable (foldMap, foldl') -import Data.List (find) +import Data.List (find, foldl') import Data.Maybe import Data.Monoid +import Data.String.Conversions (cs) import Data.Text (Text, unpack) import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Typeable import Network.HTTP.Media.MediaType ((//), (/:)) import Network.Wai import Network.Wai.Parse -import Servant +import Servant hiding (contentType) +import Servant.API.Modifiers (FoldLenient) import Servant.Client.Core (HasClient(..), RequestBody(RequestBodySource), setRequestBody) -import Servant.Docs -import Servant.Foreign +import Servant.Docs hiding (samples) +import Servant.Foreign hiding (contentType) import Servant.Server.Internal import Servant.Types.SourceT (SourceT(..), source, StepT(..), fromActionStep) import System.Directory @@ -150,8 +153,11 @@ -- 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. -data MultipartForm tag a +type MultipartForm tag a = MultipartForm' '[] tag a +-- | 'MultipartForm' which can be modified with 'Servant.API.Modifiers.Lenient'. +data MultipartForm' (mods :: [*]) tag a + -- | What servant gets out of a @multipart/form-data@ form submission. -- -- The type parameter 'tag' tells if 'MultipartData' is stored as a @@ -209,8 +215,11 @@ deriving instance Show (MultipartResult tag) => Show (FileData tag) -- | Lookup a file input with the given @name@ attribute. -lookupFile :: Text -> MultipartData tag -> Maybe (FileData tag) -lookupFile iname = find ((==iname) . fdInputName) . files +lookupFile :: Text -> MultipartData tag -> Either String (FileData tag) +lookupFile iname = + maybe (Left $ "File " <> cs iname <> " not found") Right + . find ((==iname) . fdInputName) + . files -- | Representation for a textual input (any @\@ type but @file@). -- @@ -221,8 +230,11 @@ } deriving (Eq, Show) -- | Lookup a textual input with the given @name@ attribute. -lookupInput :: Text -> MultipartData tag -> Maybe Text -lookupInput iname = fmap iValue . find ((==iname) . iName) . inputs +lookupInput :: Text -> MultipartData tag -> Either String Text +lookupInput iname = + maybe (Left $ "Field " <> cs iname <> " not found") (Right . iValue) + . find ((==iname) . iName) + . inputs -- | 'MultipartData' is the type representing -- @multipart/form-data@ form inputs. Sometimes @@ -246,10 +258,10 @@ -- in a list of textual inputs and another list for -- files, try to extract a value of type @a@. When -- extraction fails, servant errors out with status code 400. - fromMultipart :: MultipartData tag -> Maybe a + fromMultipart :: MultipartData tag -> Either String a instance FromMultipart tag (MultipartData tag) where - fromMultipart = Just + fromMultipart = Right -- | Allows you to tell servant how to turn a more structured type -- into a 'MultipartData', which is what is actually sent by the @@ -281,11 +293,12 @@ instance ( FromMultipart tag a , MultipartBackend tag , LookupContext config (MultipartOptions tag) + , SBoolI (FoldLenient mods) , HasServer sublayout config ) - => HasServer (MultipartForm tag a :> sublayout) config where + => HasServer (MultipartForm' mods tag a :> sublayout) config where - type ServerT (MultipartForm tag a :> sublayout) m = - a -> ServerT sublayout m + type ServerT (MultipartForm' mods tag a :> sublayout) m = + If (FoldLenient mods) (Either String a) a -> ServerT sublayout m #if MIN_VERSION_servant_server(0,12,0) hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy sublayout) pc nt . s @@ -299,16 +312,16 @@ popts = Proxy :: Proxy (MultipartOptions tag) multipartOpts = fromMaybe (defaultMultipartOptions pbak) $ lookupContext popts config - subserver' = addMultipartHandling pbak multipartOpts subserver + subserver' = addMultipartHandling @tag @a @mods pbak multipartOpts subserver -- | Upon seeing @MultipartForm a :> ...@ in an API type, -- servant-client will take a parameter of type @(LBS.ByteString, a)@, -- where the bytestring is the boundary to use (see 'genBoundary'), and -- replace the request body with the contents of the form. instance (ToMultipart tag a, HasClient m api, MultipartBackend tag) - => HasClient m (MultipartForm tag a :> api) where + => HasClient m (MultipartForm' mods tag a :> api) where - type Client m (MultipartForm tag a :> api) = + type Client m (MultipartForm' mods tag a :> api) = (LBS.ByteString, a) -> Client m api clientWithRoute pm _ req (boundary, param) = @@ -352,7 +365,7 @@ -- | Given a bytestring for the boundary, turns a `MultipartData` into -- a 'RequestBody' -multipartToBody :: forall tag. +multipartToBody :: forall tag. MultipartBackend tag => LBS.ByteString -> MultipartData tag @@ -373,7 +386,7 @@ mempty' = SourceT ($ Stop) crlf = "\r\n" lencode = LBS.fromStrict . encodeUtf8 - renderInput input = renderPart (lencode . iName $ input) + renderInput input = renderPart (lencode . iName $ input) "text/plain" "" (source . pure . lencode . iValue $ input) @@ -420,10 +433,11 @@ where parseOpts = generalOptions tag -- Add multipart extraction support to a Delayed. -addMultipartHandling :: forall tag multipart env a. (FromMultipart tag multipart, MultipartBackend tag) +addMultipartHandling :: forall tag multipart (mods :: [*]) env a. (FromMultipart tag multipart, MultipartBackend tag) + => SBoolI (FoldLenient mods) => Proxy tag -> MultipartOptions tag - -> Delayed env (multipart -> a) + -> Delayed env (If (FoldLenient mods) (Either String multipart) multipart -> a) -> Delayed env a addMultipartHandling pTag opts subserver = addBodyCheck subserver contentCheck bodyCheck @@ -433,10 +447,11 @@ bodyCheck () = do mpd <- check pTag opts :: DelayedIO (MultipartData tag) - case fromMultipart mpd of - Nothing -> liftRouteResult $ FailFatal - err400 { errBody = "fromMultipart returned Nothing" } - Just x -> return x + case (sbool :: SBool (FoldLenient mods), fromMultipart @tag @multipart mpd) of + (SFalse, Left msg) -> liftRouteResult $ FailFatal + err400 { errBody = "Could not decode multipart mime body: " <> cs msg } + (SFalse, Right x) -> return x + (STrue, res) -> return $ either (Left . cs) Right res contentTypeH req = fromMaybe "application/octet-stream" $ lookup "Content-Type" (requestHeaders req) @@ -502,7 +517,7 @@ type MultipartBackendOptions Tmp = TmpBackendOptions defaultBackendOptions _ = defaultTmpBackendOptions - -- streams the file from disk + -- streams the file from disk loadFile _ fp = SourceT $ \k -> withFile fp ReadMode $ \hdl -> @@ -519,7 +534,7 @@ defaultBackendOptions _ = () loadFile _ = source . pure - backend _ opts _ = lbsBackEnd + backend _ _ _ = lbsBackEnd -- | Configuration for the temporary file based backend. -- @@ -563,8 +578,8 @@ instance {-# OVERLAPPABLE #-} LookupContext cs a => LookupContext (c ': cs) a where - lookupContext p (c :. cs) = - lookupContext p cs + lookupContext p (_ :. cxts) = + lookupContext p cxts instance {-# OVERLAPPING #-} LookupContext cs a => LookupContext (a ': cs) a where diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +import Data.ByteString as BS (ByteString) +import Data.ByteString.Lazy as BSL (ByteString) +import Data.List (intersperse) +import Data.Monoid +import Data.String.Conversions (cs) +import Data.Text (Text) +import Network.HTTP.Types.Header (HeaderName, hContentType) + +import Test.Tasty +import Test.Tasty.Wai + +import Servant +import Servant.Multipart + +main :: IO () +main = defaultMain $ testGroup "servant-multipart" + [ testGroup "strict handler with FromMultipart" + [ testWai testApp "correct body" testBlogPostStrictHandler + , testWai testApp "empty body" testBlogPostStrictHandlerEmptyBody + , testWai testApp "partial body" testBlogPostStrictHandlerPartialBody + ] + , testGroup "lenient handler with FromMultipart" + [ testWai testApp "correct body" testBlogPostLenientHandler + , testWai testApp "partial body" testBlogPostLenientHandlerPartialBody + ] + , testGroup "strict handler with raw MultipartData" + [ testWai testApp "correct body" testBlogPostRawHandler + ] + ] + +data BlogPost + = BlogPost + { title :: Text + , body :: Text + } + +instance FromMultipart Mem BlogPost where + fromMultipart md = + BlogPost + <$> lookupInput "title" md + <*> fmap (cs . fdPayload) (lookupFile "body" md) + +type TestAPI + = "blogPostStrict" :> MultipartForm Mem BlogPost :> Post '[PlainText] Text + :<|> "blogPostLenient" :> MultipartForm' '[Lenient] Mem BlogPost :> Post '[JSON] Bool + :<|> "blogPostRaw" :> MultipartForm Mem (MultipartData Mem) :> Post '[PlainText] Text + +blogPostStrictHandler :: BlogPost -> Handler Text +blogPostStrictHandler bp = return $ title bp <> "\n" <> body bp + +blogPostLenientHandler :: Either String BlogPost -> Handler Bool +blogPostLenientHandler eitherBP = + case eitherBP of + Left _ -> return False + Right _ -> return True + +blogPostRawHandler :: MultipartData Mem -> Handler Text +blogPostRawHandler md = + return $ mconcat $ intersperse " " + $ map iName (inputs md) <> map fdInputName (files md) + +testApp :: Application +testApp = serve @TestAPI Proxy $ blogPostStrictHandler :<|> blogPostLenientHandler :<|> blogPostRawHandler + +multipartHeaders :: [(HeaderName, BS.ByteString)] +multipartHeaders = [(hContentType, "multipart/form-data; boundary=XX")] + +testBlogPostStrictHandler :: Session () +testBlogPostStrictHandler = do + res <- srequest $ buildRequestWithHeaders POST "/blogPostStrict" correctBody multipartHeaders + assertStatus 200 res + assertBody "Foo post\nFoo body\n" res + +testBlogPostStrictHandlerEmptyBody :: Session () +testBlogPostStrictHandlerEmptyBody = do + res <- srequest $ buildRequestWithHeaders POST "/blogPostStrict" "" multipartHeaders + assertStatus 400 res + assertBody "Could not decode multipart mime body: Field title not found" res + +testBlogPostStrictHandlerPartialBody :: Session () +testBlogPostStrictHandlerPartialBody = do + res <- srequest $ buildRequestWithHeaders POST "/blogPostStrict" partialBody multipartHeaders + assertStatus 400 res + assertBody "Could not decode multipart mime body: File body not found" res + +testBlogPostLenientHandler :: Session () +testBlogPostLenientHandler = do + res <- srequest $ buildRequestWithHeaders POST "/blogPostLenient" correctBody multipartHeaders + assertStatus 200 res + assertBody "true" res + +testBlogPostLenientHandlerPartialBody :: Session () +testBlogPostLenientHandlerPartialBody = do + res <- srequest $ buildRequestWithHeaders POST "/blogPostLenient" partialBody multipartHeaders + assertStatus 200 res + assertBody "false" res + +testBlogPostRawHandler :: Session () +testBlogPostRawHandler = do + res <- srequest $ buildRequestWithHeaders POST "/blogPostRaw" correctBody multipartHeaders + assertStatus 200 res + assertBody "title body" res + +correctBody :: BSL.ByteString +correctBody = mconcat $ intersperse "\n" + [ "--XX" + , "Content-Disposition: form-data; name=\"title\"" + , "" + , "Foo post" + , "--XX" + , "Content-Disposition: form-data; name=\"body\"; filename=\"body.md\"" + , "" + , "Foo body" + , "" + , "--XX--" + ] + +partialBody :: BSL.ByteString +partialBody = mconcat $ intersperse "\n" + [ "--XX" + , "Content-Disposition: form-data; name=\"title\"" + , "" + , "Foo post" + , "" + , "--XX--" + ]