[ANE-2955] Fix vendored archive uploads with absolute paths

Changelog.md

@@ -1,5 +1,9 @@
 # FOSSA CLI Changelog
 
+## 3.17.7
+
+- Vendored dependencies: archive uploads with an absolute `path` (as produced by the meta-fossa Yocto layer) no longer crash with a `permission denied` error while writing the tarball.
+
 ## 3.17.6
 
 - Config: `paths.only` and `paths.exclude` in `.fossa.yml` now accept glob patterns. ([#1703](https://github.com/fossas/fossa-cli/pull/1703))

src/App/Fossa/VendoredDependency.hs

@@ -7,6 +7,7 @@ module App.Fossa.VendoredDependency (
   vendoredDepToLocator,
   forceVendoredToArchive,
   compressFile,
+  safeSeparators,
   hashFile,
   hashBs,
   dedupVendoredDeps,
@@ -197,8 +198,11 @@ hashFile fileToHash = do
   fileContent <- BS.readFile fileToHash
   pure . toText . show $ md5 fileContent
 
+-- Drop root components so absolute inputs don't yield a result starting with
+-- '/', which `(</>)` would treat as absolute and use to overwrite the caller's
+-- intended output directory.
 safeSeparators :: FilePath -> FilePath
-safeSeparators = intercalate "_" . splitDirectories
+safeSeparators = intercalate "_" . filter (/= "/") . splitDirectories
 
 skippedDepsDebugLog :: NeedScanningDeps -> SkippableDeps -> VendoredDependencyScanMode -> SkippedDepsLogMsg
 skippedDepsDebugLog needScanningDeps skippedDeps scanMode =

test/App/Fossa/VendoredDependencySpec.hs

@@ -10,6 +10,7 @@ import App.Fossa.VendoredDependency (
   SkippedDepsLogMsg (..),
   VendoredDependencyScanMode (..),
   compressFile,
+  safeSeparators,
   skippedDepsDebugLog,
  )
 import Control.Carrier.Lift (sendIO)
@@ -42,6 +43,14 @@ spec = do
         compressedFilePath <- sendIO $ withSystemTempDir "fossa-temp" (flippedCompressFile specDir fileToTar)
         compressedFilePath `shouldContain'` fileToTar
 
+  describe "safeSeparators" $ do
+    it "joins relative path components with underscores" $
+      safeSeparators "foo/bar" `shouldBe` "foo_bar"
+    it "leaves bare filenames untouched" $
+      safeSeparators "foo" `shouldBe` "foo"
+    it "drops the root component for absolute paths" $
+      safeSeparators "/foo/bar/baz" `shouldBe` "foo_bar_baz"
+
   describe "skippedDepsDebugLog" $ do
     it "should return SkippingUnsupportedMsg when skipping is not supported" $
       skippedDepsDebugLog (NeedScanningDeps []) (SkippableDeps []) SkippingNotSupported `shouldBe` SkippingUnsupportedMsg