Add support for over-long filepaths via GNU extension and fix hardlinks

.github/workflows/arm.yml

@@ -33,10 +33,10 @@ jobs:
         uses: docker://hasufell/arm32v7-ubuntu-haskell:focal
         name: Run build (arm32v7 linux)
         with:
-          args: sh -c "curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | BOOTSTRAP_HASKELL_NONINTERACTIVE=1 BOOTSTRAP_HASKELL_INSTALL_NO_STACK=1 BOOTSTRAP_HASKELL_GHC_VERSION=9.2.8 sh && cabal update && cabal test -w ~/.ghcup/bin/ghc"
+          args: sh -c "curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | BOOTSTRAP_HASKELL_NONINTERACTIVE=1 BOOTSTRAP_HASKELL_INSTALL_NO_STACK=1 BOOTSTRAP_HASKELL_GHC_VERSION=9.2.8 sh && cabal update && cabal test -w ~/.ghcup/bin/ghc" --test-show-details=direct
 
       - if: matrix.arch == 'arm64v8'
         uses: docker://hasufell/arm64v8-ubuntu-haskell:focal
         name: Run build (arm64v8 linux)
         with:
-          args: sh -c "curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | BOOTSTRAP_HASKELL_NONINTERACTIVE=1 BOOTSTRAP_HASKELL_INSTALL_NO_STACK=1 sh && cabal update && cabal test -w ~/.ghcup/bin/ghc"
+          args: sh -c "curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | BOOTSTRAP_HASKELL_NONINTERACTIVE=1 BOOTSTRAP_HASKELL_INSTALL_NO_STACK=1 sh && cabal update && cabal test -w ~/.ghcup/bin/ghc" --test-show-details=direct

.github/workflows/centos.yml

@@ -22,4 +22,4 @@ jobs:
       run: |
         source ~/.ghcup/env
         cabal update
-        cabal test
+        cabal test --test-show-details=direct

.github/workflows/haskell-ci.yml

@@ -73,16 +73,6 @@ jobs:
             compilerVersion: 8.4.4
             setup-method: hvr-ppa
             allow-failure: false
-          - compiler: ghc-8.2.2
-            compilerKind: ghc
-            compilerVersion: 8.2.2
-            setup-method: hvr-ppa
-            allow-failure: false
-          - compiler: ghc-8.0.2
-            compilerKind: ghc
-            compilerVersion: 8.0.2
-            setup-method: hvr-ppa
-            allow-failure: false
       fail-fast: false
     steps:
       - name: apt

.github/workflows/i386.yml

@@ -23,4 +23,4 @@ jobs:
       run: |
         source ~/.ghcup/env
         cabal update
-        cabal test
+        cabal test --test-show-details=direct

.github/workflows/windows_and_macOS.yml

@@ -34,7 +34,7 @@ jobs:
       run: |
         bld() { cabal build pkg:tar:tests; }
         bld || bld || bld
-        cabal test
+        cabal test --test-show-details=direct
     - name: Haddock
       run: cabal haddock
     - name: SDist

Codec/Archive/Tar/Check.hs

