Fix SDK integration tests on Windows (#1125)

* Fix SDK integration tests on Windows

* Switch to Haskell-based tar extraction

.bazelrc

@@ -55,6 +55,7 @@ build --define=grpc_no_ares=true
 build --action_env=GIT_SSL_CAINFO
 # Pass through locale archive to ensure that we can get a UTF-8 locale.
 build:linux --action_env=LOCALE_ARCHIVE
+build:windows --action_env=JAVA_HOME
 
 
 # Pass workspace status for stamped actions

.dadew

@@ -12,6 +12,7 @@
         "bazel",
         "nodejs-10.12.0",
         "python-3.6.7",
-        "nsis-3.04"
+        "nsis-3.04",
+        "maven-3.6.1"
     ]
 }

WORKSPACE

@@ -136,6 +136,22 @@ dev_env_tool(
     win_tool = "msys2",
 )
 
+dev_env_tool(
+    name = "mvn_dev_env",
+    nix_include = ["bin/mvn"],
+    nix_label = "@mvn_nix",
+    nix_path = "bin/mvn",
+    tool = "mvn",
+    win_include = [
+        "bin",
+        "boot",
+        "conf",
+        "lib",
+    ],
+    win_path = "bin/mvn",
+    win_tool = "maven-3.6.1",
+)
+
 nixpkgs_package(
     name = "awk_nix",
     attribute_path = "gawk",
@@ -268,6 +284,7 @@ nixpkgs_package(
 nixpkgs_package(
     name = "mvn_nix",
     attribute_path = "mvn",
+    fail_not_supported = False,
     nix_file = "//nix:bazel.nix",
     nix_file_deps = common_nix_file_deps,
     repositories = dev_env_nix_repos,

build.ps1

@@ -67,4 +67,5 @@ bazel test `-`-experimental_execution_log_file ${ARTIFACT_DIRS}/test_execution_w
     //ledger/ledger-api-client/... `
     //ledger/ledger-api-common/... `
     //ledger-api/... `
-    //navigator/backend/...
+    //navigator/backend/... `
+    //daml-assistant/integration-tests/...

compiler/scenario-service/client/src/DA/Daml/LF/ScenarioServiceClient/LowLevel.hs

@@ -153,7 +153,12 @@ start opts@Options{..} = do
   port <- managed $ \resume -> withCheckedProcessCleanup cp $ \(stdinHdl :: System.IO.Handle) stdoutSrc stderrSrc ->
           flip finally (System.IO.hClose stdinHdl) $ do
     let splitOutput = C.T.decode C.T.utf8 .| C.T.lines
-    let printStderr line = liftIO (optLogError (T.unpack ("SCENARIO SERVICE STDERR: " <> line)))
+    let printStderr line
+            -- The last line should not be treated as an error.
+            | T.strip line == "ScenarioService: stdin closed, terminating server." =
+              liftIO (optLogInfo (T.unpack ("SCENARIO SERVICE STDERR: " <> line)))
+            | otherwise =
+              liftIO (optLogError (T.unpack ("SCENARIO SERVICE STDERR: " <> line)))
     let printStdout line = liftIO (optLogInfo (T.unpack ("SCENARIO SERVICE STDOUT: " <> line)))
     -- stick the error in the mvar so that we know we won't get an BlockedIndefinitedlyOnMvar exception
     portMVar <- newEmptyMVar

daml-assistant/BUILD.bazel

@@ -68,7 +68,10 @@ da_haskell_library(
     ] + (["Win32"] if is_windows else []),
     src_strip_prefix = "src",
     visibility = ["//visibility:public"],
-    deps = [":daml-project-config"],
+    deps = [
+        ":daml-project-config",
+        "//libs-haskell/da-hs-base",
+    ],
 )
 
 da_haskell_binary(

daml-assistant/integration-tests/BUILD.bazel

@@ -1,11 +1,12 @@
 # Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
 # SPDX-License-Identifier: Apache-2.0
 load("//bazel_tools:haskell.bzl", "da_haskell_test")
+load("@os_info//:os_info.bzl", "is_windows")
 
 genrule(
     name = "integration-tests-mvn",
     srcs = [
-        "@mvn_nix//:bin/mvn",
+        "@mvn_dev_env//:mvn",
         "//:component-version",
         "//daml-lf/archive:daml_lf_archive_java.jar",
         "//daml-lf/archive:daml_lf_archive_java_pom.xml",
@@ -26,7 +27,7 @@ genrule(
       MVN_DB="$$TMP_DIR/m2"
       VERSION=$$(cat $(location //:component-version))
       install_mvn() {
-          $(location @mvn_nix//:bin/mvn) -q install:install-file \
+          $(location @mvn_dev_env//:mvn) -q install:install-file \
           -Dmaven.repo.local=$$MVN_DB \
           "-DgroupId=$$1" \
           "-DartifactId=$$2" \
@@ -56,7 +57,7 @@ genrule(
         "com.digitalasset.ledger-api" "rs-grpc-bridge" \
         $(location //ledger-api/rs-grpc-bridge:librs-grpc-bridge.jar) \
         $(location //ledger-api/rs-grpc-bridge:rs-grpc-bridge_pom.xml)
-      $(location @mvn_nix//:bin/mvn) -q -Dmaven.repo.local=$$MVN_DB -f "$$TMP_DIR/quickstart-java/pom.xml" dependency:resolve dependency:resolve-plugins
+      $(location @mvn_dev_env//:mvn) -q -Dmaven.repo.local=$$MVN_DB -f "$$TMP_DIR/quickstart-java/pom.xml" dependency:resolve dependency:resolve-plugins
       tar cf $(location integration-tests-mvn.tar) -C $$(dirname $$MVN_DB) $$(basename $$MVN_DB)
     """,
 )
@@ -68,8 +69,9 @@ da_haskell_test(
     data = [
         ":integration-tests-mvn",
         "//release:sdk-release-tarball",
-        "@local_jdk//:bin/java",
-        "@mvn_nix//:bin/mvn",
+        "@local_jdk//:bin/java.exe" if is_windows else "@local_jdk//:bin/java",
+        "@mvn_dev_env//:mvn",
+        "@tar_dev_env//:tar",
     ],
     # I’m sure the mvn stuff will be flaky.
     flaky = True,
@@ -77,6 +79,8 @@ da_haskell_test(
         "async",
         "base",
         "bytestring",
+        "conduit",
+        "conduit-extra",
         "directory",
         "extra",
         "filepath",
@@ -84,8 +88,10 @@ da_haskell_test(
         "http-types",
         "main-tester",
         "network",
+        "unix-compat",
         "process",
         "tar",
+        "tar-conduit",
         "tasty",
         "tasty-hunit",
         "text",
@@ -95,5 +101,6 @@ da_haskell_test(
         "//:sdk-version-hs-lib",
         "//daml-assistant/daml-helper:daml-helper-lib",
         "//libs-haskell/bazel-runfiles",
+        "//libs-haskell/da-hs-base",
     ],
 )

daml-assistant/integration-tests/src/Main.hs

@@ -5,11 +5,16 @@ module Main (main) where
 
 import qualified Codec.Archive.Tar as Tar
 import qualified Codec.Archive.Zip as Zip
+import Conduit hiding (connect)
+import qualified Data.Conduit.Zlib as Zlib
+import qualified Data.Conduit.Tar.Extra as Tar.Conduit
 import Control.Concurrent
 import Control.Concurrent.Async
 import Control.Exception
 import Control.Monad
 import qualified Data.ByteString.Lazy as BSL
+import Data.List.Extra
+import qualified Data.Text as T
 import Data.Typeable
 import Network.HTTP.Client
 import Network.HTTP.Types
@@ -17,6 +22,7 @@ import Network.Socket
 import System.Directory.Extra
 import System.Environment.Blank
 import System.FilePath
+import System.Info.Extra
 import System.IO.Extra
 import System.Process
 import Test.Main
@@ -33,13 +39,14 @@ main =
     -- We manipulate global state via the working directory and
     -- the environment so running tests in parallel will cause trouble.
     setEnv "TASTY_NUM_THREADS" "1" True
-    oldPath <- getEnv "PATH"
+    oldPath <- getSearchPath
     javaPath <- locateRunfiles "local_jdk/bin"
-    mvnPath <- locateRunfiles "mvn_nix/bin"
+    mvnPath <- locateRunfiles "mvn_dev_env/bin"
+    tarPath <- locateRunfiles "tar_dev_env/bin"
     let damlDir = tmpDir </> "daml"
     withEnv
         [ ("DAML_HOME", Just damlDir)
-        , ("PATH", Just $ (damlDir </> "bin") <> ":" <> javaPath <> ":" <> mvnPath <> maybe "" (":" <>) oldPath)
+        , ("PATH", Just $ intercalate [searchPathSeparator] ((damlDir </> "bin") : tarPath : javaPath : mvnPath : oldPath))
         ] $ defaultMain (tests tmpDir)
 
 tests :: FilePath -> TestTree
@@ -47,18 +54,21 @@ tests tmpDir = testGroup "Integration tests"
     [ testCase "install" $ do
           releaseTarball <- locateRunfiles (mainWorkspace </> "release" </> "sdk-release-tarball.tar.gz")
           createDirectory tarballDir
-          callProcessQuiet "tar" ["xf", releaseTarball, "--strip-components=1", "-C", tarballDir]
-          callProcessQuiet (tarballDir </> "install.sh") []
-    , testCase "daml version" $ callProcessQuiet "daml" ["version"]
-    , testCase "daml --help" $ callProcessQuiet "daml" ["--help"]
-    , testCase "daml new --list" $ callProcessQuiet "daml" ["new", "--list"]
+          runConduitRes
+              $ sourceFileBS releaseTarball
+              .| Zlib.ungzip
+              .| Tar.Conduit.untar (Tar.Conduit.restoreFile throwError tarballDir)
+          callProcessQuiet (tarballDir </> "daml" </> "daml") ["install", "--activate", "--set-path=no", tarballDir]
+    , testCase "daml version" $ callProcessQuiet damlName ["version"]
+    , testCase "daml --help" $ callProcessQuiet damlName ["--help"]
+    , testCase "daml new --list" $ callProcessQuiet damlName ["new", "--list"]
     , packagingTests tmpDir
     , quickstartTests quickstartDir mvnDir
     ]
     where quickstartDir = tmpDir </> "quickstart"
           mvnDir = tmpDir </> "m2"
           tarballDir = tmpDir </> "tarball"
-
+          throwError msg e = fail (T.unpack $ msg <> " " <> e)
 
 packagingTests :: FilePath -> TestTree
 packagingTests tmpDir = testGroup "packaging"
@@ -85,7 +95,7 @@ packagingTests tmpDir = testGroup "packaging"
             , "  - daml-prim"
             , "  - daml-stdlib"
             ]
-        withCurrentDirectory projectA $ callProcessQuiet "daml" ["build"]
+        withCurrentDirectory projectA $ callProcessQuiet damlName ["build"]
         assertBool "a.dar was not created." =<< doesFileExist aDar
         step "Creating project b..."
         createDirectoryIfMissing True (projectB </> "daml")
@@ -107,7 +117,7 @@ packagingTests tmpDir = testGroup "packaging"
             , "  - daml-stdlib"
             , "  - " <> aDar
             ]
-        withCurrentDirectory projectB $ callProcessQuiet "daml" ["build"]
+        withCurrentDirectory projectB $ callProcessQuiet damlName ["build"]
         assertBool "b.dar was not created." =<< doesFileExist bDar
     , testCase "Top-level source files" $ do
         -- Test that a source file in the project root will be included in the
@@ -130,26 +140,28 @@ packagingTests tmpDir = testGroup "packaging"
           , "  - daml-prim"
           , "  - daml-stdlib"
           ]
-        withCurrentDirectory projDir $ callProcessQuiet "daml" ["build"]
+        withCurrentDirectory projDir $ callProcessQuiet damlName ["build"]
         let dar = projDir </> "dist" </> "proj.dar"
         assertBool "proj.dar was not created." =<< doesFileExist dar
         darFiles <- Zip.filesInArchive . Zip.toArchive <$> BSL.readFile dar
-        assertBool "A.daml is missing" (("proj" </> "A.daml") `elem` darFiles)
+        -- Note that we really want a forward slash here instead of </> since filepaths in
+        -- zip files use forward slashes.
+        assertBool "A.daml is missing" ("proj/A.daml" `elem` darFiles)
     ]
 
 quickstartTests :: FilePath -> FilePath -> TestTree
-quickstartTests quickstartDir mvnDir = testGroup "quickstart"
+quickstartTests quickstartDir mvnDir = testGroup "quickstart" $
     [ testCase "daml new" $
-          callProcessQuiet "daml" ["new", quickstartDir, "quickstart-java"]
+          callProcessQuiet damlName ["new", quickstartDir, "quickstart-java"]
     , testCase "daml build " $ withCurrentDirectory quickstartDir $
-          callProcessQuiet "daml" ["build", "-o", "target/daml/iou.dar"]
+          callProcessQuiet damlName ["build", "-o", "target/daml/iou.dar"]
     , testCase "daml damlc test" $ withCurrentDirectory quickstartDir $
-          callProcessQuiet "daml" ["damlc", "test", "daml/Main.daml"]
+          callProcessQuiet damlName ["damlc", "test", "daml/Main.daml"]
     , testCase "sandbox startup" $
       withCurrentDirectory quickstartDir $
       withDevNull $ \devNull -> do
           p :: Int <- fromIntegral <$> getFreePort
-          withCreateProcess ((proc "daml" ["sandbox", "--port", show p, "dist/quickstart.dar"]) { std_out = UseHandle devNull }) $
+          withCreateProcess (adjustCP (proc damlName ["sandbox", "--port", show p, "dist/quickstart.dar"]) { std_out = UseHandle devNull }) $
               \_ _ _ ph -> race_ (waitForProcess' "sandbox" [] ph) $ do
               waitForConnectionOnPort (threadDelay 100000) p
               addr : _ <- getAddrInfo
@@ -160,7 +172,13 @@ quickstartTests quickstartDir mvnDir = testGroup "quickstart"
                   (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))
                   close
                   (\s -> connect s (addrAddress addr))
-    , testCase "mvn compile" $
+    ] <>
+    -- The mvn tests seem to fail on Windows for some reason so for now we disable them.
+    -- mvn itself does seem to work fine outside of this test so it seems to be some
+    -- setup issue.
+    -- See https://github.com/digital-asset/daml/issues/1127
+    if isWindows then [] else
+    [ testCase "mvn compile" $
       withCurrentDirectory quickstartDir $ do
           mvnDbTarball <- locateRunfiles (mainWorkspace </> "daml-assistant" </> "integration-tests" </> "integration-tests-mvn.tar")
           Tar.extract (takeDirectory mvnDir) mvnDbTarball
@@ -170,11 +188,11 @@ quickstartTests quickstartDir mvnDir = testGroup "quickstart"
       withDevNull $ \devNull1 ->
       withDevNull $ \devNull2 -> do
           sandboxPort :: Int <- fromIntegral <$> getFreePort
-          withCreateProcess ((proc "daml" ["sandbox", "--", "--port", show sandboxPort, "--", "--scenario", "Main:setup", "target/daml/iou.dar"]) { std_out = UseHandle devNull1 }) $
+          withCreateProcess (adjustCP (proc damlName ["sandbox", "--", "--port", show sandboxPort, "--", "--scenario", "Main:setup", "target/daml/iou.dar"]) { std_out = UseHandle devNull1 }) $
               \_ _ _ ph -> race_ (waitForProcess' "sandbox" [] ph) $ do
               waitForConnectionOnPort (threadDelay 500000) sandboxPort
               restPort :: Int <- fromIntegral <$> getFreePort
-              withCreateProcess ((proc "mvn" [mvnRepoFlag, "-Dledgerport=" <> show sandboxPort, "-Drestport=" <> show restPort, "exec:java@run-quickstart"]) { std_out = UseHandle devNull2 }) $
+              withCreateProcess (adjustCP (proc "mvn" [mvnRepoFlag, "-Dledgerport=" <> show sandboxPort, "-Drestport=" <> show restPort, "exec:java@run-quickstart"]) { std_out = UseHandle devNull2 }) $
                   \_ _ _ ph -> race_ (waitForProcess' "mvn" [] ph) $ do
                   let url = "http://localhost:" <> show restPort <> "/iou"
                   waitForHttpServer (threadDelay 1000000) url
@@ -189,10 +207,28 @@ quickstartTests quickstartDir mvnDir = testGroup "quickstart"
     where
         mvnRepoFlag = "-Dmaven.repo.local=" <> mvnDir
 
+-- | Bazel tests are run in a bash environment with cmd.exe not in PATH. This results in ShellCommand
+-- failing so instead we patch ShellCommand and RawCommand to call bash directly.
+adjustCP :: CreateProcess -> CreateProcess
+adjustCP cp =  cp { cmdspec = cmdspec' }
+    where
+        cmdspec' = if isWindows
+            then case cmdspec cp of
+                RawCommand cmd args -> RawCommand "bash" ["-c", unwords $ map (\s -> "'" <> s <> "'") $ cmd : args]
+                ShellCommand cmd -> RawCommand "bash" ["-c", cmd]
+            else cmdspec cp
+
+-- | Since we run in bash and not in cmd.exe "daml" won’t look for "daml.cmd"
+-- so we use "daml.cmd" directly. Also look at the docs for `adjustCP`.
+damlName :: String
+damlName
+    | isWindows = "daml.cmd"
+    | otherwise = "daml"
+
 -- | Like call process but hides stdout.
 callProcessQuiet :: FilePath -> [String] -> IO ()
 callProcessQuiet cmd args = do
-    (exit, _out, err) <- readProcessWithExitCode cmd args ""
+    (exit, _out, err) <- readCreateProcessWithExitCode (adjustCP $ proc cmd args) ""
     hPutStr stderr err
     unless (exit == ExitSuccess) $ throwIO $ ProcessExitFailure exit cmd args
 

daml-assistant/src/DAML/Assistant/Install.hs

@@ -21,12 +21,11 @@ import DAML.Project.Util
 import Safe
 import Conduit
 import qualified Data.Conduit.List as List
-import qualified Data.Conduit.Tar as Tar
+import qualified Data.Conduit.Tar.Extra as Tar
 import qualified Data.Conduit.Zlib as Zlib
 import Network.HTTP.Simple
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.UTF8 as BS.UTF8
-import Data.List.Extra
 import System.Exit
 import System.IO
 import System.IO.Temp
@@ -36,7 +35,6 @@ import Control.Monad.Extra
 import Control.Exception.Safe
 import System.ProgressBar
 import System.Info.Extra (isWindows)
-import Data.Maybe
 
 -- unix specific
 import System.PosixCompat.Types ( FileMode )
@@ -258,61 +256,9 @@ extractAndInstall env source =
             runConduitRes
                 $ source
                 .| Zlib.ungzip
-                .| Tar.untar (restoreFile extractPath)
+                .| Tar.untar (Tar.restoreFile throwError extractPath)
             installExtracted env (SdkPath extractPath)
-    where
-        restoreFile :: MonadResource m => FilePath -> Tar.FileInfo
-            -> ConduitT BS.ByteString Void m ()
-        restoreFile extractPath info = do
-            let oldPath = Tar.decodeFilePath (Tar.filePath info)
-                newPath = dropDirectory1 oldPath
-                targetPath = extractPath </> dropTrailingPathSeparator newPath
-                parentPath = takeDirectory targetPath
-
-            when (pathEscapes newPath) $ do
-                liftIO $ throwIO $ assistantErrorBecause
-                    "Invalid SDK release: file path escapes tarball."
-                    ("path = " <> pack oldPath)
-
-            when (notNull newPath) $ do
-                case Tar.fileType info of
-                    Tar.FTNormal -> do
-                        liftIO $ createDirectoryIfMissing True parentPath
-                        sinkFileBS targetPath
-                        liftIO $ setFileMode targetPath (Tar.fileMode info)
-                    Tar.FTDirectory -> do
-                        liftIO $ createDirectoryIfMissing True targetPath
-                    Tar.FTSymbolicLink bs | not isWindows -> do
-                        let path = Tar.decodeFilePath bs
-                        unless (isRelative path) $
-                            liftIO $ throwIO $ assistantErrorBecause
-                                "Invalid SDK release: symbolic link target is absolute."
-                                ("target = " <> pack path <>  ", path = " <> pack oldPath)
-
-                        when (pathEscapes (takeDirectory newPath </> path)) $
-                            liftIO $ throwIO $ assistantErrorBecause
-                                "Invalid SDK release: symbolic link target escapes tarball."
-                                ("target = " <> pack path <> ", path = " <> pack oldPath)
-
-                        liftIO $ createDirectoryIfMissing True parentPath
-                        liftIO $ createSymbolicLink path targetPath
-                    unsupported ->
-                        liftIO $ throwIO $ assistantErrorBecause
-                            "Invalid SDK release: unsupported file type."
-                            ("type = " <> pack (show unsupported) <>  ", path = " <> pack oldPath)
-
-        -- | Check whether a relative path escapes its root.
-        pathEscapes :: FilePath -> Bool
-        pathEscapes path = isNothing $ foldM step "" (splitDirectories path)
-            where
-                step acc "."  = Just acc
-                step ""  ".." = Nothing
-                step acc ".." = Just (takeDirectory acc)
-                step acc name = Just (acc </> name)
-
-        -- | Drop first component from path
-        dropDirectory1 :: FilePath -> FilePath
-        dropDirectory1 = joinPath . tail . splitPath
+    where throwError msg e = liftIO $ throwIO $ assistantErrorBecause ("Invalid SDK release: " <> msg) e
 
 -- | Download an sdk tarball and install it.
 httpInstall :: InstallEnv -> InstallURL -> IO ()

dev-env/windows/manifests/maven-3.6.1.json

@@ -0,0 +1,27 @@
+{
+    "homepage": "https://maven.apache.org/",
+    "version": "3.6.1",
+    "license": "Apache-2.0",
+    "url": "https://archive.apache.org/dist/maven/maven-3/3.6.1/binaries/apache-maven-3.6.1-bin.zip",
+    "hash": "7e6cfe98dc9c16ae6aa267db277860594695144d719c99d1fc519e89346a8edf",
+    "extract_dir": "apache-maven-3.6.1",
+    "env_add_path": "bin",
+    "suggest": {
+        "JDK": [
+            "java/oraclejdk",
+            "java/openjdk"
+        ]
+    },
+    "checkver": {
+        "url": "https://maven.apache.org/docs/history.html",
+        "re": "<b>([\\d.]+)</b>"
+    },
+    "autoupdate": {
+        "url": "https://archive.apache.org/dist/maven/maven-$majorVersion/$version/binaries/apache-maven-$version-bin.zip",
+        "extract_dir": "apache-maven-$version",
+        "hash": {
+            "url": "$url.sha1"
+        }
+    },
+    "persist": "conf"
+}

libs-haskell/da-hs-base/BUILD.bazel

@@ -16,6 +16,7 @@ da_haskell_library(
         "binary",
         "blaze-html",
         "bytestring",
+        "conduit",
         "containers",
         "deepseq",
         "directory",
@@ -35,6 +36,7 @@ da_haskell_library(
         "safe",
         "stm",
         "tagged",
+        "tar-conduit",
         "tasty-hunit",
         "tasty-quickcheck",
         "tasty",
@@ -44,6 +46,7 @@ da_haskell_library(
         "transformers-base",
         "transformers",
         "unordered-containers",
+        "unix-compat",
         "utf8-string",
         "uuid",
         "vector",

libs-haskell/da-hs-base/src/Data.Conduit.Tar.Extra.hs

@@ -0,0 +1,83 @@
+-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
+-- SPDX-License-Identifier: Apache-2.0
+
+{-# LANGUAGE OverloadedStrings #-}
+module Data.Conduit.Tar.Extra
+    ( module Data.Conduit.Tar
+    , restoreFile
+    ) where
+
+import Conduit
+import Control.Monad
+import qualified Data.ByteString as BS
+import Data.Conduit.Tar hiding (restoreFile)
+import qualified Data.Conduit.Tar as Tar
+import Data.List.Extra
+import Data.Maybe
+import Data.Text (Text, pack)
+import System.Directory
+import System.FilePath
+import System.Info.Extra
+import System.PosixCompat.Files (createSymbolicLink, setFileMode)
+
+
+-- | This is intended to be used in combination with `Data.Conduit.Tar.untar`.
+-- It writes the given file to the given directory stripping the first component
+-- thereby emulating tar’s --strip-components=1 option.
+restoreFile
+    :: MonadResource m
+    => (Text -> Text -> m ())
+    -> FilePath
+    -> Tar.FileInfo
+    -> ConduitT BS.ByteString Void m ()
+restoreFile throwError extractPath info = do
+    let oldPath = Tar.decodeFilePath (Tar.filePath info)
+        newPath = dropDirectory1 oldPath
+        targetPath = extractPath </> dropTrailingPathSeparator newPath
+        parentPath = takeDirectory targetPath
+
+    when (pathEscapes newPath) $ do
+        lift $ throwError
+            "file path escapes tarball."
+            ("path = " <> pack oldPath)
+
+    when (notNull newPath) $ do
+        case Tar.fileType info of
+            Tar.FTNormal -> do
+                liftIO $ createDirectoryIfMissing True parentPath
+                sinkFileBS targetPath
+                liftIO $ setFileMode targetPath (Tar.fileMode info)
+            Tar.FTDirectory -> do
+                liftIO $ createDirectoryIfMissing True targetPath
+            Tar.FTSymbolicLink bs | not isWindows -> do
+                let path = Tar.decodeFilePath bs
+                unless (isRelative path) $
+                    lift $ throwError
+                        "symbolic link target is absolute."
+                        ("target = " <> pack path <>  ", path = " <> pack oldPath)
+
+                when (pathEscapes (takeDirectory newPath </> path)) $
+                    lift $ throwError
+                        "symbolic link target escapes tarball."
+                        ("target = " <> pack path <> ", path = " <> pack oldPath)
+
+                liftIO $ createDirectoryIfMissing True parentPath
+                liftIO $ createSymbolicLink path targetPath
+            unsupported ->
+                lift $ throwError
+                    "unsupported file type."
+                    ("type = " <> pack (show unsupported) <>  ", path = " <> pack oldPath)
+
+-- | Check whether a relative path escapes its root.
+pathEscapes :: FilePath -> Bool
+pathEscapes path = isNothing $ foldM step "" (splitDirectories path)
+    where
+        step acc "."  = Just acc
+        step ""  ".." = Nothing
+        step acc ".." = Just (takeDirectory acc)
+        step acc name = Just (acc </> name)
+
+-- | Drop first component from path
+dropDirectory1 :: FilePath -> FilePath
+dropDirectory1 = joinPath . tail . splitPath
+