diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Alp Mestanogullari (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Alp Mestanogullari nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/exe/Upload.hs b/exe/Upload.hs new file mode 100644 --- /dev/null +++ b/exe/Upload.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} + +import Control.Concurrent +import Control.Monad +import Control.Monad.IO.Class +import Data.Text.Encoding (encodeUtf8) +import Network (withSocketsDo) +import Network.HTTP.Client hiding (Proxy) +import Network.HTTP.Client.MultipartFormData +import Network.Wai +import Network.Wai.Handler.Warp +import Servant +import Servant.Multipart + +-- 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 MultipartData :> Post '[JSON] Integer + +api :: Proxy API +api = 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 + content <- readFile (fdFilePath file) + putStrLn $ "Content of " ++ show (fdFileName file) + ++ " at " ++ fdFilePath file + putStrLn content + return 0 + +startServer :: IO () +startServer = run 8080 (serve api upload) + +main :: IO () +main = 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 + req <- parseRequest "http://localhost:8080/" + resp <- flip httpLbs manager =<< formDataBody form req + print resp + + where form = + [ partBS "title" "World" + , partBS "text" $ encodeUtf8 "Hello" + , partFileSource "file" "./servant-multipart.cabal" + , partFileSource "otherfile" "./Setup.hs" + ] diff --git a/servant-multipart.cabal b/servant-multipart.cabal new file mode 100644 --- /dev/null +++ b/servant-multipart.cabal @@ -0,0 +1,54 @@ +name: servant-multipart +version: 0.10 +synopsis: multipart/form-data (e.g file upload) support for servant +description: Please see README.md +homepage: https://github.com/haskell-servant/servant-multipart#readme +license: BSD3 +license-file: LICENSE +author: Alp Mestanogullari +maintainer: alpmestan@gmail.com +copyright: 2016-2017 Alp Mestanogullari +category: Web +build-type: Simple +cabal-version: >=1.10 +tested-with: + GHC==7.8.4, + GHC==7.10.3, + GHC==8.0.2 + +library + hs-source-dirs: src + exposed-modules: Servant.Multipart + build-depends: + base >= 4.7 && < 5, + bytestring >= 0.10 && <0.11, + directory, + http-media >= 0.6 && <0.7, + resourcet >=1.1 && <1.2, + servant >=0.10 && <0.11, + servant-server >=0.10 && <0.11, + text >=1.2 && <1.3, + transformers >=0.3 && <0.6, + wai >= 3.2 && <3.3, + wai-extra >=3.0 && <3.1 + default-language: Haskell2010 + +executable upload + hs-source-dirs: exe + main-is: Upload.hs + default-language: Haskell2010 + build-depends: + base, + http-client, + network, + servant, + servant-multipart, + servant-server, + text, + transformers, + warp, + wai + +source-repository head + type: git + location: https://github.com/haskell-servent/servant-multipart diff --git a/src/Servant/Multipart.hs b/src/Servant/Multipart.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Multipart.hs @@ -0,0 +1,364 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +-- | @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. +module Servant.Multipart + ( MultipartForm + , MultipartData(..) + , FromMultipart(..) + , lookupInput + , lookupFile + , MultipartOptions(..) + , defaultMultipartOptions + , TmpBackendOptions(..) + , defaultTmpBackendOptions + , Input(..) + , FileData(..) + ) where + +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import Data.ByteString.Lazy (ByteString) +import Data.Function +import Data.List (find) +import Data.Maybe +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8) +import Data.Typeable +import Network.HTTP.Media ((//)) +import Network.Wai +import Network.Wai.Parse +import Servant +import Servant.Server.Internal +import System.Directory +import System.IO + +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 '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 MultipartData :> Post '[PlainText] String +-- +-- api :: Proxy API +-- api = Proxy +-- +-- server :: MultipartData -> 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 User where +-- fromMultipart multipartData = +-- User \<$\> lookupInput "username" multipartData +-- \<*\> fmap fileContent (lookupFile "pic" multipartData) +-- +-- type API = MultipartForm 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. +data MultipartForm a + +-- | What servant gets out of a @multipart/form-data@ form submission. +-- +-- 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 = MultipartData + { inputs :: [Input] + , files :: [FileData] + } + +-- TODO: this is specific to Tmp. we need a version that +-- can handle Mem as well. +fromRaw :: ([Param], [File FilePath]) -> MultipartData +fromRaw (inputs, files) = MultipartData is fs + + where is = map (\(name, val) -> Input (dec name) (dec val)) inputs + fs = map toFile files + + toFile :: File FilePath -> FileData + toFile (iname, fileinfo) = + FileData (dec iname) + (dec $ fileName fileinfo) + (dec $ fileContentType fileinfo) + (fileContent fileinfo) + + dec = decodeUtf8 + +-- | Representation for an uploaded file, usually resulting from +-- picking a local file for an HTML input that looks like +-- @\@. +data FileData = 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 + , fdFilePath :: FilePath -- ^ 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 (Eq, Show) + +-- | Lookup a file input with the given @name@ attribute. +lookupFile :: Text -> MultipartData -> Maybe FileData +lookupFile iname = 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 -> Maybe Text +lookupInput iname = fmap 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 User where +-- fromMultipart form = +-- User \<$\> lookupInput "username" (inputs form) +-- \<*\> fmap fdFilePath (lookupFile "pic" $ files form) +-- @ +class FromMultipart 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 -> Maybe a + +instance FromMultipart MultipartData where + fromMultipart = Just + +-- | 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. +instance ( FromMultipart a + , LookupContext config MultipartOptions + , HasServer sublayout config ) + => HasServer (MultipartForm a :> sublayout) config where + + type ServerT (MultipartForm a :> sublayout) m = + a -> ServerT sublayout m + + route Proxy config subserver = + route psub config subserver' + where + psub = Proxy :: Proxy sublayout + pbak = Proxy :: Proxy b + popts = Proxy :: Proxy MultipartOptions + multipartOpts = fromMaybe defaultMultipartOptions + $ lookupContext popts config + subserver' = addMultipartHandling multipartOpts subserver + +-- 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 +-- later on. +check :: MultipartOptions -> DelayedIO MultipartData +check opts = withRequest $ \request -> do + st <- liftResourceT getInternalState + rawData <- liftIO $ parseRequestBodyEx parseOpts (tmpBackend opts st) request + return (fromRaw rawData) + where parseOpts = generalOptions opts + +-- Add multipart extraction support to a Delayed. +addMultipartHandling :: FromMultipart multipart + => MultipartOptions + -> Delayed env (multipart -> a) + -> Delayed env a +addMultipartHandling opts subserver = + addBodyCheck subserver contentCheck bodyCheck + where + contentCheck = withRequest $ \request -> + fuzzyMultipartCTCheck (contentTypeH request) + + bodyCheck () = do + mpd <- check opts :: DelayedIO MultipartData + case fromMultipart mpd of + Nothing -> liftRouteResult $ FailFatal + err400 { errBody = "fromMultipart returned Nothing" } + Just x -> return x + + contentTypeH req = fromMaybe "application/octet-stream" $ + lookup "Content-Type" (requestHeaders req) + +-- Check that the content type is one of: +-- - application/x-www-form-urlencoded +-- - multipart/form-data; boundary=something +fuzzyMultipartCTCheck :: SBS.ByteString -> DelayedIO () +fuzzyMultipartCTCheck ct + | ctMatches = return () + | otherwise = delayedFailFatal err400 { + errBody = "The content type of the request body is not in application/x-www-form-urlencoded or multipart/form-data" + } + + where (ctype, attrs) = parseContentType ct + ctMatches = case ctype of + "application/x-www-form-urlencoded" -> True + "multipart/form-data" | Just _bound <- lookup "boundary" attrs -> True + _ -> False + +tmpBackend :: MultipartOptions + -> InternalState + -> ignored1 + -> ignored2 + -> IO SBS.ByteString + -> IO FilePath +tmpBackend opts = + tempFileBackEndOpts (getTmpDir tmpOpts) (filenamePat tmpOpts) + where + tmpOpts = tmpOptions opts + +-- | Global options for configuring how the +-- server should handle multipart data. +-- +-- 'generalOptions' lets you specify mostly multipart parsing +-- related options, such as the maximum file size, while +-- 'tmpOptions' lets you configure aspects specific to +-- the temporary file backend. See haddocks for +-- 'ParseRequestBodyOptions' and 'TmpBackendOptions' respectively +-- for more information on what you can tweak. +data MultipartOptions = MultipartOptions + { generalOptions :: ParseRequestBodyOptions + , tmpOptions :: TmpBackendOptions + } + +-- | Configuration for the temporary file based backend. +-- +-- You can configure the way servant-multipart gets its hands +-- on a temporary directory (defaults to 'getTemporaryDirectory') +-- as well as the filename pattern used for generating the temporary files +-- (defaults to calling them /servant-multipartXXX.buf/, where /XXX/ is some +-- random number). +data TmpBackendOptions = TmpBackendOptions + { getTmpDir :: IO FilePath + , filenamePat :: String + } + +-- | Default options for the temporary file backend: +-- 'getTemporaryDirectory' and "servant-multipart.buf" +defaultTmpBackendOptions :: TmpBackendOptions +defaultTmpBackendOptions = TmpBackendOptions + { getTmpDir = getTemporaryDirectory + , filenamePat = "servant-multipart.buf" + } + +-- | Default configuration for multipart handling. +-- +-- Uses 'defaultParseRequestBodyOptions' and +-- 'defaultTmpBackendOptions' respectively. +defaultMultipartOptions :: MultipartOptions +defaultMultipartOptions = MultipartOptions + { generalOptions = defaultParseRequestBodyOptions + , tmpOptions = defaultTmpBackendOptions + } + +-- Utility class that's like HasContextEntry +-- but allows the lookup to fail, to make a context +-- entry for upload config optional (hence using +-- some default configuration when missing) +class LookupContext ctx a where + lookupContext :: Proxy a -> Context ctx -> Maybe a + +instance LookupContext '[] a where + lookupContext _ _ = Nothing + +instance {-# OVERLAPPABLE #-} + LookupContext cs a => LookupContext (c ': cs) a where + lookupContext p (c :. cs) = + lookupContext p cs + +instance {-# OVERLAPPING #-} + LookupContext cs a => LookupContext (a ': cs) a where + lookupContext _ (c :. _) = Just c