@@ -16,6 +16,7 @@ module Codec.Archive.Tar.Check (
 
   -- * Security
   checkSecurity,
+  checkEntrySecurity,
   FileNameError(..),
 
   -- * Tarbombs
@@ -62,6 +63,7 @@ import qualified System.FilePath.Posix   as FilePath.Posix
 checkSecurity :: Entries e -> Entries (Either e FileNameError)
 checkSecurity = checkEntries checkEntrySecurity
 
+-- | @since 0.6.0.0
 checkEntrySecurity :: Entry -> Maybe FileNameError
 checkEntrySecurity entry = case entryContent entry of
     HardLink     link -> check (entryPath entry)

Codec/Archive/Tar/Entry.hs

@@ -47,6 +47,8 @@ module Codec.Archive.Tar.Entry (
   simpleEntry,
   fileEntry,
   directoryEntry,
+  longLinkEntry,
+  longSymLinkEntry,
 
   -- * Standard file permissions
   -- | For maximum portability when constructing archives use only these file
@@ -58,6 +60,7 @@ module Codec.Archive.Tar.Entry (
   -- * Constructing entries from disk files
   packFileEntry,
   packDirectoryEntry,
+  packSymlinkEntry,
   getDirectoryContentsRecursive,
 
   -- * TarPath type

Codec/Archive/Tar/Pack.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE LambdaCase #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Codec.Archive.Tar
@@ -14,19 +16,23 @@ module Codec.Archive.Tar.Pack (
     pack,
     packFileEntry,
     packDirectoryEntry,
+    packSymlinkEntry,
+    longLinkEntry,
 
     getDirectoryContentsRecursive,
   ) where
 
 import Codec.Archive.Tar.Types
-
+import Control.Monad (join, when, forM)
+import qualified Data.ByteString as BSS
 import qualified Data.ByteString.Lazy as BS
 import System.FilePath
          ( (</>) )
 import qualified System.FilePath as FilePath.Native
-         ( addTrailingPathSeparator, hasTrailingPathSeparator )
+         ( addTrailingPathSeparator, hasTrailingPathSeparator, splitDirectories )
 import System.Directory
          ( getDirectoryContents, doesDirectoryExist, getModificationTime
+         , pathIsSymbolicLink, getSymbolicLinkTarget
          , Permissions(..), getPermissions )
 import Data.Time.Clock
          ( UTCTime )
@@ -35,16 +41,17 @@ import Data.Time.Clock.POSIX
 import System.IO
          ( IOMode(ReadMode), withBinaryFile, hFileSize )
 import System.IO.Unsafe (unsafeInterleaveIO)
+import Control.Exception (throwIO)
+import Codec.Archive.Tar.Check (checkEntrySecurity)
 
 -- | Creates a tar archive from a list of directory or files. Any directories
 -- specified will have their contents included recursively. Paths in the
 -- archive will be relative to the given base directory.
 --
 -- This is a portable implementation of packing suitable for portable archives.
--- In particular it only constructs 'NormalFile' and 'Directory' entries. Hard
--- links and symbolic links are treated like ordinary files. It cannot be used
--- to pack directories containing recursive symbolic links. Special files like
--- FIFOs (named pipes), sockets or device files will also cause problems.
+-- In particular it only constructs 'NormalFile', 'Directory' and 'SymbolicLink'
+-- entries. Hard links are treated like ordinary files. Special files like
+-- FIFOs (named pipes), sockets or device files will cause problems.
 --
 -- An exception will be thrown for any file names that are too long to
 -- represent as a 'TarPath'.
@@ -70,15 +77,42 @@ preparePaths baseDir paths =
            else return [path]
     | path <- paths ]
 
+
+-- | Pack paths while accounting for overlong filepaths.
 packPaths :: FilePath -> [FilePath] -> IO [Entry]
 packPaths baseDir paths =
-  interleave
-    [ do tarpath <- either fail return (toTarPath isDir relpath)
-         if isDir then packDirectoryEntry filepath tarpath
-                  else packFileEntry      filepath tarpath
+  fmap concat $ interleave
+    [ do let tarpathRes = toTarPath' isDir relpath
+         isSymlink <- pathIsSymbolicLink filepath
+         case tarpathRes of
+           FileNameEmpty -> throwIO $ userError "File name empty"
+           FileNameOK tarpath
+             | isSymlink -> (:[]) <$> packSymlinkEntry filepath tarpath
+             | isDir     -> (:[]) <$> packDirectoryEntry filepath tarpath
+             | otherwise -> (:[]) <$> packFileEntry filepath tarpath
+           FileNameTooLong tarpath
+             | isSymlink -> do
+                 linkTarget <- getSymbolicLinkTarget filepath
+                 packSymlinkEntry' linkTarget tarpath >>= \case
+                   sym@(Entry { entryContent = SymbolicLink (LinkTarget bs) })
+                     | BSS.length bs > 100 -> do
+                        pure [longSymLinkEntry linkTarget, longLinkEntry filepath, sym]
+                   _ -> withLongLinkEntry filepath tarpath packSymlinkEntry
+             | isDir     -> withLongLinkEntry filepath tarpath packDirectoryEntry
+             | otherwise -> withLongLinkEntry filepath tarpath packFileEntry
     | relpath <- paths
     , let isDir    = FilePath.Native.hasTrailingPathSeparator filepath
           filepath = baseDir </> relpath ]
+  where
+    -- prepend the long filepath entry if necessary
+    withLongLinkEntry
+      :: FilePath
+      -> TarPath
+      -> (FilePath -> TarPath -> IO Entry)
+      -> IO [Entry]
+    withLongLinkEntry filepath tarpath f = do
+      mainEntry <- f filepath tarpath
+      pure [longLinkEntry filepath, mainEntry]
 
 interleave :: [IO a] -> IO [a]
 interleave = unsafeInterleaveIO . go
@@ -106,10 +140,10 @@ packFileEntry filepath tarpath = do
   content <- BS.readFile filepath
   let size = BS.length content
   return (simpleEntry tarpath (NormalFile content (fromIntegral size))) {
-    entryPermissions = if executable perms then executableFilePermissions
-                                           else ordinaryFilePermissions,
-    entryTime = mtime
-  }
+         entryPermissions = if executable perms then executableFilePermissions
+                                                else ordinaryFilePermissions,
+         entryTime = mtime
+         }
 
 -- | Construct a tar 'Entry' based on a local directory (but not its contents).
 --
@@ -125,6 +159,26 @@ packDirectoryEntry filepath tarpath = do
     entryTime = mtime
   }
 
+-- | Construct a tar 'Entry' based on a local symlink.
+--
+-- This automatically checks symlink safety via 'checkEntrySecurity'.
+--
+-- @since 0.6.0.0
+packSymlinkEntry :: FilePath -- ^ Full path to find the file on the local disk
+                 -> TarPath  -- ^ Path to use for the tar Entry in the archive
+                 -> IO Entry
+packSymlinkEntry filepath tarpath = do
+  linkTarget <- getSymbolicLinkTarget filepath
+  packSymlinkEntry' linkTarget tarpath
+
+packSymlinkEntry' :: String   -- ^ link target
+                  -> TarPath  -- ^ Path to use for the tar Entry in the archive
+                  -> IO Entry
+packSymlinkEntry' linkTarget tarpath = do
+  let entry tp = symlinkEntry tp linkTarget
+      safeReturn tp = maybe (pure tp) throwIO $ checkEntrySecurity tp
+  safeReturn $ entry tarpath
+
 -- | This is a utility function, much like 'getDirectoryContents'. The
 -- difference is that it includes the contents of subdirectories.
 --