Fix #6372 Allow stack sdist to check packages with non-ASCII names

ChangeLog.md

@@ -64,6 +64,8 @@ Bug fixes:
 * Better error message if a `resolver:` or `snapshot:` value is, in error, a
   YAML number.
 * Stack accepts all package names that are, in fact, acceptable to Cabal.
+* Stack's `sdist` command can check packages with names that include non-ASCII
+  characters.
 
 ## v2.13.1 - 2023-09-29
 

package.yaml

@@ -157,6 +157,7 @@ library:
   - Build_stack
   - Paths_stack
   exposed-modules:
+  - Codec.Archive.Tar.Utf8
   - Control.Concurrent.Execute
   - Data.Attoparsec.Args
   - Data.Attoparsec.Combinators

src/Codec/Archive/Tar/Utf8.hs

@@ -0,0 +1,130 @@
+module Codec.Archive.Tar.Utf8
+  ( module Codec.Archive.Tar
+  , entryPath
+  , unpack
+  ) where
+
+-- | A module that is equivalent to "Codec.Archive.Tar" from the @tar@ package,
+-- except that @unpack@ assumes that the file paths in an archive are UTF8
+-- encoded.
+
+import           Codec.Archive.Tar hiding ( entryPath, unpack )
+import           Codec.Archive.Tar.Check ( checkSecurity )
+import           Codec.Archive.Tar.Entry ( Entry (..), TarPath, fromLinkTarget )
+import qualified Codec.Archive.Tar.Entry as Tar
+import           Control.Exception ( Exception, catch, throwIO )
+import qualified Data.ByteString.Char8 as BS.Char8
+import qualified Data.ByteString.Lazy as LBS
+import           Data.Int ( Int64 )
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import           Data.Time.Clock.POSIX ( posixSecondsToUTCTime )
+import           System.Directory
+                   ( createDirectoryIfMissing, copyFile, setModificationTime )
+import           System.FilePath ( (</>) )
+import qualified System.FilePath as FP
+import           System.IO.Error ( isPermissionError )
+
+type EpochTime = Int64
+
+-- | Native 'FilePath' of the file or directory within the archive.
+--
+-- Assumes that the 'TarPath' of an 'Entry' is UTF8 encoded.
+entryPath :: Entry -> FilePath
+entryPath = fromTarPath . entryTarPath
+
+-- | Convert a 'TarPath' to a native 'FilePath'.
+--
+-- The native 'FilePath' will use the native directory separator but it is not
+-- otherwise checked for validity or sanity. In particular:
+--
+-- * The tar path may be invalid as a native path, eg the file name @\"nul\"@
+--   is not valid on Windows.
+--
+-- * The tar path may be an absolute path or may contain @\"..\"@ components.
+--   For security reasons this should not usually be allowed, but it is your
+--   responsibility to check for these conditions (eg using 'checkSecurity').
+--
+-- Assumes that the 'TarPath' is UTF8 encoded.
+fromTarPath :: TarPath -> FilePath
+fromTarPath = T.unpack . T.decodeUtf8Lenient . BS.Char8.pack . Tar.fromTarPath
+
+-- | Create local files and directories based on the entries of a tar archive.
+--
+-- This is a portable implementation of unpacking suitable for portable
+-- archives. It handles 'NormalFile' and 'Directory' entries and has simulated
+-- support for 'SymbolicLink' and 'HardLink' entries. Links are implemented by
+-- copying the target file. This therefore works on Windows as well as Unix.
+-- All other entry types are ignored, that is they are not unpacked and no
+-- exception is raised.
+--
+-- If the 'Entries' ends in an error then it is raised an an exception. Any
+-- files or directories that have been unpacked before the error was
+-- encountered will not be deleted. For this reason you may want to unpack
+-- into an empty directory so that you can easily clean up if unpacking fails
+-- part-way.
+--
+-- On its own, this function only checks for security (using 'checkSecurity').
+-- You can do other checks by applying checking functions to the 'Entries' that
+-- you pass to this function. For example:
+--
+-- > unpack dir (checkTarbomb expectedDir entries)
+--
+-- If you care about the priority of the reported errors then you may want to
+-- use 'checkSecurity' before 'checkTarbomb' or other checks.
+--
+-- Assumes that the 'TarPath' of an `Entry` is UTF8 encoded.
+unpack :: Exception e => FilePath -> Entries e -> IO ()
+unpack baseDir entries = unpackEntries [] (checkSecurity entries)
+                     >>= emulateLinks
+
+  where
+    -- We're relying here on 'checkSecurity' to make sure we're not scribbling
+    -- files all over the place.
+
+    unpackEntries _     (Fail err)      = either throwIO throwIO err
+    unpackEntries links Done            = return links
+    unpackEntries links (Next entry es) = case entryContent entry of
+      NormalFile file _ -> extractFile path file mtime
+                        >> unpackEntries links es
+      Directory         -> extractDir path mtime
+                        >> unpackEntries links es
+      HardLink     link -> (unpackEntries $! saveLink path link links) es
+      SymbolicLink link -> (unpackEntries $! saveLink path link links) es
+      _                 -> unpackEntries links es --ignore other file types
+      where
+        path  = entryPath entry
+        mtime = entryTime entry
+
+    extractFile path content mtime = do
+      -- Note that tar archives do not make sure each directory is created
+      -- before files they contain, indeed we may have to create several
+      -- levels of directory.
+      createDirectoryIfMissing True absDir
+      LBS.writeFile absPath content
+      setModTime absPath mtime
+      where
+        absDir  = baseDir </> FP.takeDirectory path
+        absPath = baseDir </> path
+
+    extractDir path mtime = do
+      createDirectoryIfMissing True absPath
+      setModTime absPath mtime
+      where
+        absPath = baseDir </> path
+
+    saveLink path link links = seq (length path)
+                             $ seq (length link')
+                             $ (path, link'):links
+      where link' = fromLinkTarget link
+
+    emulateLinks = mapM_ $ \(relPath, relLinkTarget) ->
+      let absPath   = baseDir </> relPath
+          absTarget = FP.takeDirectory absPath </> relLinkTarget
+       in copyFile absTarget absPath
+
+setModTime :: FilePath -> EpochTime -> IO ()
+setModTime path t =
+    setModificationTime path (posixSecondsToUTCTime (fromIntegral t))
+      `catch` \e ->
+        if isPermissionError e then return () else throwIO e

src/Stack/SDist.hs

@@ -12,7 +12,7 @@ module Stack.SDist
   , readLocalPackage
   ) where
 
-import qualified Codec.Archive.Tar as Tar
+import qualified Codec.Archive.Tar.Utf8 as Tar
 import qualified Codec.Archive.Tar.Entry as Tar
 import qualified Codec.Compression.GZip as GZip
 import           Conduit ( runConduitRes, sourceLazy, sinkFileCautious )

stack.cabal

@@ -151,6 +151,7 @@ flag supported-build
 
 library
   exposed-modules:
+      Codec.Archive.Tar.Utf8
       Control.Concurrent.Execute
       Data.Attoparsec.Args
       Data.Attoparsec.Combinators