servant-multipart 0.11.5 → 0.11.6
raw patch · 5 files changed
+212/−43 lines, 5 filesdep +http-typesdep +string-conversionsdep +tastydep ~basedep ~bytestringdep ~lensnew-component:exe:uploadnew-uploader
Dependencies added: http-types, string-conversions, tasty, tasty-wai
Dependency ranges changed: base, bytestring, lens, servant-docs, servant-server, text
Files
- CHANGELOG.md +7/−0
- exe/Upload.hs +3/−4
- servant-multipart.cabal +25/−9
- src/Servant/Multipart.hs +45/−30
- test/Test.hs +132/−0
CHANGELOG.md view
@@ -1,3 +1,10 @@+0.11.6+------++- relax bounds for ghc810 #38+- update haskell-ci #37+- better parse errors #36+ 0.11.5 ------
exe/Upload.hs view
@@ -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"
servant-multipart.cabal view
@@ -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
src/Servant/Multipart.hs view
@@ -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 @\<input\>@ 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
+ test/Test.hs view
@@ -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--"+ ]