Merge pull request #1 from phadej/updates

Updates. MonadResource in `servant-server` cleans a bit here

Author: alpmestan

.travis.yml

@@ -0,0 +1,92 @@
+# This Travis job script has been generated by a script via
+#
+#   make_travis_yml_2.hs 'servant-multipart.cabal'
+#
+# For more information, see https://github.com/hvr/multi-ghc-travis
+#
+language: c
+sudo: false
+
+git:
+  submodules: false  # whether to recursively clone submodules
+
+cache:
+  directories:
+    - $HOME/.cabal/packages
+    - $HOME/.cabal/store
+
+before_cache:
+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
+  # remove files that are regenerated by 'cabal update'
+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*
+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json
+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache
+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar
+  - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx
+
+matrix:
+  include:
+    - compiler: "ghc-7.8.4"
+    # env: TEST=--disable-tests BENCH=--disable-benchmarks
+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.8.4], sources: [hvr-ghc]}}
+    - compiler: "ghc-7.10.3"
+    # env: TEST=--disable-tests BENCH=--disable-benchmarks
+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.10.3], sources: [hvr-ghc]}}
+    - compiler: "ghc-8.0.2"
+    # env: TEST=--disable-tests BENCH=--disable-benchmarks
+      addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.0.2], sources: [hvr-ghc]}}
+
+before_install:
+ - HC=${CC}
+ - unset CC
+ - PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$PATH
+ - PKGNAME='servant-multipart'
+ - ROOTDIR=$(pwd)
+
+install:
+ - cabal --version
+ - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
+ - BENCH=${BENCH---enable-benchmarks}
+ - TEST=${TEST---enable-tests}
+ - travis_retry cabal update -v
+ - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
+ - rm -fv cabal.project.local
+ # Fetch not-released servant
+ - git clone https://github.com/haskell-servant/servant.git 
+ - cd servant; git checkout 736918a694dd7247fbd3f21a9bc138f6dcc5b3dd; cd ..
+ - "echo 'packages: . servant/servant/ servant/servant-server/ ' > cabal.project"
+ - rm -f cabal.project.freeze
+ - cabal new-build -w ${HC} ${TEST} ${BENCH} --dep -j2
+ - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --dep -j2
+
+# Here starts the actual work to be performed for the package under test;
+# any command which exits with a non-zero exit code causes the build to fail.
+script:
+ - if [ -f configure.ac ]; then autoreconf -i; fi
+ - rm -rf dist/
+ - cabal sdist # test that a source-distribution can be generated
+ - cd dist/
+ - SRCTAR=(${PKGNAME}-*.tar.gz)
+ - SRC_BASENAME="${SRCTAR/%.tar.gz}"
+ - tar -xvf "./$SRC_BASENAME.tar.gz"
+ - cd "$SRC_BASENAME/"
+## from here on, CWD is inside the extracted source-tarball
+ - rm -fv cabal.project.local
+ - "echo 'packages: . servant/servant/ servant/servant-server/ ' > cabal.project"
+ - mv $ROOTDIR/servant .
+ # this builds all libraries and executables (without tests/benchmarks)
+ - rm -f cabal.project.freeze
+ - cabal new-build -w ${HC} --disable-tests --disable-benchmarks
+ # this builds all libraries and executables (including tests/benchmarks)
+ # - rm -rf ./dist-newstyle
+ - cabal new-build -w ${HC} ${TEST} ${BENCH}
+
+ # there's no 'cabal new-test' yet, so let's emulate for now
+ - TESTS=( $(awk 'tolower($0) ~ /^test-suite / { print $2 }' *.cabal) )
+ - if [ "$TEST" != "--enable-tests" ]; then TESTS=(); fi
+ - shopt -s globstar;
+   RC=true; for T in ${TESTS[@]}; do echo "== $T ==";
+   if dist-newstyle/build/**/$SRC_BASENAME/**/build/$T/$T; then echo "= $T OK =";
+   else echo "= $T FAILED ="; RC=false; fi; done; $RC
+
+# EOF

