Move MultipartBackend class to server package

Author: maksbotan

servant-multipart-api/servant-multipart-api.cabal

@@ -33,8 +33,7 @@ library
 
   -- other dependencies
   build-depends:
-      resourcet           >=1.2.2    && <1.3
-    , servant             >=0.16     && <0.19
+      servant             >=0.16     && <0.19
 
 source-repository head
   type:     git

servant-multipart-api/src/Servant/Multipart/API.hs

@@ -24,19 +24,17 @@ module Servant.Multipart.API
   , MultipartData(..)
   , ToMultipart(..)
   , FromMultipart(..)
-  , MultipartBackend(..)
+  , MultipartResult
   , Tmp
   , Mem
   , Input(..)
   , FileData(..)
   ) where
 
-import Control.Monad.Trans.Resource
 import Data.Text (Text)
 import Data.Typeable
 import Servant.API
 
-import qualified Data.ByteString      as SBS
 import qualified Data.ByteString.Lazy as LBS
 
 -- | Combinator for specifying a @multipart/form-data@ request
@@ -224,28 +222,16 @@ class ToMultipart tag a where
 instance ToMultipart tag (MultipartData tag) where
   toMultipart = id
 
-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
 
+type family MultipartResult tag :: *
+type instance MultipartResult Tmp = FilePath
+type instance MultipartResult Mem = LBS.ByteString
+
 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

servant-multipart-client/exe/Upload.hs

@@ -3,20 +3,14 @@
 {-# 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 Data.Proxy
+import Network.HTTP.Client      hiding (Proxy)
+import Network.Socket           (withSocketsDo)
+import Servant.API
+import Servant.Client           (client, mkClientEnv, runClientM)
+import Servant.Client.Core      (BaseUrl (BaseUrl), Scheme (Http))
+import Servant.Multipart.API
 import Servant.Multipart.Client
-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
@@ -31,56 +25,22 @@ type family MemToTmp api where
   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"
+main = withSocketsDo $ do
+  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
 
   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"
+                             [ FileData "file" "./servant-multipart/servant-multipart.cabal"
+                                        "text/plain" "./servant-multipart/servant-multipart.cabal"
+                             , FileData "otherfile" "./servant-multipart/Setup.hs" "text/plain" "./servant-multipart/Setup.hs"
                              ]

servant-multipart-client/servant-multipart-client.cabal

@@ -45,13 +45,22 @@ executable upload
   default-language: Haskell2010
   build-depends:
       base
-    , bytestring
     , http-client
     , network            >=2.8 && <3.2
     , servant
-    , servant-multipart
+    , servant-multipart-api
     , servant-multipart-client
     , servant-client
     , servant-client-core
+
+executable server
+  hs-source-dirs:   exe
+  main-is:          Server.hs
+  default-language: Haskell2010
+  build-depends:
+      base
+    , bytestring
+    , network            >=2.8 && <3.2
+    , servant-multipart
     , servant-server
     , warp

servant-multipart-client/src/Servant/Multipart/Client.hs

@@ -32,21 +32,23 @@ import Data.List (foldl')
 #if !MIN_VERSION_base(4,11,0)
 import Data.Monoid ((<>))
 #endif
-import Data.Text.Encoding (encodeUtf8)
+import Data.Text.Encoding           (encodeUtf8)
 import Data.Typeable
 import Network.HTTP.Media.MediaType ((//), (/:))
 import Servant.API
-import Servant.Client.Core (HasClient(..), RequestBody(RequestBodySource), setRequestBody)
-import Servant.Types.SourceT (SourceT(..), StepT(..), source)
-import System.Random (getStdRandom, randomR)
+import Servant.Client.Core          (HasClient (..), RequestBody (RequestBodySource),
+                                     setRequestBody)
+import Servant.Types.SourceT        (SourceT (..), StepT (..), fromActionStep, source)
+import System.IO                    (IOMode (ReadMode), withFile)
+import System.Random                (getStdRandom, randomR)
 
 import qualified Data.ByteString.Lazy as LBS
 
 -- | 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)
+instance (ToMultipart tag a, HasClient m api, MultipartClient tag)
       => HasClient m (MultipartForm' mods tag a :> api) where
 
   type Client m (MultipartForm' mods tag a :> api) =
@@ -61,6 +63,21 @@ instance (ToMultipart tag a, HasClient m api, MultipartBackend tag)
   hoistClientMonad pm _ f cl = \a ->
       hoistClientMonad pm (Proxy @api) f (cl a)
 
+class MultipartClient tag where
+    loadFile :: Proxy tag -> MultipartResult tag -> SourceIO LBS.ByteString
+
+instance MultipartClient Tmp where
+    -- 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)
+
+instance MultipartClient Mem where
+    loadFile _ = source . pure
+
 -- | Generates a boundary to be used to separate parts of the multipart.
 -- Requires 'IO' because it is randomized.
 genBoundary :: IO LBS.ByteString
@@ -93,8 +110,8 @@ genBoundary = LBS.pack
 
 -- | Given a bytestring for the boundary, turns a `MultipartData` into
 -- a 'RequestBody'
-multipartToBody :: forall tag.
-                MultipartBackend tag
+multipartToBody :: forall tag
+                .  MultipartClient tag
                 => LBS.ByteString
                 -> MultipartData tag
                 -> RequestBody

servant-multipart/src/Servant/Multipart.hs

@@ -59,12 +59,9 @@ import Servant.API.Modifiers (FoldLenient)
 import Servant.Docs hiding (samples)
 import Servant.Foreign hiding (contentType)
 import Servant.Server.Internal
-import Servant.Types.SourceT (SourceT(..), source, fromActionStep)
 import System.Directory
-import System.IO (IOMode(ReadMode), withFile)
 
 import qualified Data.ByteString      as SBS
-import qualified Data.ByteString.Lazy as LBS
 
 -- | Lookup a textual input with the given @name@ attribute.
 lookupInput :: Text -> MultipartData tag -> Either String Text
@@ -96,6 +93,19 @@ fromRaw (inputs, files) = MultipartData is fs
 
         dec = decodeUtf8
 
+class MultipartBackend tag where
+    type MultipartBackendOptions tag :: *
+
+    backend :: Proxy tag
+            -> MultipartBackendOptions tag
+            -> InternalState
+            -> ignored1
+            -> ignored2
+            -> IO SBS.ByteString
+            -> IO (MultipartResult tag)
+
+    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
 --   assuming the request body's content type is
@@ -222,27 +232,17 @@ data MultipartOptions tag = MultipartOptions
   }
 
 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.