servant-multipart 0.10.0.1 → 0.11

raw patch · 4 files changed

+244/−71 lines, 4 filesdep +lensdep +servant-docsdep ~bytestringdep ~resourcetdep ~servantPVP ok

version bump matches the API change (PVP)

Dependencies added: lens, servant-docs

Dependency ranges changed: bytestring, resourcet, servant, servant-server

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• exe/Upload.hs +5/−4
• servant-multipart.cabal +11/−6
• src/Servant/Multipart.hs +218/−61

@@ -0,0 +1,10 @@+0.11+----++- Support `servant-0.12`+- Add support for memory backend++0.10+----++- Initial release

@@ -14,10 +14,12 @@ import Servant import Servant.Multipart +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 MultipartData :> Post '[JSON] Integer+type API = MultipartForm Mem (MultipartData Mem) :> Post '[JSON] Integer  api :: Proxy API api = Proxy@@ -38,10 +40,9 @@             ++ " -> " ++ show (iValue input)      forM_ (files multipartData) $ \file -> do-      content <- readFile (fdFilePath file)+      let content = fdPayload file       putStrLn $ "Content of " ++ show (fdFileName file)-              ++ " at " ++ fdFilePath file-      putStrLn content+      LBS.putStr content   return 0  startServer :: IO ()

@@ -1,5 +1,5 @@ name:                servant-multipart-version:             0.10.0.1+version:             0.11 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@@ -8,13 +8,15 @@ author:              Alp Mestanogullari maintainer:          alpmestan@gmail.com copyright:           2016-2017 Alp Mestanogullari-category:            Web+category:            Web, Servant build-type:          Simple cabal-version:       >=1.10+extra-source-files:  CHANGELOG.md tested-with:   GHC==7.8.4,   GHC==7.10.3,-  GHC==8.0.2+  GHC==8.0.2,+  GHC==8.2.1  library   hs-source-dirs:      src@@ -23,10 +25,12 @@                 base >= 4.7 && < 5,                 bytestring >= 0.10 && <0.11,                 directory,-                http-media >= 0.6 && <0.7,+                http-media >= 0.6 && <0.8,+                lens >= 4.0 && < 4.16,                 resourcet >=1.1 && <1.2,-                servant >=0.10 && <0.12,-                servant-server >=0.10 && <0.12,+                servant >=0.10 && <0.13,+                servant-docs >=0.10 && <0.13,+                servant-server >=0.10 && <0.13,                 text >=1.2 && <1.3,                 transformers >=0.3 && <0.6,                 wai >= 3.2 && <3.3,@@ -40,6 +44,7 @@   build-depends:                 base,                 http-client,+                bytestring,                 network,                 servant,                 servant-multipart,

