Gnu tar long filenames

.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

Codec/Archive/Tar/Entry.hs

@@ -48,6 +48,7 @@ module Codec.Archive.Tar.Entry (
   fileEntry,
   directoryEntry,
   longLinkEntry,
+  longSymLinkEntry,
 
   -- * Standard file permissions
   -- | For maximum portability when constructing archives use only these file

Codec/Archive/Tar/Pack.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE LambdaCase #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Codec.Archive.Tar
@@ -23,6 +24,7 @@ module Codec.Archive.Tar.Pack (
 
 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
          ( (</>) )
@@ -80,24 +82,35 @@ preparePaths baseDir paths =
 packPaths :: FilePath -> [FilePath] -> IO [Entry]
 packPaths baseDir paths =
   fmap concat $ interleave
-    [ do let tarpath = toTarPath' isDir relpath
+    [ do let tarpathRes = toTarPath' isDir relpath
          isSymlink <- pathIsSymbolicLink filepath
-         if | isSymlink -> withLongLinkEntry filepath tarpath packSymlinkEntry
-            | isDir -> withLongLinkEntry filepath tarpath packDirectoryEntry
-            | otherwise -> withLongLinkEntry filepath tarpath packFileEntry
+         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
-      -> ToTarPathResult
+      -> TarPath
       -> (FilePath -> TarPath -> IO Entry)
       -> IO [Entry]
-    withLongLinkEntry _ FileNameEmpty _ = throwIO $ userError "File name empty"
-    withLongLinkEntry filepath (FileNameOK tarpath) f = (:[]) <$> f filepath tarpath
-    withLongLinkEntry filepath (FileNameTooLong tarpath) f = do
+    withLongLinkEntry filepath tarpath f = do
       mainEntry <- f filepath tarpath
       pure [longLinkEntry filepath, mainEntry]
 
@@ -156,6 +169,12 @@ packSymlinkEntry :: FilePath -- ^ Full path to find the file on the local disk
                  -> 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

Codec/Archive/Tar/Types.hs

@@ -30,6 +30,7 @@ module Codec.Archive.Tar.Types (
 
   simpleEntry,
   longLinkEntry,
+  longSymLinkEntry,
   fileEntry,
   symlinkEntry,
   directoryEntry,
@@ -265,6 +266,23 @@ longLinkEntry tarpath = Entry {
     entryFormat      = GnuFormat
   }
 
+-- | [GNU extension](https://www.gnu.org/software/tar/manual/html_node/Standard.html)
+-- to store a link target too long to fit into 'entryTarPath'
+-- as 'OtherEntryType' @\'K\'@ with the full filepath as 'entryContent'.
+-- The next entry must contain the actual
+-- data with truncated 'entryTarPath'.
+--
+-- @since 0.6.0.0
+longSymLinkEntry :: FilePath -> Entry
+longSymLinkEntry linkTarget = Entry {
+    entryTarPath     = TarPath (BS.Char8.pack "././@LongLink") BS.empty,
+    entryContent     = OtherEntryType 'K' (LBS.fromStrict $ packAscii linkTarget) (fromIntegral $ length linkTarget),
+    entryPermissions = ordinaryFilePermissions,
+    entryOwnership   = Ownership "" "" 0 0,
+    entryTime        = 0,
+    entryFormat      = GnuFormat
+  }
+
 -- | A tar 'Entry' for a directory.
 --
 -- Entry fields such as file permissions and ownership have default values.

Codec/Archive/Tar/Unpack.hs

@@ -22,6 +22,7 @@ import Codec.Archive.Tar.Check
 import Data.Bits
          ( testBit )
 import Data.List (partition, nub)
+import Data.Maybe ( fromMaybe )
 import qualified Data.ByteString.Char8 as Char8
 import qualified Data.ByteString.Lazy as BS
 import System.FilePath
@@ -32,6 +33,7 @@ import System.Directory
          ( createDirectoryIfMissing, copyFile, setPermissions, getDirectoryContents, doesDirectoryExist, createDirectoryLink, createFileLink )
 import Control.Exception
          ( Exception, throwIO, handle )
+import System.IO ( stderr, hPutStr )
 import System.IO.Error
          ( ioeGetErrorType )
 import GHC.IO (unsafeInterleaveIO)
@@ -73,7 +75,7 @@ import System.IO.Error
 --
 unpack :: Exception e => FilePath -> Entries e -> IO ()
 unpack baseDir entries = do
-  uEntries <- unpackEntries [] (checkSecurity entries)
+  uEntries <- unpackEntries Nothing Nothing [] (checkSecurity entries)
   let (hardlinks, symlinks) = partition (\(_, _, x) -> x) uEntries
   -- handle hardlinks first, in case a symlink points to it
   handleHardLinks hardlinks
@@ -83,32 +85,49 @@ unpack baseDir entries = do
     -- 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 _ -> do
-        extractFile (entryPermissions entry) (entryPath entry) file (entryTime entry)
-        unpackEntries links es
-      Directory         -> do
-        extractDir (entryPath entry) (entryTime entry)
-        unpackEntries links es
-      HardLink     link -> (unpackEntries $! saveLink True (entryPath entry) link links) es
-      SymbolicLink link -> (unpackEntries $! saveLink False (entryPath entry) link links) es
-      OtherEntryType 'L' (Char8.unpack . BS.toStrict -> fn) _ ->
-        case es of
-             (Next entry' es') -> case entryContent entry' of
-               NormalFile file _ -> do
-                extractFile (entryPermissions entry') fn file (entryTime entry')
-                unpackEntries links es'
-               Directory         -> extractDir fn (entryTime entry')
-                                 >> unpackEntries links es'
-               HardLink     link -> (unpackEntries $! saveLink True fn link links) es'
-               SymbolicLink link -> (unpackEntries $! saveLink False fn link links) es'
-               OtherEntryType 'L' _ _ -> throwIO $ userError "Two subsequent OtherEntryType 'L'"
-               _ -> unpackEntries links es'
-             (Fail err)      -> either throwIO throwIO err
-             Done            -> throwIO $ userError "././@LongLink without a subsequent entry"
-      _ -> unpackEntries links es --ignore other file types
+    unpackEntries :: Exception e
+                  => Maybe LinkTarget
+                  -> Maybe FilePath
+                  -> [(FilePath, FilePath, Bool)]     -- ^ links (path, link, isHardLink)
+                  -> Entries (Either e FileNameError) -- ^ entries
+                  -> IO [(FilePath, FilePath, Bool)]
+    unpackEntries _ _ _     (Fail err)      = either throwIO throwIO err
+    unpackEntries _ _ links Done            = return links
+    unpackEntries mLink mPath links (Next entry es) = do
+      let path = fromMaybe (entryPath entry) mPath
+      case entryContent entry of
+        NormalFile file _
+          | Just _ <- mLink -> throwIO $ userError "Expected SymbolicLink or HardLink after OtherEntryType K"
+          | otherwise -> do
+              extractFile (entryPermissions entry) path file (entryTime entry)
+              unpackEntries Nothing Nothing links es
+        Directory
+          | Just _ <- mLink -> throwIO $ userError "Expected SymbolicLink or HardLink after OtherEntryType K"
+          | otherwise -> do
+              extractDir path (entryTime entry)
+              unpackEntries Nothing Nothing links es
+        HardLink     link -> do
+          let linkTarget = fromMaybe link mLink
+          (unpackEntries Nothing Nothing $! saveLink True path linkTarget links) es
+        SymbolicLink link -> do
+          let linkTarget = fromMaybe link mLink
+          (unpackEntries Nothing Nothing $! saveLink False path linkTarget links) es
+        OtherEntryType 'L' fn _
+          | Just _ <- mPath -> throwIO $ userError "Two subsequent OtherEntryType L"
+          | otherwise -> unpackEntries mLink (Just . Char8.unpack . BS.toStrict $ fn) links es
+        OtherEntryType 'K' link _
+          | Just _ <- mLink -> throwIO $ userError "Two subsequent OtherEntryType K"
+          | otherwise -> unpackEntries (Just . LinkTarget . BS.toStrict $ link) mPath links es
+        OtherEntryType _ _ _
+          | Just _ <- mLink -> throwIO $ userError "Unknown entry type following OtherEntryType K"
+          | Just _ <- mPath -> throwIO $ userError "Unknown entry type following OtherEntryType L"
+          | otherwise -> do
+              -- the spec demands that we attempt to extract as normal file on unknown typecode,
+              -- but we just skip it
+              unpackEntries Nothing Nothing links es
+        _ -> do
+          unpackEntries Nothing Nothing links es -- ignore other file types
+
 
     extractFile permissions path content mtime = do
       -- Note that tar archives do not make sure each directory is created

tar.cabal

@@ -23,10 +23,10 @@ description:     This library is for working with \"@.tar@\" archive files. It
                  content using an index.
 build-type:      Simple
 cabal-version:   2.0
-extra-source-files: changelog.md
+extra-source-files: test/data/long.tar
+extra-doc-files: changelog.md
 tested-with:     GHC==9.8.1, GHC==9.6.3, GHC==9.4.8, GHC==9.2.8, GHC==9.0.2,
-                 GHC==8.10.7, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4,
-                 GHC==8.2.2, GHC==8.0.2
+                 GHC==8.10.7, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4
 
 source-repository head
   type: git
@@ -44,7 +44,7 @@ library
 
 library tar-internal
   default-language: Haskell2010
-  build-depends: base       >= 4.9  && < 5,
+  build-depends: base       >= 4.11.0.0  && < 5,
                  array                 < 0.6,
                  bytestring >= 0.10 && < 0.13,
                  containers >= 0.2  && < 0.8,
@@ -87,6 +87,7 @@ test-suite properties
                  containers,
                  deepseq,
                  directory >= 1.2,
+                 file-embed,
                  filepath,
                  QuickCheck       == 2.*,
                  tar-internal,

test/Codec/Archive/Tar/Pack/Tests.hs

@@ -1,9 +1,17 @@
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Codec.Archive.Tar.Pack.Tests
   ( prop_roundtrip
+  , unit_roundtrip
   ) where
 
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as BL
+import Data.FileEmbed
+import qualified Codec.Archive.Tar as Tar
 import qualified Codec.Archive.Tar.Pack as Pack
 import Codec.Archive.Tar.Types (Entries(..))
 import qualified Codec.Archive.Tar.Unpack as Unpack
@@ -49,3 +57,10 @@ prop_roundtrip xss (ASCIIString cnt)
 mkFilePath :: ASCIIString -> FilePath
 mkFilePath (ASCIIString xs) = makeValid $
   filter (\c -> not $ isPathSeparator c || c == '.') xs
+
+unit_roundtrip :: Property
+unit_roundtrip =
+  let tar :: BL.ByteString = BL.fromStrict $(embedFile "test/data/long.tar")
+      entries = Tar.foldEntries (:) [] (const []) (Tar.read tar)
+  in Tar.write entries === tar
+

test/Properties.hs

@@ -55,7 +55,8 @@ main =
       ]
 
     , testGroup "pack" [
-      testProperty "roundtrip" Pack.prop_roundtrip
+      testProperty "roundtrip" Pack.prop_roundtrip,
+      testProperty "long symlink" Pack.unit_roundtrip
       ]
     ]