servant-multipart.cabal

@@ -2,7 +2,7 @@ name:                servant-multipart
 version:             0.1
 synopsis:            multipart/form-data (e.g file upload) support for servant
 description:         Please see README.md
-homepage:            https://github.com/alpmestan/servant-multipart#readme
+homepage:            https://github.com/haskell-servant/servant-multipart#readme
 license:             BSD3
 license-file:        LICENSE
 author:              Alp Mestanogullari
@@ -11,6 +11,10 @@ copyright:           2016 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
@@ -21,9 +25,10 @@ library
                 directory,
                 http-media,
                 resourcet,
-                servant,
-                servant-server,
+                servant >=0.10 && <0.11,
+                servant-server >=0.10 && <0.11,
                 text,
+                transformers >=0.3 && <0.6,
                 wai,
                 wai-extra
   default-language:    Haskell2010
@@ -39,9 +44,10 @@ executable upload
                 servant-multipart,
                 servant-server,
                 text,
+                transformers,
                 warp,
                 wai
 
 source-repository head
   type:     git
-  location: https://github.com/alpmestan/servant-multipart
+  location: https://github.com/haskell-servent/servant-multipart

src/Servant/Multipart.hs

@@ -244,49 +244,32 @@ instance ( FromMultipart a
 -- 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, InternalState)
-check opts = withRequest $ \request -> liftIO $ do
-  st <- createInternalState
-  rawData <- parseRequestBodyEx parseOpts (tmpBackend opts st) request
-  return (fromRaw rawData, st)
-
+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
 
--- Perform cleanup of uploaded files in /tmp.
-cleanup :: (MultipartData, InternalState) -> IO ()
-cleanup (multipartData, internalState) = do
-  removeFileKeys <- forM (files multipartData) $ \file ->
-    runInternalState
-      (register $ do
-          exists <- doesFileExist (fdFilePath file)
-          when exists $ removeFile (fdFilePath file)
-      )
-      internalState
-  mapM_ release removeFileKeys
-  closeInternalState internalState
-
 -- Add multipart extraction support to a Delayed.
 addMultipartHandling :: FromMultipart multipart
                      => MultipartOptions
                      -> Delayed env (multipart -> a)
                      -> Delayed env a
-addMultipartHandling opts Delayed{..} =
-  Delayed { bodyD     = withRequest $ \request -> do
-              fuzzyMultipartCTCheck (contentTypeH request)
-              b <- bodyD
-              b' <- check opts
-              addCleanup (cleanup b')
-              return (b, b')
-          , serverD   = \cs a (b, (multipartData, _st)) req ->
-              case fromMultipart multipartData of
-                Nothing -> FailFatal $
-                  err400 { errBody = "fromMultipart returned Nothing" }
-                Just x  -> fmap ($ x) $
-                  serverD cs a b req
-          , ..
-          }
-
-  where contentTypeH req = fromMaybe "application/octed-stream" $
+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:
@@ -311,21 +294,10 @@ tmpBackend :: MultipartOptions
            -> ignored2
            -> IO SBS.ByteString
            -> IO FilePath
-tmpBackend opts st _ _ popper = do
-  (hcloseReleaseKey, (fp, h)) <-
-    flip runInternalState st $ allocate tmpFile (hClose . snd)
-  fix $ \loop -> do
-    bs <- popper
-    unless (SBS.null bs) $ do
-      SBS.hPut h bs
-      loop
-  -- make sure the file is closed by now
-  release hcloseReleaseKey
-  return fp
-
-  where tmpFile = do
-          tmpdir <- getTmpDir (tmpOptions opts)
-          openBinaryTempFile tmpdir $ filenamePat (tmpOptions opts)
+tmpBackend opts =
+    tempFileBackEndOpts (getTmpDir tmpOpts) (filenamePat tmpOpts)
+  where
+    tmpOpts = tmpOptions opts
 
 -- | Global options for configuring how the
 --   server should handle multipart data.