@@ -1,5 +1,7 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleContexts #-}@@ -8,6 +10,8 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-} -- | @multipart/form-data@ support for servant. -- --   This is mostly useful for adding file upload support to@@ -20,26 +24,33 @@   , lookupFile   , MultipartOptions(..)   , defaultMultipartOptions-  , TmpBackendOptions(..)+  , Tmp+  , Mem   , defaultTmpBackendOptions   , Input(..)   , FileData(..)+  -- * servant-docs+  , ToMultipartSample(..)   ) where +import Control.Lens ((<>~), (&), view) import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Resource import Data.ByteString.Lazy (ByteString)+import Data.Foldable (foldMap) import Data.Function import Data.List (find) import Data.Maybe-import Data.Text (Text)+import Data.Monoid+import Data.Text (Text, unpack) import Data.Text.Encoding (decodeUtf8) import Data.Typeable import Network.HTTP.Media ((//)) import Network.Wai import Network.Wai.Parse import Servant+import Servant.Docs import Servant.Server.Internal import System.Directory import System.IO@@ -58,6 +69,10 @@ --   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@@ -70,12 +85,12 @@ --   Example: -- --   @---   type API = MultipartForm MultipartData :> Post '[PlainText] String+--   type API = MultipartForm Tmp (MultipartData Tmp) :> Post '[PlainText] String -- --   api :: Proxy API --   api = Proxy -----   server :: MultipartData -> Handler String+--   server :: MultipartData Tmp -> Handler String --   server multipartData = return str -- --     where str = "The form was submitted with "@@ -97,12 +112,12 @@ --   @ --   data User = User { username :: Text, pic :: FilePath } -----   instance FromMultipart User where+--   instance FromMultipart Tmp User where --     fromMultipart multipartData = --       User \<$\> lookupInput "username" multipartData---            \<*\> fmap fileContent (lookupFile "pic" multipartData)+--            \<*\> fmap fdPayload (lookupFile "pic" multipartData) -----   type API = MultipartForm User :> Post '[PlainText] String+--   type API = MultipartForm Tmp User :> Post '[PlainText] String -- --   server :: User -> Handler String --   server usr = return str@@ -125,10 +140,14 @@ --   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+data MultipartForm tag a  -- | 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@@ -139,20 +158,19 @@ --   '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+data MultipartData tag = MultipartData   { inputs :: [Input]-  , files  :: [FileData]+  , files  :: [FileData tag]   } --- TODO: this is specific to Tmp. we need a version that--- can handle Mem as well.-fromRaw :: ([Network.Wai.Parse.Param], [File FilePath]) -> MultipartData+fromRaw :: forall tag. ([Network.Wai.Parse.Param], [File (MultipartResult tag)])+        -> MultipartData tag 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 :: File (MultipartResult tag) -> FileData tag         toFile (iname, fileinfo) =           FileData (dec iname)                    (dec $ fileName fileinfo)@@ -164,20 +182,24 @@ -- | 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 = FileData+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-  , fdFilePath  :: FilePath -- ^ path to the temporary file that has the+  , 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 (Eq, Show)+  } +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 -> Maybe FileData+lookupFile :: Text -> MultipartData tag -> Maybe (FileData tag) lookupFile iname = find ((==iname) . fdInputName) . files  -- | Representation for a textual input (any @\<input\>@ type but @file@).@@ -189,7 +211,7 @@   } deriving (Eq, Show)  -- | Lookup a textual input with the given @name@ attribute.-lookupInput :: Text -> MultipartData -> Maybe Text+lookupInput :: Text -> MultipartData tag -> Maybe Text lookupInput iname = fmap iValue . find ((==iname) . iName) . inputs  -- | 'MultipartData' is the type representing@@ -204,67 +226,80 @@ --   @ --   data User = User { username :: Text, pic :: FilePath } -----   instance FromMultipart User where+--   instance FromMultipart Tmp User where --     fromMultipart form = --       User \<$\> lookupInput "username" (inputs form)---            \<*\> fmap fdFilePath (lookupFile "pic" $ files form)+--            \<*\> fmap fdPayload (lookupFile "pic" $ files form) --   @-class FromMultipart a where+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 -> Maybe a+  fromMultipart :: MultipartData tag -> Maybe a -instance FromMultipart MultipartData where+instance FromMultipart tag (MultipartData tag) 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+instance ( FromMultipart tag a+         , MultipartBackend tag+         , LookupContext config (MultipartOptions tag)          , HasServer sublayout config )-      => HasServer (MultipartForm a :> sublayout) config where+      => HasServer (MultipartForm tag a :> sublayout) config where -  type ServerT (MultipartForm a :> sublayout) m =+  type ServerT (MultipartForm tag a :> sublayout) m =     a -> ServerT sublayout m +#if MIN_VERSION_servant_server(0,12,0)+  hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy sublayout) pc nt . s+#endif+   route Proxy config subserver =     route psub config subserver'     where       psub  = Proxy :: Proxy sublayout       pbak  = Proxy :: Proxy b-      popts = Proxy :: Proxy MultipartOptions-      multipartOpts = fromMaybe defaultMultipartOptions+      popts = Proxy :: Proxy (MultipartOptions tag)+      multipartOpts = fromMaybe (defaultMultipartOptions pbak)                     $ lookupContext popts config-      subserver' = addMultipartHandling multipartOpts subserver+      subserver' = addMultipartHandling pbak 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+check :: MultipartBackend tag+      => Proxy tag+      -> MultipartOptions tag+      -> DelayedIO (MultipartData tag)+check pTag tag = withRequest $ \request -> do   st <- liftResourceT getInternalState-  rawData <- liftIO $ parseRequestBodyEx parseOpts (tmpBackend opts st) request+  rawData <- liftIO+      $ parseRequestBodyEx+          parseOpts+          (backend pTag (backendOptions tag) st)+          request   return (fromRaw rawData)-  where parseOpts = generalOptions opts+  where parseOpts = generalOptions tag  -- Add multipart extraction support to a Delayed.-addMultipartHandling :: FromMultipart multipart-                     => MultipartOptions+addMultipartHandling :: forall tag multipart env a. (FromMultipart tag multipart, MultipartBackend tag)+                     => Proxy tag+                     -> MultipartOptions tag                      -> Delayed env (multipart -> a)                      -> Delayed env a-addMultipartHandling opts subserver =+addMultipartHandling pTag opts subserver =   addBodyCheck subserver contentCheck bodyCheck   where     contentCheck = withRequest $ \request ->       fuzzyMultipartCTCheck (contentTypeH request)      bodyCheck () = do-      mpd <- check opts :: DelayedIO MultipartData+      mpd <- check pTag opts :: DelayedIO (MultipartData tag)       case fromMultipart mpd of         Nothing -> liftRouteResult $ FailFatal           err400 { errBody = "fromMultipart returned Nothing" }@@ -289,31 +324,60 @@           "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+--   'backendOptions' lets you configure aspects specific to the chosen+--   backend. Note: there isn't anything to tweak in a memory+--   backend ('Mem'). Maximum file size etc. options are in+--   'ParseRequestBodyOptions'.+--+--   See haddocks for 'ParseRequestBodyOptions' and+--   'TmpBackendOptions' respectively for more information on+--   what you can tweak.+data MultipartOptions tag = MultipartOptions+  { generalOptions        :: ParseRequestBodyOptions+  , 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)++    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+    backend _ opts = tmpBackend+      where+        tmpBackend = tempFileBackEndOpts (getTmpDir opts) (filenamePat opts)++instance MultipartBackend Mem where+    type MultipartResult Mem = LBS.ByteString+    type MultipartBackendOptions Mem = ()++    defaultBackendOptions _ = ()+    backend _ opts _ = lbsBackEnd+ -- | Configuration for the temporary file based backend. -- --   You can configure the way servant-multipart gets its hands@@ -337,11 +401,11 @@ -- | Default configuration for multipart handling. -- --   Uses 'defaultParseRequestBodyOptions' and---   'defaultTmpBackendOptions' respectively.-defaultMultipartOptions :: MultipartOptions-defaultMultipartOptions = MultipartOptions+--   'defaultBackendOptions' respectively.+defaultMultipartOptions :: MultipartBackend tag => Proxy tag -> MultipartOptions tag+defaultMultipartOptions pTag = MultipartOptions   { generalOptions = defaultParseRequestBodyOptions-  , tmpOptions = defaultTmpBackendOptions+  , backendOptions = defaultBackendOptions pTag   }  -- Utility class that's like HasContextEntry@@ -366,3 +430,96 @@ instance HasLink sub => HasLink (MultipartForm a :> sub) where   type MkLink (MultipartForm a :> sub) = MkLink sub   toLink _ = toLink (Proxy :: Proxy sub)++-- | 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'.+--+-- Given the example 'User' type and 'FromMultipart' instance above, here is a+-- corresponding 'ToMultipartSample' instance:+--+-- @+--   data User = User { username :: Text, pic :: FilePath }+--+--   instance 'ToMultipartSample' 'Tmp' User where+--     'toMultipartSamples' proxy =+--       [ ( \"sample 1\"+--         , 'MultipartData'+--             [ 'Input' \"username\" \"Elvis Presley\" ]+--             [ 'FileData'+--                 \"pic\"+--                 \"playing_guitar.jpeg\"+--                 \"image/jpeg\"+--                 \"/tmp/servant-multipart000.buf\"+--             ]+--         )+--       ]+-- @+class ToMultipartSample tag a where+  toMultipartSamples :: Proxy a -> [(Text, MultipartData tag)]++-- | Format an 'Input' into a markdown list item.+multipartInputToItem :: Input -> Text+multipartInputToItem (Input name val) =+  "        - *" <> name <> "*: " <> "`" <> val <> "`"++-- | Format a 'FileData' into a markdown list item.+multipartFileToItem :: FileData tag -> Text+multipartFileToItem (FileData name _ contentType _) =+  "        - *" <> name <> "*, content-type: " <> "`" <> contentType <> "`"++-- | Format a description and a sample 'MultipartData' into a markdown list+-- item.+multipartSampleToDesc+  :: Text -- ^ The description for the sample.+  -> MultipartData tag -- ^ The sample 'MultipartData'.+  -> Text -- ^ A markdown list item.+multipartSampleToDesc desc (MultipartData inputs files) =+  "- " <> desc <> "\n" <>+  "    - textual inputs (any `<input>` type but file):\n" <>+  foldMap (\input -> multipartInputToItem input <> "\n") inputs <>+  "    - file inputs (any HTML input that looks like `<input type=\"file\" name=\"somefile\" />`):\n" <>+  foldMap (\file -> multipartFileToItem file <> "\n") files++-- | Format a list of samples generated with 'ToMultipartSample' into sections+-- of markdown.+toMultipartDescriptions+  :: forall tag a.+     ToMultipartSample tag a+  => Proxy tag -> Proxy a -> [Text]+toMultipartDescriptions _ proxyA = fmap (uncurry multipartSampleToDesc) samples+  where+    samples :: [(Text, MultipartData tag)]+    samples = toMultipartSamples proxyA++-- | Create a 'DocNote' that represents samples for this multipart input.+toMultipartNotes+  :: ToMultipartSample tag a+  => Int -> Proxy tag -> Proxy a -> DocNote+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:"+        , foldMap (<> "\n") sampleLines+        ]+  in DocNote "Multipart Request Samples" $ fmap unpack body++-- | Declare an instance of 'ToMultipartSample' for your 'MultipartForm' type+-- to be able to use this 'HasDocs' instance.+instance (HasDocs api, ToMultipartSample tag a) => HasDocs (MultipartForm tag a :> api) where+  docsFor+    :: Proxy (MultipartForm tag a :> api)+    -> (Endpoint, Action)+    -> DocOptions+    -> API+  docsFor _ (endpoint, action) opts =+    let newAction =+          action+            & notes <>~+                [ toMultipartNotes+                    (view maxSamples opts)+                    (Proxy :: Proxy tag)+                    (Proxy :: Proxy a)+                ]+    in docsFor (Proxy :: Proxy api) (endpoint, newAction) opts