diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ---- diff --git a/exe/Upload.hs b/exe/Upload.hs deleted file mode 100644 --- a/exe/Upload.hs +++ /dev/null @@ -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" - ] diff --git a/servant-multipart.cabal b/servant-multipart.cabal --- a/servant-multipart.cabal +++ b/servant-multipart.cabal @@ -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 diff --git a/src/Servant/Multipart.hs b/src/Servant/Multipart.hs --- a/src/Servant/Multipart.hs +++ b/src/Servant/Multipart.hs @@ -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 @\@. --- --- @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 @\@ --- 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 --- @\@. -data FileData tag = FileData - { fdInputName :: Text -- ^ @name@ attribute of the corresponding - -- HTML @\@ - , 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 @\@ type but @file@). --- --- @\@ 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