From ad10f98020052a33450545e630b79c8003558997 Mon Sep 17 00:00:00 2001 From: Moritz Kiefer Date: Tue, 14 May 2019 21:55:45 +0200 Subject: [PATCH] Fix SDK integration tests on Windows (#1125) * Fix SDK integration tests on Windows * Switch to Haskell-based tar extraction --- .bazelrc | 1 + .dadew | 3 +- WORKSPACE | 17 ++++ build.ps1 | 3 +- .../Daml/LF/ScenarioServiceClient/LowLevel.hs | 7 +- daml-assistant/BUILD.bazel | 5 +- daml-assistant/integration-tests/BUILD.bazel | 17 ++-- daml-assistant/integration-tests/src/Main.hs | 80 +++++++++++++----- daml-assistant/src/DAML/Assistant/Install.hs | 60 +------------- dev-env/windows/manifests/maven-3.6.1.json | 27 ++++++ libs-haskell/da-hs-base/BUILD.bazel | 3 + .../da-hs-base/src/Data.Conduit.Tar.Extra.hs | 83 +++++++++++++++++++ 12 files changed, 218 insertions(+), 88 deletions(-) create mode 100644 dev-env/windows/manifests/maven-3.6.1.json create mode 100644 libs-haskell/da-hs-base/src/Data.Conduit.Tar.Extra.hs diff --git a/.bazelrc b/.bazelrc index 2ca6cbf0671..f479e9e43f9 100644 --- a/.bazelrc +++ b/.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 diff --git a/.dadew b/.dadew index 8339349c26f..95e480cc1a7 100644 --- a/.dadew +++ b/.dadew @@ -12,6 +12,7 @@ "bazel", "nodejs-10.12.0", "python-3.6.7", - "nsis-3.04" + "nsis-3.04", + "maven-3.6.1" ] } diff --git a/WORKSPACE b/WORKSPACE index 48cfcedbf36..7d595404795 100644 --- a/WORKSPACE +++ b/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, diff --git a/build.ps1 b/build.ps1 index e32f1654976..500ec05f9eb 100644 --- a/build.ps1 +++ b/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/... diff --git a/compiler/scenario-service/client/src/DA/Daml/LF/ScenarioServiceClient/LowLevel.hs b/compiler/scenario-service/client/src/DA/Daml/LF/ScenarioServiceClient/LowLevel.hs index 49a22b65404..a56e0d4afb3 100644 --- a/compiler/scenario-service/client/src/DA/Daml/LF/ScenarioServiceClient/LowLevel.hs +++ b/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 diff --git a/daml-assistant/BUILD.bazel b/daml-assistant/BUILD.bazel index 3a5deb33d36..89d79e00ed6 100644 --- a/daml-assistant/BUILD.bazel +++ b/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( diff --git a/daml-assistant/integration-tests/BUILD.bazel b/daml-assistant/integration-tests/BUILD.bazel index b62e667b109..3126c454c90 100644 --- a/daml-assistant/integration-tests/BUILD.bazel +++ b/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", ], ) diff --git a/daml-assistant/integration-tests/src/Main.hs b/daml-assistant/integration-tests/src/Main.hs index 9baa8478b37..00e95733cce 100644 --- a/daml-assistant/integration-tests/src/Main.hs +++ b/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 diff --git a/daml-assistant/src/DAML/Assistant/Install.hs b/daml-assistant/src/DAML/Assistant/Install.hs index cf8bc744e22..511ebb12d03 100644 --- a/daml-assistant/src/DAML/Assistant/Install.hs +++ b/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 () diff --git a/dev-env/windows/manifests/maven-3.6.1.json b/dev-env/windows/manifests/maven-3.6.1.json new file mode 100644 index 00000000000..47a3c8f236d --- /dev/null +++ b/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": "([\\d.]+)" + }, + "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" +} diff --git a/libs-haskell/da-hs-base/BUILD.bazel b/libs-haskell/da-hs-base/BUILD.bazel index 1507764e66a..dbf789fa66b 100644 --- a/libs-haskell/da-hs-base/BUILD.bazel +++ b/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", diff --git a/libs-haskell/da-hs-base/src/Data.Conduit.Tar.Extra.hs b/libs-haskell/da-hs-base/src/Data.Conduit.Tar.Extra.hs new file mode 100644 index 00000000000..145d7ddb01c --- /dev/null +++ b/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 +