servant-multipart 0.12 → 0.12.1
raw patch · 4 files changed
+46/−474 lines, 4 filesdep +servant-multipart-apidep −arraydep −http-clientdep −http-mediadep ~basedep ~bytestringdep ~lens
Dependencies added: servant-multipart-api
Dependencies removed: array, http-client, http-media, network, random, servant-client, servant-client-core, transformers, warp
Dependency ranges changed: base, bytestring, lens, resourcet, servant, servant-docs, servant-foreign, servant-server, text, wai
Files
- CHANGELOG.md +6/−0
- exe/Upload.hs +0/−85
- servant-multipart.cabal +7/−33
- src/Servant/Multipart.hs +33/−356
CHANGELOG.md view
@@ -1,3 +1,9 @@+0.12.1+------++- split package into api, server and client parts+ [#51](https://github.com/haskell-servant/servant-multipart/pull/51)+ 0.12 ----
− exe/Upload.hs
@@ -1,85 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}--import Control.Concurrent-import Control.Monad-import Control.Monad.IO.Class-import Network.Socket (withSocketsDo)-import Network.HTTP.Client hiding (Proxy)-import Network.Wai.Handler.Warp-import Servant-import Servant.Multipart-import System.Environment (getArgs)-import Servant.Client (client, runClientM, mkClientEnv)-import Servant.Client.Core (BaseUrl(BaseUrl), Scheme(Http))--import qualified Data.ByteString.Lazy as LBS---- Our API, which consists in a single POST endpoint at /--- that takes a multipart/form-data request body and--- pretty-prints the data it got to stdout before returning 0.-type API = MultipartForm Mem (MultipartData Mem) :> Post '[JSON] Integer---- We want to load our file from disk, so we need to convert--- the 'Mem's in the serverside API to 'Tmp's-type family MemToTmp api where- MemToTmp (a :<|> b) = MemToTmp a :<|> MemToTmp b- MemToTmp (a :> b) = MemToTmp a :> MemToTmp b- MemToTmp (MultipartForm Mem (MultipartData Mem)) = MultipartForm Tmp (MultipartData Tmp)- MemToTmp a = a--api :: Proxy API-api = Proxy--clientApi :: Proxy (MemToTmp API)-clientApi = Proxy---- The handler for our single endpoint.--- Its concrete type is:--- MultipartData -> Handler Integer------ MultipartData consists in textual inputs,--- accessible through its "inputs" field, as well--- as files, accessible through its "files" field.-upload :: Server API-upload multipartData = do- liftIO $ do- putStrLn "Inputs:"- forM_ (inputs multipartData) $ \input ->- putStrLn $ " " ++ show (iName input)- ++ " -> " ++ show (iValue input)-- forM_ (files multipartData) $ \file -> do- let content = fdPayload file- putStrLn $ "Content of " ++ show (fdFileName file)- LBS.putStr content- return 0--startServer :: IO ()-startServer = run 8080 (serve api upload)--main :: IO ()-main = do- args <- getArgs- case args of- ("run":_) -> withSocketsDo $ do- _ <- 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 ""- runC cli = runClientM cli (mkClientEnv manager burl)- resp <- runC $ client clientApi (boundary, form)- print resp- _ -> putStrLn "Pass run to run"-- where form = MultipartData [ Input "title" "World"- , Input "text" "Hello"- ]- [ FileData "file" "./servant-multipart.cabal"- "text/plain" "./servant-multipart.cabal"- , FileData "otherfile" "./Setup.hs" "text/plain" "./Setup.hs"- ]
servant-multipart.cabal view
@@ -1,11 +1,8 @@ name: servant-multipart-version: 0.12+version: 0.12.1 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- servant's issue tracker.+ This package adds server-side support of file upload to the servant ecosystem. homepage: https://github.com/haskell-servant/servant-multipart#readme license: BSD3@@ -17,7 +14,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.4 || ==8.10.2+tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.4 library default-language: Haskell2010@@ -26,46 +23,23 @@ -- ghc boot libs build-depends:- array >=0.5.1.1 && <0.6- , base >=4.9 && <5+ base >=4.9 && <5 , bytestring >=0.10.8.1 && <0.11 , directory >=1.3 && <1.4 , text >=1.2.3.0 && <1.3- , transformers >=0.5.2.0 && <0.6- , random >=0.1.1 && <1.2 -- other dependencies build-depends:- http-media >=0.7.1.3 && <0.9- , lens >=4.17 && <4.20+ servant-multipart-api == 0.12.*+ , lens >=4.17 && <5.1 , resourcet >=1.2.2 && <1.3 , servant >=0.16 && <0.19- , servant-client-core >=0.16 && <0.19 , servant-docs >=0.10 && <0.19 , servant-foreign >=0.15 && <0.19 , servant-server >=0.16 && <0.19 , string-conversions >=0.4.0.1 && <0.5 , wai >=3.2.1.2 && <3.3- , wai-extra >=3.0.24.3 && <3.1--executable upload- hs-source-dirs: exe- main-is: Upload.hs- default-language: Haskell2010- build-depends:- base- , bytestring- , http-client- , network >=2.8 && <3.2- , servant- , servant-multipart- , servant-server- , servant-client- , servant-client-core- , text- , transformers- , wai- , warp+ , wai-extra >=3.0.24.3 && <3.2 test-suite servant-multipart-test type: exitcode-stdio-1.0
src/Servant/Multipart.hs view
@@ -14,10 +14,8 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeApplications #-}--- | @multipart/form-data@ support for servant.------ This is mostly useful for adding file upload support to--- an API. See haddocks of 'MultipartForm' for an introduction.+-- | @multipart/form-data@ server-side support for servant.+-- See servant-multipart-api for the API definitions. module Servant.Multipart ( MultipartForm , MultipartForm'@@ -34,150 +32,48 @@ , defaultTmpBackendOptions , Input(..) , FileData(..)- -- * servant-client- , genBoundary- , ToMultipart(..)- , multipartToBody -- * servant-docs , ToMultipartSample(..) ) where +import Servant.Multipart.API+ import Control.Lens ((<>~), (&), view, (.~))-import Control.Monad (replicateM) import Control.Monad.IO.Class import Control.Monad.Trans.Resource-import Data.Array (listArray, (!))-import Data.List (find, foldl')+import Data.List (find) import Data.Maybe-import Data.Monoid+#if !MIN_VERSION_base(4,11,0)+import Data.Monoid ((<>))+#endif import Data.String.Conversions (cs) import Data.Text (Text, unpack)-import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import Data.Text.Encoding (decodeUtf8) import Data.Typeable-import Network.HTTP.Media.MediaType ((//), (/:)) import Network.Wai import Network.Wai.Parse import Servant hiding (contentType) import Servant.API.Modifiers (FoldLenient)-import Servant.Client.Core (HasClient(..), RequestBody(RequestBodySource), setRequestBody) 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-import System.IO (IOMode(ReadMode), withFile)-import System.Random (getStdRandom, Random(randomR)) import qualified Data.ByteString as SBS-import qualified Data.ByteString.Lazy as LBS --- | Combinator for specifying a @multipart/form-data@ request--- body, typically (but not always) issued from an HTML @\<form\>@.------ @multipart/form-data@ can't be made into an ordinary content--- type for now in servant because it doesn't just decode the--- request body from some format but also performs IO in the case--- of writing the uploaded files to disk, e.g in @/tmp@, which is--- not compatible with servant's vision of a content type as things--- stand now. This also means that 'MultipartForm' can't be used in--- conjunction with 'ReqBody' in an endpoint.------ The 'tag' type parameter instructs the function to handle data--- either as data to be saved to temporary storage ('Tmp') or saved to--- memory ('Mem').------ The 'a' type parameter represents the Haskell type to which--- you are going to decode the multipart data to, where the--- multipart data consists in all the usual form inputs along--- with the files sent along through @\<input type="file"\>@--- fields in the form.------ One option provided out of the box by this library is to decode--- to 'MultipartData'.------ Example:------ @--- type API = MultipartForm Tmp (MultipartData Tmp) :> Post '[PlainText] String------ api :: Proxy API--- api = Proxy------ server :: MultipartData Tmp -> Handler String--- server multipartData = return str------ where str = "The form was submitted with "--- ++ show nInputs ++ " textual inputs and "--- ++ show nFiles ++ " files."--- nInputs = length (inputs multipartData)--- nFiles = length (files multipartData)--- @------ You can alternatively provide a 'FromMultipart' instance--- for some type of yours, allowing you to regroup data--- into a structured form and potentially selecting--- a subset of the entire form data that was submitted.------ Example, where we only look extract one input, /username/,--- and one file, where the corresponding input field's /name/--- attribute was set to /pic/:------ @--- data User = User { username :: Text, pic :: FilePath }------ instance FromMultipart Tmp User where--- fromMultipart multipartData =--- User \<$\> lookupInput "username" multipartData--- \<*\> fmap fdPayload (lookupFile "pic" multipartData)------ type API = MultipartForm Tmp User :> Post '[PlainText] String------ server :: User -> Handler String--- server usr = return str------ where str = username usr ++ "'s profile picture"--- ++ " got temporarily uploaded to "--- ++ pic usr ++ " and will be removed from there "--- ++ " after this handler has run."--- @------ Note that the behavior of this combinator is configurable,--- by using 'serveWith' from servant-server instead of 'serve',--- which takes an additional 'Context' argument. It simply is an--- heterogeneous list where you can for example store--- a value of type 'MultipartOptions' that has the configuration that--- you want, which would then get picked up by servant-multipart.------ __Important__: as mentionned in the example above,--- the file paths point to temporary files which get removed--- 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.-type MultipartForm tag a = MultipartForm' '[] tag a---- | 'MultipartForm' which can be modified with 'Servant.API.Modifiers.Lenient'.-data MultipartForm' (mods :: [*]) tag a+-- | Lookup a textual input with the given @name@ attribute.+lookupInput :: Text -> MultipartData tag -> Either String Text+lookupInput iname =+ maybe (Left $ "Field " <> cs iname <> " not found") (Right . iValue)+ . find ((==iname) . iName)+ . inputs --- | What servant gets out of a @multipart/form-data@ form submission.------ The type parameter 'tag' tells if 'MultipartData' is stored as a--- temporary file or stored in memory. 'tag' is type of either 'Mem'--- or 'Tmp'.------ The 'inputs' field contains a list of textual 'Input's, where--- each input for which a value is provided gets to be in this list,--- represented by the input name and the input value. See haddocks for--- 'Input'.------ The 'files' field contains a list of files that were sent along with the--- other inputs in the form. Each file is represented by a value of type--- 'FileData' which among other things contains the path to the temporary file--- (to be removed when your handler is done running) with a given uploaded--- file's content. See haddocks for 'FileData'.-data MultipartData tag = MultipartData- { inputs :: [Input]- , files :: [FileData tag]- }+-- | Lookup a file input with the given @name@ attribute.+lookupFile :: Text -> MultipartData tag -> Either String (FileData tag)+lookupFile iname =+ maybe (Left $ "File " <> cs iname <> " not found") Right+ . find ((==iname) . fdInputName)+ . files fromRaw :: forall tag. ([Network.Wai.Parse.Param], [File (MultipartResult tag)]) -> MultipartData tag@@ -195,96 +91,18 @@ dec = decodeUtf8 --- | Representation for an uploaded file, usually resulting from--- picking a local file for an HTML input that looks like--- @\<input type="file" name="somefile" /\>@.-data FileData tag = FileData- { fdInputName :: Text -- ^ @name@ attribute of the corresponding- -- HTML @\<input\>@- , fdFileName :: Text -- ^ name of the file on the client's disk- , fdFileCType :: Text -- ^ MIME type for the file- , fdPayload :: MultipartResult tag- -- ^ path to the temporary file that has the- -- content of the user's original file. Only- -- valid during the execution of your handler as- -- it gets removed right after, which means you- -- really want to move or copy it in your handler.- }--deriving instance Eq (MultipartResult tag) => Eq (FileData tag)-deriving instance Show (MultipartResult tag) => Show (FileData tag)---- | Lookup a file input with the given @name@ attribute.-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@).------ @\<input name="foo" value="bar"\ />@ would appear as @'Input' "foo" "bar"@.-data Input = Input- { iName :: Text -- ^ @name@ attribute of the input- , iValue :: Text -- ^ value given for that input- } deriving (Eq, Show)---- | Lookup a textual input with the given @name@ attribute.-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--- you may instead want to work with a more structured type--- of yours that potentially selects only a fraction of--- the data that was submitted, or just reshapes it to make--- it easier to work with. The 'FromMultipart' class is exactly--- what allows you to tell servant how to turn "raw" multipart--- data into a value of your nicer type.------ @--- data User = User { username :: Text, pic :: FilePath }------ instance FromMultipart Tmp User where--- fromMultipart form =--- User \<$\> lookupInput "username" (inputs form)--- \<*\> fmap fdPayload (lookupFile "pic" $ files form)--- @-class FromMultipart tag a where- -- | Given a value of type 'MultipartData', which consists- -- 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 -> Either String a--instance FromMultipart tag (MultipartData tag) where- fromMultipart = Right+class MultipartBackend tag where+ type MultipartBackendOptions tag :: * --- | Allows you to tell servant how to turn a more structured type--- into a 'MultipartData', which is what is actually sent by the--- client.------ @--- data User = User { username :: Text, pic :: FilePath }------ instance toMultipart Tmp User where--- toMultipart user = MultipartData [Input "username" $ username user]--- [FileData "pic"--- (pic user)--- "image/png"--- (pic user)--- ]--- @-class ToMultipart tag a where- -- | Given a value of type 'a', convert it to a- -- 'MultipartData'.- toMultipart :: a -> MultipartData tag+ backend :: Proxy tag+ -> MultipartBackendOptions tag+ -> InternalState+ -> ignored1+ -> ignored2+ -> IO SBS.ByteString+ -> IO (MultipartResult tag) -instance ToMultipart tag (MultipartData tag) where- toMultipart = id+ defaultBackendOptions :: Proxy tag -> MultipartBackendOptions tag -- | Upon seeing @MultipartForm a :> ...@ in an API type, --- servant-server will hand a value of type @a@ to your handler@@ -317,106 +135,6 @@ $ lookupContext popts config subserver' = addMultipartHandling @tag @a @mods @config pbak multipartOpts config 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' mods tag a :> api) where-- type Client m (MultipartForm' mods tag a :> api) =- (LBS.ByteString, a) -> Client m api-- clientWithRoute pm _ req (boundary, param) =- clientWithRoute pm (Proxy @api) $ setRequestBody newBody newMedia req- where- newBody = multipartToBody boundary $ toMultipart @tag param- newMedia = "multipart" // "form-data" /: ("boundary", LBS.toStrict boundary)-- hoistClientMonad pm _ f cl = \a ->- hoistClientMonad pm (Proxy @api) f (cl a)---- | Generates a boundary to be used to separate parts of the multipart.--- Requires 'IO' because it is randomized.-genBoundary :: IO LBS.ByteString-genBoundary = LBS.pack- . map (validChars !)- <$> indices- where- -- the standard allows up to 70 chars, but most implementations seem to be- -- in the range of 40-60, so we pick 55- indices = replicateM 55 . getStdRandom $ randomR (0,61)- -- Following Chromium on this one:- -- > The RFC 2046 spec says the alphanumeric characters plus the- -- > following characters are legal for boundaries: '()+_,-./:=?- -- > However the following characters, though legal, cause some sites- -- > to fail: (),./:=+- -- https://github.com/chromium/chromium/blob/6efa1184771ace08f3e2162b0255c93526d1750d/net/base/mime_util.cc#L662-L670- validChars = listArray (0 :: Int, 61)- -- 0-9- [ 0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37- , 0x38, 0x39, 0x41, 0x42- -- A-Z, a-z- , 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49, 0x4a- , 0x4b, 0x4c, 0x4d, 0x4e, 0x4f, 0x50, 0x51, 0x52- , 0x53, 0x54, 0x55, 0x56, 0x57, 0x58, 0x59, 0x5a- , 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68- , 0x69, 0x6a, 0x6b, 0x6c, 0x6d, 0x6e, 0x6f, 0x70- , 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78- , 0x79, 0x7a- ]---- | Given a bytestring for the boundary, turns a `MultipartData` into--- a 'RequestBody'-multipartToBody :: forall tag.- MultipartBackend tag- => LBS.ByteString- -> MultipartData tag- -> RequestBody-multipartToBody boundary mp = RequestBodySource $ files' <> source ["--", boundary, "--"]- where- -- at time of writing no Semigroup or Monoid instance exists for SourceT and StepT- -- in releases of Servant; they are in master though- (SourceT l) `mappend'` (SourceT r) = SourceT $ \k ->- l $ \lstep ->- r $ \rstep ->- k (appendStep lstep rstep)- appendStep Stop r = r- appendStep (Error err) _ = Error err- appendStep (Skip s) r = appendStep s r- appendStep (Yield x s) r = Yield x (appendStep s r)- appendStep (Effect ms) r = Effect $ (flip appendStep r <$> ms)- mempty' = SourceT ($ Stop)- crlf = "\r\n"- lencode = LBS.fromStrict . encodeUtf8- renderInput input = renderPart (lencode . iName $ input)- "text/plain"- ""- (source . pure . lencode . iValue $ input)- inputs' = foldl' (\acc x -> acc `mappend'` renderInput x) mempty' (inputs mp)- renderFile :: FileData tag -> SourceIO LBS.ByteString- renderFile file = renderPart (lencode . fdInputName $ file)- (lencode . fdFileCType $ file)- ((flip mappend) "\"" . mappend "; filename=\""- . lencode- . fdFileName $ file)- (loadFile (Proxy @tag) . fdPayload $ file)- files' = foldl' (\acc x -> acc `mappend'` renderFile x) inputs' (files mp)- renderPart name contentType extraParams payload =- source [ "--"- , boundary- , crlf- , "Content-Disposition: form-data; name=\""- , name- , "\""- , extraParams- , crlf- , "Content-Type: "- , contentType- , crlf- , crlf- ] `mappend'` payload `mappend'` source [crlf]- -- Try and extract the request body as multipart/form-data, -- returning the data as well as the resourcet InternalState -- that allows us to properly clean up the temporary files@@ -511,50 +229,18 @@ , backendOptions :: MultipartBackendOptions tag } -class MultipartBackend tag where- type MultipartResult tag :: *- type MultipartBackendOptions tag :: *-- backend :: Proxy tag- -> MultipartBackendOptions tag- -> InternalState- -> ignored1- -> ignored2- -> IO SBS.ByteString- -> IO (MultipartResult tag)-- loadFile :: Proxy tag -> MultipartResult tag -> SourceIO LBS.ByteString-- defaultBackendOptions :: Proxy tag -> MultipartBackendOptions tag---- | Tag for data stored as a temporary file-data Tmp---- | Tag for data stored in memory-data Mem- instance MultipartBackend Tmp where- type MultipartResult Tmp = FilePath type MultipartBackendOptions Tmp = TmpBackendOptions defaultBackendOptions _ = defaultTmpBackendOptions- -- streams the file from disk- loadFile _ fp =- SourceT $ \k ->- withFile fp ReadMode $ \hdl ->- k (readHandle hdl)- where- readHandle hdl = fromActionStep LBS.null (LBS.hGet hdl 4096) backend _ opts = tmpBackend where tmpBackend = tempFileBackEndOpts (getTmpDir opts) (filenamePat opts) instance MultipartBackend Mem where- type MultipartResult Mem = LBS.ByteString type MultipartBackendOptions Mem = () defaultBackendOptions _ = ()- loadFile _ = source . pure backend _ _ _ = lbsBackEnd -- | Configuration for the temporary file based backend.@@ -606,15 +292,6 @@ LookupContext cs a => LookupContext (a ': cs) a where lookupContext _ (c :. _) = Just c -instance HasLink sub => HasLink (MultipartForm tag a :> sub) where-#if MIN_VERSION_servant(0,14,0)- type MkLink (MultipartForm tag a :> sub) r = MkLink sub r- toLink toA _ = toLink toA (Proxy :: Proxy sub)-#else- type MkLink (MultipartForm tag a :> sub) = MkLink sub- toLink _ = toLink (Proxy :: Proxy sub)-#endif- -- | The 'ToMultipartSample' class allows you to create sample 'MultipartData' -- inputs for your type for use with "Servant.Docs". This is used by the -- 'HasDocs' instance for 'MultipartForm'.@@ -683,8 +360,8 @@ toMultipartNotes maxSamples' proxyTag proxyA = let sampleLines = take maxSamples' $ toMultipartDescriptions proxyTag proxyA body =- [ "This endpoint takes `multipart/form-data` requests. The following is " <>- "a list of sample requests:"+ [ "This endpoint takes `multipart/form-data` requests. " <>+ "The following is a list of sample requests:" , foldMap (<> "\n") sampleLines ] in DocNote "Multipart Request Samples" $ fmap unpack body