From 4ed6bfc827a26500e3f26a349620606d84b5c464 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Mon, 11 Dec 2023 23:41:15 +0800 Subject: [PATCH] Implement Unicode support by utilizing PosixString and friends Fixes #78 --- Codec/Archive/Tar.hs | 27 +-- Codec/Archive/Tar/Check/Internal.hs | 120 +++++++----- Codec/Archive/Tar/Index/Internal.hs | 43 +++-- Codec/Archive/Tar/LongNames.hs | 36 ++-- Codec/Archive/Tar/Pack.hs | 80 ++++---- Codec/Archive/Tar/Read.hs | 12 +- Codec/Archive/Tar/Types.hs | 275 +++++++++++++++------------- Codec/Archive/Tar/Unpack.hs | 113 +++++++----- Codec/Archive/Tar/Write.hs | 106 ++++++----- cabal.project | 16 ++ htar/htar.cabal | 4 +- htar/htar.hs | 34 ++-- tar.cabal | 11 +- 13 files changed, 514 insertions(+), 363 deletions(-) diff --git a/Codec/Archive/Tar.hs b/Codec/Archive/Tar.hs index 2c097fb..0e39d23 100644 --- a/Codec/Archive/Tar.hs +++ b/Codec/Archive/Tar.hs @@ -165,9 +165,12 @@ import Codec.Archive.Tar.Check import Control.Exception (Exception, throw, catch) import qualified Data.ByteString.Lazy as BS -import System.IO (withFile, IOMode(..)) +import System.IO (IOMode(..)) import Prelude hiding (read) +import System.OsPath (OsPath) +import qualified System.File.OsPath as OSP + -- | Create a new @\".tar\"@ file from a directory of files. -- -- It is equivalent to calling the standard @tar@ program like so: @@ -199,11 +202,11 @@ import Prelude hiding (read) -- -- * @rwxr-xr-x@ for directories -- -create :: FilePath -- ^ Path of the \".tar\" file to write. - -> FilePath -- ^ Base directory - -> [FilePath] -- ^ Files and directories to archive, relative to base dir +create :: OsPath -- ^ Path of the \".tar\" file to write. + -> OsPath -- ^ Base directory + -> [OsPath] -- ^ Files and directories to archive, relative to base dir -> IO () -create tar base paths = BS.writeFile tar . write =<< pack base paths +create tar base paths = OSP.writeFile tar . write =<< pack base paths -- | Extract all the files contained in a @\".tar\"@ file. -- @@ -233,10 +236,10 @@ create tar base paths = BS.writeFile tar . write =<< pack base paths -- containing entries that point outside of the tarball (either absolute paths -- or relative paths) will be caught and an exception will be thrown. -- -extract :: FilePath -- ^ Destination directory - -> FilePath -- ^ Tarball +extract :: OsPath -- ^ Destination directory + -> OsPath -- ^ Tarball -> IO () -extract dir tar = unpack dir . read =<< BS.readFile tar +extract dir tar = unpack dir . read =<< OSP.readFile tar -- | Append new entries to a @\".tar\"@ file from a directory of files. -- @@ -244,11 +247,11 @@ extract dir tar = unpack dir . read =<< BS.readFile tar -- end of an existing tar file. Or if the file does not already exists then -- it behaves the same as 'create'. -- -append :: FilePath -- ^ Path of the \".tar\" file to write. - -> FilePath -- ^ Base directory - -> [FilePath] -- ^ Files and directories to archive, relative to base dir +append :: OsPath -- ^ Path of the \".tar\" file to write. + -> OsPath -- ^ Base directory + -> [OsPath] -- ^ Files and directories to archive, relative to base dir -> IO () append tar base paths = - withFile tar ReadWriteMode $ \hnd -> do + OSP.withFile tar ReadWriteMode $ \hnd -> do _ <- hSeekEndEntryOffset hnd Nothing BS.hPut hnd . write =<< pack base paths diff --git a/Codec/Archive/Tar/Check/Internal.hs b/Codec/Archive/Tar/Check/Internal.hs index c6dd30e..44c298a 100644 --- a/Codec/Archive/Tar/Check/Internal.hs +++ b/Codec/Archive/Tar/Check/Internal.hs @@ -4,6 +4,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE QuasiQuotes #-} {-# OPTIONS_GHC -Wno-orphans #-} ----------------------------------------------------------------------------- -- | @@ -50,6 +51,17 @@ import qualified System.FilePath as FilePath.Native import qualified System.FilePath.Windows as FilePath.Windows import qualified System.FilePath.Posix as FilePath.Posix +import System.OsPath (OsPath) +import System.OsPath.Posix (PosixPath) +import qualified System.OsPath as OSP +import qualified System.OsPath.Posix as PFP +import qualified System.OsPath.Windows as WFP + +import System.OsString.Posix (pstr) +import System.OsString (osstr) +import qualified System.OsString.Posix as PS +import qualified System.OsString.Windows as WS + -------------------------- -- Security @@ -72,57 +84,77 @@ import qualified System.FilePath.Posix as FilePath.Posix -- checkSecurity :: Entries e - -> GenEntries FilePath FilePath (Either (Either e DecodeLongNamesError) FileNameError) + -> GenEntries PosixPath PosixPath (Either (Either e DecodeLongNamesError) FileNameError) checkSecurity = checkEntries checkEntrySecurity . decodeLongNames -- | Worker of 'checkSecurity'. -- -- @since 0.6.0.0 -checkEntrySecurity :: GenEntry FilePath FilePath -> Maybe FileNameError +checkEntrySecurity :: GenEntry PosixPath PosixPath -> Maybe FileNameError checkEntrySecurity e = check (entryTarPath e) <|> case entryContent e of HardLink link -> check link SymbolicLink link -> - check (FilePath.Posix.takeDirectory (entryTarPath e) FilePath.Posix. link) + check (PFP.takeDirectory (entryTarPath e) PFP. link) _ -> Nothing where + checkPosix :: PosixPath -> Maybe FileNameError checkPosix name - | FilePath.Posix.isAbsolute name + | PFP.isAbsolute name = Just $ AbsoluteFileName name - | not (FilePath.Posix.isValid name) + | not (PFP.isValid name) = Just $ InvalidFileName name - | not (isInsideBaseDir (FilePath.Posix.splitDirectories name)) + | not (isInsideBaseDir (PFP.splitDirectories name)) = Just $ UnsafeLinkTarget name | otherwise = Nothing - checkNative (fromFilePathToNative -> name) - | FilePath.Native.isAbsolute name || FilePath.Native.hasDrive name - = Just $ AbsoluteFileName name - | not (FilePath.Native.isValid name) - = Just $ InvalidFileName name - | not (isInsideBaseDir (FilePath.Native.splitDirectories name)) - = Just $ UnsafeLinkTarget name + checkNative :: PosixPath -> Maybe FileNameError + checkNative name' + | OSP.isAbsolute name || OSP.hasDrive name + = Just $ AbsoluteFileName name' + | not (OSP.isValid name) + = Just $ InvalidFileName name' + | not (isInsideBaseDir' (OSP.splitDirectories name)) + = Just $ UnsafeLinkTarget name' | otherwise = Nothing + where + (Just name) = fromPosixPath name' - check name = checkPosix name <|> checkNative (fromFilePathToNative name) + check name = checkPosix name <|> checkNative name -isInsideBaseDir :: [FilePath] -> Bool +isInsideBaseDir :: [PosixPath] -> Bool isInsideBaseDir = go 0 where - go :: Word -> [FilePath] -> Bool + go :: Word -> [PosixPath] -> Bool + go !_ [] = True + go 0 (x : _) + | x == [pstr|..|] = False + go lvl (x : xs) + | x == [pstr|..|] = go (lvl - 1) xs + go lvl (x : xs) + | x == [pstr|.|] = go lvl xs + go lvl (_ : xs) = go (lvl + 1) xs + +isInsideBaseDir' :: [OsPath] -> Bool +isInsideBaseDir' = go 0 + where + go :: Word -> [OsPath] -> Bool go !_ [] = True - go 0 (".." : _) = False - go lvl (".." : xs) = go (lvl - 1) xs - go lvl ("." : xs) = go lvl xs + go 0 (x : _) + | x == [osstr|..|] = False + go lvl (x : xs) + | x == [osstr|..|] = go (lvl - 1) xs + go lvl (x : xs) + | x == [osstr|.|] = go lvl xs go lvl (_ : xs) = go (lvl + 1) xs -- | Errors arising from tar file names being in some way invalid or dangerous data FileNameError - = InvalidFileName FilePath - | AbsoluteFileName FilePath - | UnsafeLinkTarget FilePath + = InvalidFileName PosixPath + | AbsoluteFileName PosixPath + | UnsafeLinkTarget PosixPath -- ^ @since 0.6.0.0 deriving (Typeable) @@ -155,9 +187,9 @@ showFileNameError mb_plat err = case err of -- (or 'checkPortability'). -- checkTarbomb - :: FilePath + :: PosixPath -> Entries e - -> GenEntries FilePath FilePath (Either (Either e DecodeLongNamesError) TarBombError) + -> GenEntries PosixPath PosixPath (Either (Either e DecodeLongNamesError) TarBombError) checkTarbomb expectedTopDir = checkEntries (checkEntryTarbomb expectedTopDir) . decodeLongNames @@ -165,7 +197,7 @@ checkTarbomb expectedTopDir -- | Worker of 'checkTarbomb'. -- -- @since 0.6.0.0 -checkEntryTarbomb :: FilePath -> GenEntry FilePath linkTarget -> Maybe TarBombError +checkEntryTarbomb :: PosixPath -> GenEntry PosixPath linkTarget -> Maybe TarBombError checkEntryTarbomb expectedTopDir entry = do case entryContent entry of -- Global extended header aka XGLTYPE aka pax_global_header @@ -174,7 +206,7 @@ checkEntryTarbomb expectedTopDir entry = do -- Extended header referring to the next file in the archive aka XHDTYPE OtherEntryType 'x' _ _ -> Nothing _ -> - case FilePath.Posix.splitDirectories (entryTarPath entry) of + case PFP.splitDirectories (entryTarPath entry) of (topDir:_) | topDir == expectedTopDir -> Nothing _ -> Just $ TarBombError expectedTopDir (entryTarPath entry) @@ -182,10 +214,10 @@ checkEntryTarbomb expectedTopDir entry = do -- files outside of the intended directory. data TarBombError = TarBombError - FilePath -- ^ Path inside archive. + PosixPath -- ^ Path inside archive. -- -- @since 0.6.0.0 - FilePath -- ^ Expected top directory. + PosixPath -- ^ Expected top directory. deriving (Typeable) instance Exception TarBombError @@ -219,13 +251,13 @@ instance Show TarBombError where -- checkPortability :: Entries e - -> GenEntries FilePath FilePath (Either (Either e DecodeLongNamesError) PortabilityError) + -> GenEntries PosixPath PosixPath (Either (Either e DecodeLongNamesError) PortabilityError) checkPortability = checkEntries checkEntryPortability . decodeLongNames -- | Worker of 'checkPortability'. -- -- @since 0.6.0.0 -checkEntryPortability :: GenEntry FilePath linkTarget -> Maybe PortabilityError +checkEntryPortability :: GenEntry PosixPath linkTarget -> Maybe PortabilityError checkEntryPortability entry | entryFormat entry `elem` [V7Format, GnuFormat] = Just $ NonPortableFormat (entryFormat entry) @@ -233,29 +265,29 @@ checkEntryPortability entry | not (portableFileType (entryContent entry)) = Just NonPortableFileType - | not (all portableChar posixPath) + | not (PS.all portableChar posixPath) = Just $ NonPortableEntryNameChar posixPath - | not (FilePath.Posix.isValid posixPath) + | not (PFP.isValid posixPath) = Just $ NonPortableFileName "unix" (InvalidFileName posixPath) - | not (FilePath.Windows.isValid windowsPath) - = Just $ NonPortableFileName "windows" (InvalidFileName windowsPath) + | not (WFP.isValid windowsPath) + = Just $ NonPortableFileName "windows" (InvalidFileName posixPath) - | FilePath.Posix.isAbsolute posixPath + | PFP.isAbsolute posixPath = Just $ NonPortableFileName "unix" (AbsoluteFileName posixPath) - | FilePath.Windows.isAbsolute windowsPath - = Just $ NonPortableFileName "windows" (AbsoluteFileName windowsPath) + | WFP.isAbsolute windowsPath + = Just $ NonPortableFileName "windows" (AbsoluteFileName posixPath) - | any (=="..") (FilePath.Posix.splitDirectories posixPath) + | any (== [PS.pstr|..|]) (PFP.splitDirectories posixPath) = Just $ NonPortableFileName "unix" (InvalidFileName posixPath) - | any (=="..") (FilePath.Windows.splitDirectories windowsPath) - = Just $ NonPortableFileName "windows" (InvalidFileName windowsPath) + | any (== [WS.pstr|..|]) (WFP.splitDirectories windowsPath) + = Just $ NonPortableFileName "windows" (InvalidFileName posixPath) | otherwise = Nothing where - posixPath = entryTarPath entry - windowsPath = fromFilePathToWindowsPath posixPath + posixPath = entryTarPath entry + (Just windowsPath) = toWindowsPath posixPath portableFileType ftype = case ftype of NormalFile {} -> True @@ -264,13 +296,13 @@ checkEntryPortability entry Directory -> True _ -> False - portableChar c = c <= '\127' + portableChar c = PS.toChar c <= '\127' -- | Portability problems in a tar archive data PortabilityError = NonPortableFormat Format | NonPortableFileType - | NonPortableEntryNameChar FilePath + | NonPortableEntryNameChar PosixPath | NonPortableFileName PortabilityPlatform FileNameError deriving (Typeable) diff --git a/Codec/Archive/Tar/Index/Internal.hs b/Codec/Archive/Tar/Index/Internal.hs index bc5ac78..1e39998 100644 --- a/Codec/Archive/Tar/Index/Internal.hs +++ b/Codec/Archive/Tar/Index/Internal.hs @@ -65,7 +65,6 @@ import qualified Codec.Archive.Tar.Index.IntTrie as IntTrie import Codec.Archive.Tar.Index.IntTrie (IntTrie, IntTrieBuilder) import Codec.Archive.Tar.PackAscii -import qualified System.FilePath.Posix as FilePath import Data.Monoid (Monoid(..)) import Data.Monoid ((<>)) import Data.Word @@ -85,6 +84,14 @@ import Data.ByteString.Builder as BS import Data.ByteString.Builder.Extra as BS (toLazyByteStringWith, untrimmedStrategy) +import System.OsPath.Posix (PosixPath) +import qualified System.OsPath.Posix as PFP + +import System.OsString.Internal.Types (PosixString(..)) +import qualified System.OsString.Posix as PS + +import qualified Data.ByteString.Short as SBS + -- | An index of the entries in a tar file. -- -- This index type is designed to be quite compact and suitable to store either @@ -128,7 +135,7 @@ instance NFData TarIndex where -- cheaper if you don't look at them. -- data TarIndexEntry = TarFileEntry {-# UNPACK #-} !TarEntryOffset - | TarDir [(FilePath, TarIndexEntry)] + | TarDir [(PosixPath, TarIndexEntry)] deriving (Show, Typeable) @@ -154,7 +161,7 @@ type TarEntryOffset = Word32 -- -- * 'hReadEntryHeader' to read just the file metadata (e.g. its length); -- -lookup :: TarIndex -> FilePath -> Maybe TarIndexEntry +lookup :: TarIndex -> PosixPath -> Maybe TarIndexEntry lookup (TarIndex pathTable pathTrie _) path = do fpath <- toComponentIds pathTable path tentry <- IntTrie.lookup pathTrie $ map pathComponentIdToKey fpath @@ -166,31 +173,31 @@ lookup (TarIndex pathTable pathTrie _) path = do | (key, entry) <- entries ] -toComponentIds :: StringTable PathComponentId -> FilePath -> Maybe [PathComponentId] +toComponentIds :: StringTable PathComponentId -> PosixPath -> Maybe [PathComponentId] toComponentIds table = lookupComponents [] - . filter (/= BS.Char8.singleton '.') + . fmap (SBS.fromShort . getPosixString) + . filter (/= (PS.singleton $ PS.unsafeFromChar '.')) . splitDirectories - . packAscii where lookupComponents cs' [] = Just (reverse cs') lookupComponents cs' (c:cs) = case StringTable.lookup table c of Nothing -> Nothing Just cid -> lookupComponents (cid:cs') cs -fromComponentId :: StringTable PathComponentId -> PathComponentId -> FilePath -fromComponentId table = BS.Char8.unpack . StringTable.index table +fromComponentId :: StringTable PathComponentId -> PathComponentId -> PosixPath +fromComponentId table = PosixString . SBS.toShort . StringTable.index table -- | All the files in the index with their corresponding 'TarEntryOffset's. -- -- Note that the files are in no special order. If you intend to read all or -- most files then is is recommended to sort by the 'TarEntryOffset'. -- -toList :: TarIndex -> [(FilePath, TarEntryOffset)] +toList :: TarIndex -> [(PosixPath, TarEntryOffset)] toList (TarIndex pathTable pathTrie _) = [ (path, IntTrie.unValue off) | (cids, off) <- IntTrie.toList pathTrie - , let path = FilePath.joinPath (map (fromComponentId pathTable . keyToPathComponentId) cids) ] + , let path = PFP.joinPath (map (fromComponentId pathTable . keyToPathComponentId) cids) ] -- | Build a 'TarIndex' from a sequence of tar 'Entries'. The 'Entries' are @@ -227,7 +234,7 @@ addNextEntry entry (IndexBuilder stbl itrie nextOffset) = (nextEntryOffset entry nextOffset) where !entrypath = splitTarPath (entryTarPath entry) - (stbl', cids) = StringTable.inserts entrypath stbl + (stbl', cids) = StringTable.inserts ((SBS.fromShort . getPosixString) <$> entrypath) stbl itrie' = IntTrie.insert (map pathComponentIdToKey cids) (IntTrie.Value nextOffset) itrie -- | Use this function if you want to skip some entries and not add them to the @@ -281,17 +288,17 @@ nextEntryOffset entry offset = blocks :: Int64 -> TarEntryOffset blocks size = fromIntegral (1 + (size - 1) `div` 512) -type FilePathBS = BS.ByteString - -splitTarPath :: TarPath -> [FilePathBS] +splitTarPath :: TarPath -> [PosixPath] splitTarPath (TarPath name prefix) = splitDirectories prefix ++ splitDirectories name -splitDirectories :: FilePathBS -> [FilePathBS] +splitDirectories :: PosixPath -> [PosixPath] splitDirectories bs = - case BS.Char8.split '/' bs of - c:cs | BS.null c -> BS.Char8.singleton '/' : filter (not . BS.null) cs - cs -> filter (not . BS.null) cs + case PS.split sep bs of + c:cs | PS.null c -> PS.singleton sep : filter (not . PS.null) cs + cs -> filter (not . PS.null) cs + where + sep = PS.unsafeFromChar '/' ------------------------- diff --git a/Codec/Archive/Tar/LongNames.hs b/Codec/Archive/Tar/LongNames.hs index deac14f..6ab460d 100644 --- a/Codec/Archive/Tar/LongNames.hs +++ b/Codec/Archive/Tar/LongNames.hs @@ -11,6 +11,15 @@ import Control.Exception import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as BL +import System.OsPath (OsPath) +import System.OsPath.Posix (PosixPath) + +import System.OsString.Internal.Types (PosixString(..)) + +import qualified System.OsString.Posix as PS + +import qualified Data.ByteString.Short as SBS + -- | Errors raised by 'decodeLongNames'. data DecodeLongNamesError = TwoTypeKEntries @@ -29,7 +38,7 @@ instance Exception DecodeLongNamesError -- -- Input 'FilePath's must be POSIX file names, not native ones. encodeLongNames - :: GenEntry FilePath FilePath + :: GenEntry PosixPath PosixPath -> [Entry] encodeLongNames e = maybe id (:) mEntry $ maybe id (:) mEntry' [e''] where @@ -37,16 +46,16 @@ encodeLongNames e = maybe id (:) mEntry $ maybe id (:) mEntry' [e''] (mEntry', e'') = encodeTarPath e' encodeTarPath - :: GenEntry FilePath linkTarget + :: GenEntry PosixPath linkTarget -> (Maybe (GenEntry TarPath whatever), GenEntry TarPath linkTarget) -- ^ (LongLink entry, actual entry) -encodeTarPath e = case toTarPath' (entryTarPath e) of +encodeTarPath e = case splitLongPath (entryTarPath e) of FileNameEmpty -> (Nothing, e { entryTarPath = TarPath mempty mempty }) FileNameOK tarPath -> (Nothing, e { entryTarPath = tarPath }) FileNameTooLong tarPath -> (Just $ longLinkEntry $ entryTarPath e, e { entryTarPath = tarPath }) encodeLinkTarget - :: GenEntry tarPath FilePath + :: GenEntry tarPath PosixPath -> (Maybe (GenEntry TarPath LinkTarget), GenEntry tarPath LinkTarget) -- ^ (LongLink symlink entry, actual entry) encodeLinkTarget e = case entryContent e of @@ -62,12 +71,12 @@ encodeLinkTarget e = case entryContent e of OtherEntryType x y z -> (Nothing, e { entryContent = OtherEntryType x y z }) encodeLinkPath - :: FilePath + :: PosixPath -> (Maybe (GenEntry TarPath LinkTarget), LinkTarget) -encodeLinkPath lnk = case toTarPath' lnk of +encodeLinkPath lnk = case splitLongPath lnk of FileNameEmpty -> (Nothing, LinkTarget mempty) FileNameOK (TarPath name prefix) - | B.null prefix -> (Nothing, LinkTarget name) + | PS.null prefix -> (Nothing, LinkTarget name) | otherwise -> (Just $ longSymLinkEntry lnk, LinkTarget name) FileNameTooLong (TarPath name _) -> (Just $ longSymLinkEntry lnk, LinkTarget name) @@ -80,10 +89,10 @@ encodeLinkPath lnk = case toTarPath' lnk of -- Resolved 'FilePath's are still POSIX file names, not native ones. decodeLongNames :: Entries e - -> GenEntries FilePath FilePath (Either e DecodeLongNamesError) + -> GenEntries PosixPath PosixPath (Either e DecodeLongNamesError) decodeLongNames = go Nothing Nothing where - go :: Maybe FilePath -> Maybe FilePath -> Entries e -> GenEntries FilePath FilePath (Either e DecodeLongNamesError) + go :: Maybe PosixPath -> Maybe PosixPath -> Entries e -> GenEntries PosixPath PosixPath (Either e DecodeLongNamesError) go _ _ (Fail err) = Fail (Left err) go _ _ Done = Done @@ -126,16 +135,16 @@ decodeLongNames = go Nothing Nothing _ -> Fail $ Right NoLinkEntryAfterTypeKEntry -otherEntryPayloadToFilePath :: BL.ByteString -> FilePath -otherEntryPayloadToFilePath = B.unpack . B.takeWhile (/= '\0') . BL.toStrict +otherEntryPayloadToFilePath :: BL.ByteString -> PosixPath +otherEntryPayloadToFilePath = PosixString . SBS.toShort . B.takeWhile (/= '\0') . BL.toStrict -castEntry :: Entry -> GenEntry FilePath FilePath +castEntry :: Entry -> GenEntry PosixPath PosixPath castEntry e = e { entryTarPath = fromTarPathToPosixPath (entryTarPath e) , entryContent = castEntryContent (entryContent e) } -castEntryContent :: EntryContent -> GenEntryContent FilePath +castEntryContent :: EntryContent -> GenEntryContent PosixPath castEntryContent = \case NormalFile x y -> NormalFile x y Directory -> Directory @@ -145,3 +154,4 @@ castEntryContent = \case BlockDevice x y -> BlockDevice x y NamedPipe -> NamedPipe OtherEntryType x y z -> OtherEntryType x y z + diff --git a/Codec/Archive/Tar/Pack.hs b/Codec/Archive/Tar/Pack.hs index 9543193..6fdb116 100644 --- a/Codec/Archive/Tar/Pack.hs +++ b/Codec/Archive/Tar/Pack.hs @@ -3,6 +3,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE QuasiQuotes #-} ----------------------------------------------------------------------------- -- | -- Module : Codec.Archive.Tar @@ -36,7 +37,7 @@ import System.FilePath ( () ) import qualified System.FilePath as FilePath.Native ( addTrailingPathSeparator, hasTrailingPathSeparator, splitDirectories ) -import System.Directory +import System.Directory.OsPath ( listDirectory, doesDirectoryExist, getModificationTime , pathIsSymbolicLink, getSymbolicLinkTarget , Permissions(..), getPermissions, getFileSize ) @@ -45,11 +46,19 @@ import Data.Time.Clock import Data.Time.Clock.POSIX ( utcTimeToPOSIXSeconds ) import System.IO - ( IOMode(ReadMode), openBinaryFile, hFileSize ) + ( IOMode(ReadMode), hFileSize ) +import qualified System.File.OsPath as OSP import System.IO.Unsafe (unsafeInterleaveIO) import Control.Exception (throwIO, SomeException) import Codec.Archive.Tar.Check.Internal (checkEntrySecurity) +import System.OsPath (OsPath) +import System.OsPath.Posix (PosixPath) + +import qualified System.OsPath as OSP +import qualified System.OsString as OS + + -- | 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. @@ -66,8 +75,8 @@ import Codec.Archive.Tar.Check.Internal (checkEntrySecurity) -- and files are read one by one as the list of entries is consumed. -- pack - :: FilePath -- ^ Base directory - -> [FilePath] -- ^ Files and directories to pack, relative to the base dir + :: OsPath -- ^ Base directory + -> [OsPath] -- ^ Files and directories to pack, relative to the base dir -> IO [Entry] pack = packAndCheck (const Nothing) @@ -78,9 +87,9 @@ pack = packAndCheck (const Nothing) -- -- @since 0.6.0.0 packAndCheck - :: (GenEntry FilePath FilePath -> Maybe SomeException) - -> FilePath -- ^ Base directory - -> [FilePath] -- ^ Files and directories to pack, relative to the base dir + :: (GenEntry PosixPath PosixPath -> Maybe SomeException) + -> OsPath -- ^ Base directory + -> [OsPath] -- ^ Files and directories to pack, relative to the base dir -> IO [Entry] packAndCheck secCB baseDir relpaths = do paths <- preparePaths baseDir relpaths @@ -88,34 +97,36 @@ packAndCheck secCB baseDir relpaths = do traverse_ (maybe (pure ()) throwIO . secCB) entries pure $ concatMap encodeLongNames entries -preparePaths :: FilePath -> [FilePath] -> IO [FilePath] +preparePaths :: OsPath -> [OsPath] -> IO [OsPath] preparePaths baseDir = fmap concat . interleave . map go where + go :: OsPath -> IO [OsPath] go relpath = do - let abspath = baseDir relpath + let abspath = baseDir OSP. relpath isDir <- doesDirectoryExist abspath isSymlink <- pathIsSymbolicLink abspath if isDir && not isSymlink then do entries <- getDirectoryContentsRecursive abspath - let entries' = map (relpath ) entries - return $ if null relpath + let entries' = map (relpath OSP.) entries + return $ if OS.null relpath then entries' - else FilePath.Native.addTrailingPathSeparator relpath : entries' + else OSP.addTrailingPathSeparator relpath : entries' else return [relpath] -- | Pack paths while accounting for overlong filepaths. packPaths - :: FilePath - -> [FilePath] - -> IO [GenEntry FilePath FilePath] -packPaths baseDir paths = interleave $ flip map paths $ \relpath -> do - let isDir = FilePath.Native.hasTrailingPathSeparator abspath - abspath = baseDir relpath + :: OsPath + -> [OsPath] + -> IO [GenEntry PosixPath PosixPath] +packPaths baseDir paths = interleave $ flip map paths $ \relpath' -> do + let isDir = OSP.hasTrailingPathSeparator abspath + abspath = baseDir OSP. relpath' isSymlink <- pathIsSymbolicLink abspath let mkEntry | isSymlink = packSymlinkEntry | isDir = packDirectoryEntry | otherwise = packFileEntry + relpath <- toPosixPath' relpath' mkEntry abspath relpath interleave :: [IO a] -> IO [a] @@ -136,7 +147,7 @@ interleave = unsafeInterleaveIO . go -- * The file contents is read lazily. -- packFileEntry - :: FilePath -- ^ Full path to find the file on the local disk + :: OsPath -- ^ Full path to find the file on the local disk -> tarPath -- ^ Path to use for the tar 'Entry' in the archive -> IO (GenEntry tarPath linkTarget) packFileEntry filepath tarpath = do @@ -149,10 +160,10 @@ packFileEntry filepath tarpath = do -- If file is short enough, just read it strictly -- so that no file handle dangles around indefinitely. then do - cnt <- B.readFile filepath + cnt <- OSP.readFile' filepath pure (BL.fromStrict cnt, fromIntegral $ B.length cnt) else do - hndl <- openBinaryFile filepath ReadMode + hndl <- OSP.openBinaryFile filepath ReadMode -- File size could have changed between measuring approxSize -- and here. Measuring again. sz <- hFileSize hndl @@ -176,7 +187,7 @@ packFileEntry filepath tarpath = do -- Directory ownership and detailed permissions are not preserved. -- packDirectoryEntry - :: FilePath -- ^ Full path to find the file on the local disk + :: OsPath -- ^ Full path to find the file on the local disk -> tarPath -- ^ Path to use for the tar 'Entry' in the archive -> IO (GenEntry tarPath linkTarget) packDirectoryEntry filepath tarpath = do @@ -191,11 +202,12 @@ packDirectoryEntry filepath tarpath = do -- -- @since 0.6.0.0 packSymlinkEntry - :: FilePath -- ^ Full path to find the file on the local disk + :: OsPath -- ^ Full path to find the file on the local disk -> tarPath -- ^ Path to use for the tar 'Entry' in the archive - -> IO (GenEntry tarPath FilePath) + -> IO (GenEntry tarPath PosixPath) packSymlinkEntry filepath tarpath = do - linkTarget <- getSymbolicLinkTarget filepath + linkTarget' <- getSymbolicLinkTarget filepath + linkTarget <- toPosixPath' linkTarget' pure $ symlinkEntry tarpath linkTarget -- | This is a utility function, much like 'listDirectory'. The @@ -216,14 +228,14 @@ packSymlinkEntry filepath tarpath = do -- If the source directory structure changes before the result is used, -- the behaviour is undefined. -- -getDirectoryContentsRecursive :: FilePath -> IO [FilePath] +getDirectoryContentsRecursive :: OsPath -> IO [OsPath] getDirectoryContentsRecursive dir0 = - fmap tail (recurseDirectories dir0 [""]) + fmap tail (recurseDirectories dir0 [[OS.osstr||]]) -recurseDirectories :: FilePath -> [FilePath] -> IO [FilePath] +recurseDirectories :: OsPath -> [OsPath] -> IO [OsPath] recurseDirectories _ [] = return [] recurseDirectories base (dir:dirs) = unsafeInterleaveIO $ do - (files, dirs') <- collect [] [] =<< listDirectory (base dir) + (files, dirs') <- collect [] [] =<< listDirectory (base OSP. dir) files' <- recurseDirectories base (dirs' ++ dirs) return (dir : files ++ files') @@ -231,15 +243,15 @@ recurseDirectories base (dir:dirs) = unsafeInterleaveIO $ do where collect files dirs' [] = return (reverse files, reverse dirs') collect files dirs' (entry:entries) = do - let dirEntry = dir entry - dirEntry' = FilePath.Native.addTrailingPathSeparator dirEntry - isDirectory <- doesDirectoryExist (base dirEntry) - isSymlink <- pathIsSymbolicLink (base dirEntry) + let dirEntry = dir OSP. entry + dirEntry' = OSP.addTrailingPathSeparator dirEntry + isDirectory <- doesDirectoryExist (base OSP. dirEntry) + isSymlink <- pathIsSymbolicLink (base OSP. dirEntry) if isDirectory && not isSymlink then collect files (dirEntry':dirs') entries else collect (dirEntry:files) dirs' entries -getModTime :: FilePath -> IO EpochTime +getModTime :: OsPath -> IO EpochTime getModTime path = do -- The directory package switched to the new time package t <- getModificationTime path diff --git a/Codec/Archive/Tar/Read.hs b/Codec/Archive/Tar/Read.hs index 67816bb..4f7fe05 100644 --- a/Codec/Archive/Tar/Read.hs +++ b/Codec/Archive/Tar/Read.hs @@ -32,6 +32,11 @@ import qualified Data.ByteString.Lazy as LBS import Prelude hiding (read) +import System.OsString.Internal.Types (PosixString(..)) +import qualified Data.ByteString.Short as SBS + +import qualified System.OsString.Posix as PS + -- | Errors that can be encountered when parsing a Tar archive. data FormatError = TruncatedArchive @@ -122,8 +127,7 @@ getEntry bs '7' -> NormalFile content size _ -> OtherEntryType typecode content size, entryPermissions = mode, - entryOwnership = Ownership (BS.Char8.unpack uname) - (BS.Char8.unpack gname) uid gid, + entryOwnership = Ownership uname gname uid gid, entryTime = mtime, entryFormat = format } @@ -213,8 +217,8 @@ getByte off bs = BS.Char8.index bs off getChars :: Int -> Int -> BS.ByteString -> BS.ByteString getChars = getBytes -getString :: Int -> Int -> BS.ByteString -> BS.ByteString -getString off len = BS.copy . BS.Char8.takeWhile (/='\0') . getBytes off len +getString :: Int -> Int -> BS.ByteString -> PS.PosixString +getString off len = PS.takeWhile (/= PS.unsafeFromChar '\0') . PosixString. SBS.toShort . getBytes off len {-# SPECIALISE readOct :: BS.ByteString -> Maybe Int #-} {-# SPECIALISE readOct :: BS.ByteString -> Maybe Int64 #-} diff --git a/Codec/Archive/Tar/Types.hs b/Codec/Archive/Tar/Types.hs index 48355fc..18d3c25 100644 --- a/Codec/Archive/Tar/Types.hs +++ b/Codec/Archive/Tar/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, BangPatterns, DeriveTraversable, ScopedTypeVariables, RankNTypes #-} +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, BangPatterns, DeriveTraversable, ScopedTypeVariables, RankNTypes, QuasiQuotes, MultiWayIf #-} ----------------------------------------------------------------------------- -- | -- Module : Codec.Archive.Tar.Types @@ -45,18 +45,22 @@ module Codec.Archive.Tar.Types ( TarPath(..), toTarPath, toTarPath', + splitLongPath, ToTarPathResult(..), fromTarPath, fromTarPathToPosixPath, fromTarPathToWindowsPath, - fromFilePathToNative, LinkTarget(..), toLinkTarget, fromLinkTarget, fromLinkTargetToPosixPath, fromLinkTargetToWindowsPath, - fromFilePathToWindowsPath, + + toPosixPath, + toPosixPath', + toWindowsPath, + fromPosixPath, GenEntries(..), Entries, @@ -76,6 +80,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS.Char8 import qualified Data.ByteString.Lazy as LBS import Control.DeepSeq +import Control.Monad.Catch (MonadThrow, throwM) import Control.Exception (Exception, displayException) import qualified System.FilePath as FilePath.Native @@ -88,6 +93,20 @@ import qualified System.FilePath.Windows as FilePath.Windows import System.Posix.Types ( FileMode ) +import System.OsString.Posix (pstr) +import System.OsString.Internal.Types (OsString(..), WindowsString(..), PosixString(..)) +import qualified System.OsString.Posix as PS +import qualified System.OsString.Windows as WS + +import System.OsPath (OsPath) +import System.OsPath.Windows (WindowsPath) +import System.OsPath.Posix (PosixPath) +import qualified System.OsPath as OSP +import qualified System.OsPath.Posix as PFP +import qualified System.OsPath.Windows as WFP + +import qualified Data.ByteString.Short as SBS + import Codec.Archive.Tar.PackAscii type FileSize = Int64 @@ -130,13 +149,13 @@ data GenEntry tarPath linkTarget = Entry { -- type Entry = GenEntry TarPath LinkTarget --- | Native 'FilePath' of the file or directory within the archive. +-- | Native 'OsPath' of the file or directory within the archive. -- -entryPath :: GenEntry TarPath linkTarget -> FilePath +entryPath :: GenEntry TarPath linkTarget -> OsString entryPath = fromTarPath . entryTarPath -- | Polymorphic content of a tar archive entry. High-level interfaces --- commonly work with 'GenEntryContent' 'FilePath', +-- commonly work with 'GenEntryContent' 'OsPath', -- while low level uses 'GenEntryContent' 'LinkTarget'. -- -- Portable archives should contain only 'NormalFile' and 'Directory'. @@ -162,10 +181,10 @@ type EntryContent = GenEntryContent LinkTarget data Ownership = Ownership { -- | The owner user name. Should be set to @\"\"@ if unknown. - ownerName :: String, + ownerName :: PosixString, -- | The owner group name. Should be set to @\"\"@ if unknown. - groupName :: String, + groupName :: PosixString, -- | Numeric owner user id. Should be set to @0@ if unknown. ownerId :: {-# UNPACK #-} !Int, @@ -241,7 +260,7 @@ simpleEntry tarpath content = Entry { Directory -> directoryPermissions SymbolicLink _ -> symbolicLinkPermission _ -> ordinaryFilePermissions, - entryOwnership = Ownership "" "" 0 0, + entryOwnership = Ownership PS.empty PS.empty 0 0, entryTime = 0, entryFormat = UstarFormat } @@ -273,12 +292,12 @@ symlinkEntry name targetLink = -- See [What exactly is the GNU tar ././@LongLink "trick"?](https://stackoverflow.com/questions/2078778/what-exactly-is-the-gnu-tar-longlink-trick) -- -- @since 0.6.0.0 -longLinkEntry :: FilePath -> GenEntry TarPath linkTarget -longLinkEntry tarpath = Entry { - entryTarPath = TarPath (BS.Char8.pack "././@LongLink") BS.empty, - entryContent = OtherEntryType 'L' (LBS.fromStrict $ packAscii tarpath) (fromIntegral $ length tarpath), +longLinkEntry :: PosixPath -> GenEntry TarPath linkTarget +longLinkEntry (PosixString tarpath) = Entry { + entryTarPath = TarPath [pstr|././@LongLink|] PS.empty, + entryContent = OtherEntryType 'L' (LBS.fromStrict . SBS.fromShort $ tarpath) (fromIntegral $ SBS.length tarpath), entryPermissions = ordinaryFilePermissions, - entryOwnership = Ownership "" "" 0 0, + entryOwnership = Ownership PS.empty PS.empty 0 0, entryTime = 0, entryFormat = GnuFormat } @@ -290,12 +309,12 @@ longLinkEntry tarpath = Entry { -- data with truncated 'entryTarPath'. -- -- @since 0.6.0.0 -longSymLinkEntry :: FilePath -> GenEntry TarPath linkTarget -longSymLinkEntry linkTarget = Entry { - entryTarPath = TarPath (BS.Char8.pack "././@LongLink") BS.empty, - entryContent = OtherEntryType 'K' (LBS.fromStrict . packAscii $ linkTarget) (fromIntegral $ length linkTarget), +longSymLinkEntry :: PosixPath -> GenEntry TarPath linkTarget +longSymLinkEntry (PosixString linkTarget) = Entry { + entryTarPath = TarPath [pstr|././@LongLink|] PS.empty, + entryContent = OtherEntryType 'K' (LBS.fromStrict . SBS.fromShort $ linkTarget) (fromIntegral $ SBS.length linkTarget), entryPermissions = ordinaryFilePermissions, - entryOwnership = Ownership "" "" 0 0, + entryOwnership = Ownership PS.empty PS.empty 0 0, entryTime = 0, entryFormat = GnuFormat } @@ -335,8 +354,8 @@ directoryEntry name = simpleEntry name Directory -- -- * The directory separator between the prefix and name is /not/ stored. -- -data TarPath = TarPath {-# UNPACK #-} !BS.ByteString -- path name, 100 characters max. - {-# UNPACK #-} !BS.ByteString -- path prefix, 155 characters max. +data TarPath = TarPath {-# UNPACK #-} !PosixPath -- path name, 100 characters max. + {-# UNPACK #-} !PosixPath -- path prefix, 155 characters max. deriving (Eq, Ord) instance NFData TarPath where @@ -345,9 +364,9 @@ instance NFData TarPath where instance Show TarPath where show = show . fromTarPath --- | Convert a 'TarPath' to a native 'FilePath'. +-- | Convert a 'TarPath' to a native 'OsPath'. -- --- The native 'FilePath' will use the native directory separator but it is not +-- The native 'OsPath' 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\"@ @@ -358,10 +377,14 @@ instance Show TarPath where -- responsibility to check for these conditions -- (e.g., using 'Codec.Archive.Tar.Check.checkEntrySecurity'). -- -fromTarPath :: TarPath -> FilePath -fromTarPath = BS.Char8.unpack . fromTarPathInternal FilePath.Native.pathSeparator +fromTarPath :: TarPath -> OsPath +#if defined(mingw32_HOST_OS) +fromTarPath = OsString . fromTarPathToWindowsPath +#else +fromTarPath = OsString . fromTarPathToPosixPath +#endif --- | Convert a 'TarPath' to a Unix\/Posix 'FilePath'. +-- | Convert a 'TarPath' to a Unix\/Posix 'OsPath'. -- -- The difference compared to 'fromTarPath' is that it always returns a Unix -- style path irrespective of the current operating system. @@ -369,10 +392,13 @@ fromTarPath = BS.Char8.unpack . fromTarPathInternal FilePath.Native.pathSeparato -- This is useful to check how a 'TarPath' would be interpreted on a specific -- operating system, eg to perform portability checks. -- -fromTarPathToPosixPath :: TarPath -> FilePath -fromTarPathToPosixPath = BS.Char8.unpack . fromTarPathInternal FilePath.Posix.pathSeparator +fromTarPathToPosixPath :: TarPath -> PosixPath +fromTarPathToPosixPath (TarPath name prefix) + | PS.null prefix = name + | PS.null name = prefix + | otherwise = prefix <> PS.cons PFP.pathSeparator name --- | Convert a 'TarPath' to a Windows 'FilePath'. +-- | Convert a 'TarPath' to a Windows 'OsPath'. -- -- The only difference compared to 'fromTarPath' is that it always returns a -- Windows style path irrespective of the current operating system. @@ -380,61 +406,82 @@ fromTarPathToPosixPath = BS.Char8.unpack . fromTarPathInternal FilePath.Posix.pa -- This is useful to check how a 'TarPath' would be interpreted on a specific -- operating system, eg to perform portability checks. -- -fromTarPathToWindowsPath :: TarPath -> FilePath -fromTarPathToWindowsPath = BS.Char8.unpack . fromTarPathInternal FilePath.Windows.pathSeparator - -fromTarPathInternal :: Char -> TarPath -> BS.ByteString -fromTarPathInternal sep (TarPath name prefix) - | BS.null prefix = adjustSeps name - | BS.null name = adjustSeps prefix - | sep == FilePath.Posix.pathSeparator = prefix <> BS.Char8.cons sep name - | otherwise = adjustSeps prefix <> BS.Char8.cons sep (adjustSeps name) - where - adjustSeps = BS.Char8.map $ \c -> if c == FilePath.Posix.pathSeparator then sep else c -{-# INLINE fromTarPathInternal #-} - --- | Convert a native 'FilePath' to a 'TarPath'. --- --- The conversion may fail if the 'FilePath' is empty or too long. +fromTarPathToWindowsPath :: MonadThrow m => TarPath -> m WindowsPath +fromTarPathToWindowsPath tarPath = do + let posix = fromTarPathToPosixPath tarPath + toWindowsPath posix + +-- | We assume UTF-8 on posix and UTF-16 on windows. +toWindowsPath :: MonadThrow m => PosixPath -> m WindowsPath +toWindowsPath posix = do + str <- PFP.decodeUtf posix + win <- WFP.encodeUtf str + pure $ WS.map (\c -> if WFP.isPathSeparator c then WFP.pathSeparator else c) win + +-- | We assume UTF-8 on posix and UTF-16 on windows. +toPosixPath :: MonadThrow m => WindowsPath -> m PosixPath +toPosixPath win = do + str <- WFP.decodeUtf win + posix <- PFP.encodeUtf str + pure $ PS.map (\c -> if PFP.isPathSeparator c then PFP.pathSeparator else c) posix + +-- | We assume UTF-8 on posix and UTF-16 on windows. +toPosixPath' :: MonadThrow m => OsPath -> m PosixPath +#if defined(mingw32_HOST_OS) +toPosixPath' (OsString ws) = toPosixPath ws +#else +toPosixPath' (OsString ps) = pure ps +#endif + +-- | We assume UTF-8 on posix and UTF-16 on windows. +fromPosixPath :: MonadThrow m => PosixPath -> m OsPath +#if defined(mingw32_HOST_OS) +fromPosixPath ps = OsPath <$> toWindowsPath ps +#else +fromPosixPath ps = pure $ OsString ps +#endif + + +-- | Convert a native 'OsPath' to a 'TarPath'. +-- +-- The conversion may fail if the 'OsPath' is empty or too long. -- Use 'toTarPath'' for a structured output. toTarPath :: Bool -- ^ Is the path for a directory? This is needed because for -- directories a 'TarPath' must always use a trailing @\/@. - -> FilePath + -> OsPath -> Either String TarPath toTarPath isDir path = case toTarPath' path' of - FileNameEmpty -> Left "File name empty" - FileNameOK tarPath -> Right tarPath - FileNameTooLong{} -> Left "File name too long" + Right (FileNameEmpty) -> Left "File name empty" + Right (FileNameOK tarPath) -> Right tarPath + Right (FileNameTooLong{}) -> Left "File name too long" + Left e -> Left $ displayException e where - path' = if isDir && not (FilePath.Native.hasTrailingPathSeparator path) - then path <> [FilePath.Native.pathSeparator] + path' = if isDir && not (OSP.hasTrailingPathSeparator path) + then path <> OSP.pack [OSP.pathSeparator] else path --- | Convert a native 'FilePath' to a 'TarPath'. +-- | Convert a native 'OsPath' to a 'TarPath'. -- Directory paths must always have a trailing @\/@, this is not checked. -- -- @since 0.6.0.0 toTarPath' - :: FilePath - -> ToTarPathResult -toTarPath' - = splitLongPath - . (if nativeSep == posixSep then id else adjustSeps) - where - nativeSep = FilePath.Native.pathSeparator - posixSep = FilePath.Posix.pathSeparator - adjustSeps = map $ \c -> if c == nativeSep then posixSep else c + :: MonadThrow m + => OsPath + -> m ToTarPathResult +toTarPath' osp' = do + posix <- toPosixPath' osp' + pure $ splitLongPath posix -- | Return type of 'toTarPath''. -- -- @since 0.6.0.0 data ToTarPathResult = FileNameEmpty - -- ^ 'FilePath' was empty, but 'TarPath' must be non-empty. + -- ^ 'OsPath' was empty, but 'TarPath' must be non-empty. | FileNameOK TarPath -- ^ All good, this is just a normal 'TarPath'. | FileNameTooLong TarPath - -- ^ 'FilePath' was longer than 255 characters, 'TarPath' contains + -- ^ 'OsPath' was longer than 255 characters, 'TarPath' contains -- a truncated part only. An actual entry must be preceded by -- 'longLinkEntry'. @@ -444,105 +491,85 @@ data ToTarPathResult -- The strategy is this: take the name-directory components in reverse order -- and try to fit as many components into the 100 long name area as possible. -- If all the remaining components fit in the 155 name area then we win. -splitLongPath :: FilePath -> ToTarPathResult -splitLongPath path = case reverse (FilePath.Posix.splitPath path) of +splitLongPath :: PosixPath -> ToTarPathResult +splitLongPath path = case reverse (PFP.splitPath path) of [] -> FileNameEmpty c : cs -> case packName nameMax (c :| cs) of - Nothing -> FileNameTooLong $ TarPath (packAscii $ take 100 path) BS.empty - Just (name, []) -> FileNameOK $! TarPath (packAscii name) BS.empty + Nothing -> FileNameTooLong $ TarPath (PS.take 100 path) PS.empty + Just (name, []) -> FileNameOK $! TarPath name PS.empty Just (name, first:rest) -> case packName prefixMax remainder of - Nothing -> FileNameTooLong $ TarPath (packAscii $ take 100 path) BS.empty - Just (_ , _:_) -> FileNameTooLong $ TarPath (packAscii $ take 100 path) BS.empty - Just (prefix, []) -> FileNameOK $! TarPath (packAscii name) (packAscii prefix) + Nothing -> FileNameTooLong $ TarPath (PS.take 100 path) PS.empty + Just (_ , _:_) -> FileNameTooLong $ TarPath (PS.take 100 path) PS.empty + Just (prefix, []) -> FileNameOK $! TarPath name prefix where -- drop the '/' between the name and prefix: - remainder = init first :| rest + remainder = PS.init first :| rest where nameMax, prefixMax :: Int nameMax = 100 prefixMax = 155 - packName :: Int -> NonEmpty FilePath -> Maybe (FilePath, [FilePath]) + packName :: Int -> NonEmpty PosixPath -> Maybe (PosixPath, [PosixPath]) packName maxLen (c :| cs) | n > maxLen = Nothing | otherwise = Just (packName' maxLen n [c] cs) - where n = length c + where n = PS.length c - packName' :: Int -> Int -> [FilePath] -> [FilePath] -> (FilePath, [FilePath]) + packName' :: Int -> Int -> [PosixPath] -> [PosixPath] -> (PosixPath, [PosixPath]) packName' maxLen n ok (c:cs) | n' <= maxLen = packName' maxLen n' (c:ok) cs - where n' = n + length c - packName' _ _ ok cs = (FilePath.Posix.joinPath ok, cs) + where n' = n + PS.length c + packName' _ _ ok cs = (PFP.joinPath ok, cs) -- | The tar format allows just 100 ASCII characters for the 'SymbolicLink' and -- 'HardLink' entry types. -- -newtype LinkTarget = LinkTarget BS.ByteString +newtype LinkTarget = LinkTarget PosixPath deriving (Eq, Ord, Show) instance NFData LinkTarget where rnf (LinkTarget bs) = rnf bs --- | Convert a native 'FilePath' to a tar 'LinkTarget'. +-- | Convert a native 'OsPath' to a tar 'LinkTarget'. -- string is longer than 100 characters or if it contains non-portable -- characters. -toLinkTarget :: FilePath -> Maybe LinkTarget -toLinkTarget path - | length path <= 100 = do - target <- toLinkTarget' path - Just $! LinkTarget (packAscii target) - | otherwise = Nothing - -data LinkTargetException = IsAbsolute FilePath - | TooLong FilePath +toLinkTarget :: MonadThrow m => OsPath -> m LinkTarget +toLinkTarget osPath = do + path <- toPosixPath' osPath + if | PFP.isAbsolute path -> throwM (IsAbsolute osPath) + | PS.length path <= 100 -> do + pure $! LinkTarget path + | otherwise -> throwM (TooLong osPath) + +data LinkTargetException = IsAbsolute OsPath + | TooLong OsPath deriving (Show,Typeable) instance Exception LinkTargetException where - displayException (IsAbsolute fp) = "Link target \"" <> fp <> "\" is unexpectedly absolute" + displayException (IsAbsolute fp) = "Link target \"" <> show fp <> "\" is unexpectedly absolute" displayException (TooLong _) = "The link target is too long" --- | Convert a native 'FilePath' to a unix filepath suitable for --- using as 'LinkTarget'. Does not error if longer than 100 characters. -toLinkTarget' :: FilePath -> Maybe FilePath -toLinkTarget' path - | FilePath.Native.isAbsolute path = Nothing - | otherwise = Just $ adjustDirectory $ FilePath.Posix.joinPath $ FilePath.Native.splitDirectories path - where - adjustDirectory | FilePath.Native.hasTrailingPathSeparator path - = FilePath.Posix.addTrailingPathSeparator - | otherwise = id - -- | Convert a tar 'LinkTarget' to a native 'FilePath'. -fromLinkTarget :: LinkTarget -> FilePath -fromLinkTarget (LinkTarget pathbs) = fromFilePathToNative $ BS.Char8.unpack pathbs +fromLinkTarget :: MonadThrow m => LinkTarget -> m OsPath +#if defined(mingw32_HOST_OS) +fromLinkTarget linkTarget = + OsString <$> fromLinkTargetToWindowsPath linkTarget +#else +fromLinkTarget linkTarget = + pure (OsString $ fromLinkTargetToPosixPath linkTarget) +#endif -- | Convert a tar 'LinkTarget' to a Unix\/POSIX 'FilePath' (@\'/\'@ path separators). -fromLinkTargetToPosixPath :: LinkTarget -> FilePath -fromLinkTargetToPosixPath (LinkTarget pathbs) = BS.Char8.unpack pathbs +fromLinkTargetToPosixPath :: LinkTarget -> PosixPath +fromLinkTargetToPosixPath (LinkTarget pathbs) = pathbs -- | Convert a tar 'LinkTarget' to a Windows 'FilePath' (@\'\\\\\'@ path separators). -fromLinkTargetToWindowsPath :: LinkTarget -> FilePath -fromLinkTargetToWindowsPath (LinkTarget pathbs) = - fromFilePathToWindowsPath $ BS.Char8.unpack pathbs - --- | Convert a unix FilePath to a native 'FilePath'. -fromFilePathToNative :: FilePath -> FilePath -fromFilePathToNative path = adjustDirectory $ - FilePath.Native.joinPath $ FilePath.Posix.splitDirectories path - where - adjustDirectory | FilePath.Posix.hasTrailingPathSeparator path - = FilePath.Native.addTrailingPathSeparator - | otherwise = id - --- | Convert a unix FilePath to a Windows 'FilePath'. -fromFilePathToWindowsPath :: FilePath -> FilePath -fromFilePathToWindowsPath path = adjustDirectory $ - FilePath.Windows.joinPath $ FilePath.Posix.splitDirectories path - where - adjustDirectory | FilePath.Posix.hasTrailingPathSeparator path - = FilePath.Windows.addTrailingPathSeparator - | otherwise = id +fromLinkTargetToWindowsPath :: MonadThrow m => LinkTarget -> m WindowsPath +fromLinkTargetToWindowsPath (LinkTarget posix) = do + win <- toWindowsPath posix + pure win + -- -- * Entries type diff --git a/Codec/Archive/Tar/Unpack.hs b/Codec/Archive/Tar/Unpack.hs index 4a8c15c..b9b7f3b 100644 --- a/Codec/Archive/Tar/Unpack.hs +++ b/Codec/Archive/Tar/Unpack.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE QuasiQuotes #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Use for_" #-} @@ -37,7 +38,7 @@ import System.FilePath ( () ) import qualified System.FilePath as FilePath.Native ( takeDirectory ) -import System.Directory +import System.Directory.OsPath ( createDirectoryIfMissing, copyFile, setPermissions, @@ -63,6 +64,16 @@ import Data.Time.Clock.POSIX import Control.Exception as Exception ( catch, SomeException(..) ) +import System.OsPath (OsPath) +import System.OsPath.Posix (PosixPath) + +import qualified System.OsPath as OSP +import qualified System.File.OsPath as OSP + +import qualified System.OsString as OS +import qualified System.OsString.Posix as PS + + -- | Create local files and directories based on the entries of a tar archive. -- -- This is a portable implementation of unpacking suitable for portable @@ -83,7 +94,7 @@ import Control.Exception as Exception -- unpack :: Exception e - => FilePath + => OsPath -- ^ Base directory -> Entries e -- ^ Entries to upack @@ -99,9 +110,9 @@ unpack = unpackAndCheck (fmap SomeException . checkEntrySecurity) -- @since 0.6.0.0 unpackAndCheck :: Exception e - => (GenEntry FilePath FilePath -> Maybe SomeException) + => (GenEntry PosixPath PosixPath -> Maybe SomeException) -- ^ Checks to run on each entry before unpacking - -> FilePath + -> OsPath -- ^ Base directory -> Entries e -- ^ Entries to upack @@ -119,11 +130,11 @@ unpackAndCheck secCB baseDir entries = do -- files all over the place. unpackEntries :: Exception e - => [(FilePath, FilePath, Bool)] + => [(PosixPath, PosixPath, Bool)] -- ^ links (path, link, isHardLink) - -> GenEntries FilePath FilePath (Either e DecodeLongNamesError) + -> GenEntries PosixPath PosixPath (Either e DecodeLongNamesError) -- ^ entries - -> IO [(FilePath, FilePath, Bool)] + -> IO [(PosixPath, PosixPath, Bool)] unpackEntries _ (Fail err) = either throwIO throwIO err unpackEntries links Done = return links unpackEntries links (Next entry es) = do @@ -150,42 +161,49 @@ unpackAndCheck secCB baseDir entries = do BlockDevice{} -> unpackEntries links es NamedPipe -> unpackEntries links es - extractFile permissions (fromFilePathToNative -> path) content mtime = do + extractFile :: Permissions -> PosixPath -> BS.ByteString -> EpochTime -> IO () + extractFile permissions path' content mtime = do + path <- fromPosixPath path' + let absDir = baseDir OSP. OSP.takeDirectory path + let absPath = baseDir OSP. path + -- 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 - BS.writeFile absPath content + OSP.writeFile absPath content setOwnerPermissions absPath permissions setModTime absPath mtime - where - absDir = baseDir FilePath.Native.takeDirectory path - absPath = baseDir path - extractDir (fromFilePathToNative -> path) mtime = do + extractDir :: PosixPath -> EpochTime -> IO () + extractDir path' mtime = do + path <- fromPosixPath path' + let absPath = baseDir OSP. path createDirectoryIfMissing True absPath setModTime absPath mtime - where - absPath = baseDir path - saveLink isHardLink (fromFilePathToNative -> path) (fromFilePathToNative -> link) links - = seq (length path) - $ seq (length link) + saveLink :: Bool -> PosixPath -> PosixPath -> [(PosixPath, PosixPath, Bool)] -> [(PosixPath, PosixPath, Bool)] + saveLink isHardLink path link links + = seq (PS.length path) + $ seq (PS.length link) $ (path, link, isHardLink):links -- for hardlinks, we just copy - handleHardLinks = mapM_ $ \(relPath, relLinkTarget, _) -> - let absPath = baseDir relPath + handleHardLinks :: [(PosixPath, PosixPath, Bool)] -> IO () + handleHardLinks = mapM_ $ \(relPath', relLinkTarget', _) -> do + relPath <- fromPosixPath relPath' + relLinkTarget <- fromPosixPath relLinkTarget' + let absPath = baseDir OSP. relPath -- hard links link targets are always "absolute" paths in -- the context of the tar root - absTarget = baseDir relLinkTarget + absTarget = baseDir OSP. relLinkTarget -- we don't expect races here, since we should be the -- only process unpacking the tar archive and writing to -- the destination - in doesDirectoryExist absTarget >>= \case - True -> copyDirectoryRecursive absTarget absPath - False -> copyFile absTarget absPath + doesDirectoryExist absTarget >>= \case + True -> copyDirectoryRecursive absTarget absPath + False -> copyFile absTarget absPath -- For symlinks, we first try to recreate them and if that fails -- with 'IllegalOperation', 'PermissionDenied' or 'InvalidArgument', @@ -193,19 +211,22 @@ unpackAndCheck secCB baseDir entries = do -- This error handling isn't too fine grained and maybe should be -- platform specific, but this way it might catch erros on unix even on -- FAT32 fuse mounted volumes. - handleSymlinks = mapM_ $ \(relPath, relLinkTarget, _) -> - let absPath = baseDir relPath + handleSymlinks :: [(PosixPath, PosixPath, Bool)] -> IO () + handleSymlinks = mapM_ $ \(relPath', relLinkTarget', _) -> do + relPath <- fromPosixPath relPath' + relLinkTarget <- fromPosixPath relLinkTarget' + let absPath = baseDir OSP. relPath -- hard links link targets are always "absolute" paths in -- the context of the tar root - absTarget = FilePath.Native.takeDirectory absPath relLinkTarget + absTarget = OSP.takeDirectory absPath OSP. relLinkTarget -- we don't expect races here, since we should be the -- only process unpacking the tar archive and writing to -- the destination - in doesDirectoryExist absTarget >>= \case - True -> handleSymlinkError (copyDirectoryRecursive absTarget absPath) - $ createDirectoryLink relLinkTarget absPath - False -> handleSymlinkError (copyFile absTarget absPath) - $ createFileLink relLinkTarget absPath + doesDirectoryExist absTarget >>= \case + True -> handleSymlinkError (copyDirectoryRecursive absTarget absPath) + $ createDirectoryLink relLinkTarget absPath + False -> handleSymlinkError (copyFile absTarget absPath) + $ createFileLink relLinkTarget absPath where handleSymlinkError action = @@ -219,7 +240,7 @@ unpackAndCheck secCB baseDir entries = do -- | Recursively copy the contents of one directory to another path. -- -- This is a rip-off of Cabal library. -copyDirectoryRecursive :: FilePath -> FilePath -> IO () +copyDirectoryRecursive :: OsPath -> OsPath -> IO () copyDirectoryRecursive srcDir destDir = do srcFiles <- getDirectoryContentsRecursive srcDir copyFilesWith copyFile destDir [ (srcDir, f) @@ -227,17 +248,17 @@ copyDirectoryRecursive srcDir destDir = do where -- | Common implementation of 'copyFiles', 'installOrdinaryFiles', -- 'installExecutableFiles' and 'installMaybeExecutableFiles'. - copyFilesWith :: (FilePath -> FilePath -> IO ()) - -> FilePath -> [(FilePath, FilePath)] -> IO () + copyFilesWith :: (OsPath -> OsPath -> IO ()) + -> OsPath -> [(OsPath, OsPath)] -> IO () copyFilesWith doCopy targetDir srcFiles = do -- Create parent directories for everything - let dirs = map (targetDir ) . nub . map (FilePath.Native.takeDirectory . snd) $ srcFiles + let dirs = map (targetDir OSP.) . nub . map (OSP.takeDirectory . snd) $ srcFiles traverse_ (createDirectoryIfMissing True) dirs -- Copy all the files - sequence_ [ let src = srcBase srcFile - dest = targetDir srcFile + sequence_ [ let src = srcBase OSP. srcFile + dest = targetDir OSP. srcFile in doCopy src dest | (srcBase, srcFile) <- srcFiles ] @@ -247,13 +268,13 @@ copyDirectoryRecursive srcDir destDir = do -- parent directories. The list is generated lazily so is not well defined if -- the source directory structure changes before the list is used. -- - getDirectoryContentsRecursive :: FilePath -> IO [FilePath] - getDirectoryContentsRecursive topdir = recurseDirectories [""] + getDirectoryContentsRecursive :: OsPath -> IO [OsPath] + getDirectoryContentsRecursive topdir = recurseDirectories [[OS.osstr||]] where - recurseDirectories :: [FilePath] -> IO [FilePath] + recurseDirectories :: [OsPath] -> IO [OsPath] recurseDirectories [] = return [] recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do - (files, dirs') <- collect [] [] =<< listDirectory (topdir dir) + (files, dirs') <- collect [] [] =<< listDirectory (topdir OSP. dir) files' <- recurseDirectories (dirs' ++ dirs) return (files ++ files') @@ -261,13 +282,13 @@ copyDirectoryRecursive srcDir destDir = do collect files dirs' [] = return (reverse files ,reverse dirs') collect files dirs' (entry:entries) = do - let dirEntry = dir entry - isDirectory <- doesDirectoryExist (topdir dirEntry) + let dirEntry = dir OSP. entry + isDirectory <- doesDirectoryExist (topdir OSP. dirEntry) if isDirectory then collect files (dirEntry:dirs') entries else collect (dirEntry:files) dirs' entries -setModTime :: FilePath -> EpochTime -> IO () +setModTime :: OsPath -> EpochTime -> IO () setModTime path t = setModificationTime path (posixSecondsToUTCTime (fromIntegral t)) `Exception.catch` \e -> case ioeGetErrorType e of @@ -277,7 +298,7 @@ setModTime path t = InvalidArgument -> return () _ -> throwIO e -setOwnerPermissions :: FilePath -> Permissions -> IO () +setOwnerPermissions :: OsPath -> Permissions -> IO () setOwnerPermissions path permissions = setPermissions path ownerPermissions where diff --git a/Codec/Archive/Tar/Write.hs b/Codec/Archive/Tar/Write.hs index 55059c0..6339157 100644 --- a/Codec/Archive/Tar/Write.hs +++ b/Codec/Archive/Tar/Write.hs @@ -25,6 +25,13 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS.Char8 import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy.Char8 as LBS.Char8 +import Data.ByteString.Internal (c2w) + +import qualified System.OsString.Posix as PS + +import System.OsString.Internal.Types (PosixString(..)) + +import qualified Data.ByteString.Short as SBS -- | Create the external representation of a tar archive by serialising a list @@ -56,16 +63,16 @@ putEntry entry = case entryContent entry of where paddingSize = fromIntegral (negate size `mod` 512) putHeader :: Entry -> LBS.ByteString -putHeader entry = - LBS.Char8.pack - $ take 148 block - ++ putOct 7 checksum - ++ ' ' : drop 156 block +putHeader entry = LBS.fromStrict $ + BS.take 148 block + <> putOct 7 checksum + <> BS.Char8.singleton ' ' + <> BS.drop 156 block where block = putHeaderNoChkSum entry - checksum = foldl' (\x y -> x + ord y) 0 block + checksum = BS.foldl' (\x y -> x + fromIntegral y) (0 :: Int) block -putHeaderNoChkSum :: Entry -> String +putHeaderNoChkSum :: Entry -> BS.ByteString putHeaderNoChkSum Entry { entryTarPath = TarPath name prefix, entryContent = content, @@ -75,40 +82,40 @@ putHeaderNoChkSum Entry { entryFormat = format } = - concat - [ putBString 100 name + BS.concat + [ putPString 100 name , putOct 8 permissions , putOct 8 $ ownerId ownership , putOct 8 $ groupId ownership , numField 12 contentSize , putOct 12 modTime - , replicate 8 ' ' -- dummy checksum - , putChar8 typeCode - , putBString 100 linkTarget - ] ++ + , BS.replicate 8 (c2w ' ') -- dummy checksum + , putChar8' typeCode + , putPString 100 linkTarget + ] <> case format of - V7Format -> - replicate 255 '\NUL' - UstarFormat -> concat - [ putBString 8 ustarMagic - , putString 32 $ ownerName ownership - , putString 32 $ groupName ownership - , putOct 8 deviceMajor - , putOct 8 deviceMinor - , putBString 155 prefix - , replicate 12 '\NUL' - ] - GnuFormat -> concat - [ putBString 8 gnuMagic - , putString 32 $ ownerName ownership - , putString 32 $ groupName ownership - , putGnuDev 8 deviceMajor - , putGnuDev 8 deviceMinor - , putBString 155 prefix - , replicate 12 '\NUL' - ] + V7Format -> + BS.replicate 255 0 + UstarFormat -> BS.concat + [ putBString 8 ustarMagic + , putPString 32 $ ownerName ownership + , putPString 32 $ groupName ownership + , putOct 8 deviceMajor + , putOct 8 deviceMinor + , putPString 155 prefix + , BS.replicate 12 0 + ] + GnuFormat -> BS.concat + [ putBString 8 gnuMagic + , putPString 32 $ ownerName ownership + , putPString 32 $ groupName ownership + , putGnuDev 8 deviceMajor + , putGnuDev 8 deviceMinor + , putPString 155 prefix + , BS.replicate 12 0 + ] where - numField :: FieldWidth -> Int64 -> String + numField :: FieldWidth -> Int64 -> BS.ByteString numField w n | n >= 0 && n < 1 `shiftL` (3 * (w - 1)) = putOct w n @@ -129,7 +136,7 @@ putHeaderNoChkSum Entry { putGnuDev w n = case content of CharacterDevice _ _ -> putOct w n BlockDevice _ _ -> putOct w n - _ -> replicate w '\NUL' + _ -> BS.replicate w 0 ustarMagic, gnuMagic :: BS.ByteString ustarMagic = BS.Char8.pack "ustar\NUL00" @@ -139,24 +146,25 @@ gnuMagic = BS.Char8.pack "ustar \NUL" type FieldWidth = Int -putBString :: FieldWidth -> BS.ByteString -> String -putBString n s = BS.Char8.unpack (BS.take n s) ++ replicate (n - BS.length s) '\NUL' +putBString :: FieldWidth -> BS.ByteString -> BS.ByteString +putBString n s = BS.take n s <> BS.replicate (n - BS.length s) 0 -putString :: FieldWidth -> String -> String -putString n s = take n s ++ replicate (n - length s) '\NUL' +putPString :: FieldWidth -> PS.PosixString -> BS.ByteString +putPString n s = (SBS.fromShort . getPosixString $ PS.take n s) <> BS.replicate (n - PS.length s) 0 -{-# SPECIALISE putLarge :: FieldWidth -> Int64 -> String #-} -putLarge :: (Bits a, Integral a) => FieldWidth -> a -> String -putLarge n0 x0 = '\x80' : reverse (go (n0-1) x0) +{-# SPECIALISE putLarge :: FieldWidth -> Int64 -> BS.ByteString #-} +putLarge :: (Bits a, Integral a) => FieldWidth -> a -> BS.ByteString +putLarge n0 x0 = BS.Char8.pack $ '\x80' : reverse (go (n0-1) x0) where go 0 _ = [] go n x = chr (fromIntegral (x .&. 0xff)) : go (n-1) (x `shiftR` 8) -putOct :: (Integral a, Show a) => FieldWidth -> a -> String +putOct :: (Integral a, Show a) => FieldWidth -> a -> BS.ByteString putOct n x = - let octStr = take (n-1) $ showOct x "" - in replicate (n - length octStr - 1) '0' - ++ octStr - ++ putChar8 '\NUL' + let octStr = BS.Char8.pack $ take (n-1) $ showOct x "" + in BS.replicate (n - BS.length octStr - 1) (c2w '0') + <> octStr + <> BS.singleton 0 + +putChar8' :: Char -> BS.ByteString +putChar8' c = BS.Char8.pack [c] -putChar8 :: Char -> String -putChar8 c = [c] diff --git a/cabal.project b/cabal.project index cbde73f..aca7694 100644 --- a/cabal.project +++ b/cabal.project @@ -1 +1,17 @@ packages: . htar + +source-repository-package + type: git + location: https://github.com/haskell/directory.git + tag: 27e41d949d06e1998d8b17ca978aab7b6ba8139c + post-checkout-command: autoreconf -i + +if (os(windows)) + source-repository-package + type: git + location: https://github.com/haskell/win32.git + tag: 86e2737e1c2a668168ba8497c932a058c5c9a600 +else + constraints: + unix == 2.8.5.0 + diff --git a/htar/htar.cabal b/htar/htar.cabal index 4393ae1..5f2afac 100644 --- a/htar/htar.cabal +++ b/htar/htar.cabal @@ -28,8 +28,8 @@ executable htar build-depends: base >= 4.9 && < 5, time >= 1.1, - directory >= 1.0, - filepath >= 1.0, + directory >= 1.3.8.0 && < 1.4, + filepath >= 1.5 &&< 1.6, bytestring >= 0.9, tar >= 0.4.2, zlib >= 0.4 && < 0.7, diff --git a/htar/htar.hs b/htar/htar.hs index d12c2f1..5b2df3d 100644 --- a/htar/htar.hs +++ b/htar/htar.hs @@ -19,17 +19,24 @@ import System.IO (hPutStrLn, stderr) import Data.Time (formatTime, defaultTimeLocale) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import System.OsPath.Posix (PosixPath) +import qualified System.OsPath as OSP + + main :: IO () main = do (opts, files) <- parseOptions =<< getArgs main' opts files main' :: Options -> [FilePath] -> IO () -main' (Options { optFile = file, - optDir = dir, +main' (Options { optFile = file', + optDir = dir', optAction = action, optCompression = compression, - optVerbosity = verbosity }) files = + optVerbosity = verbosity }) files' = do + file <- OSP.encodeFS file' + dir <- OSP.encodeFS dir' + files <- mapM OSP.encodeFS files' case action of NoAction -> die ["No action given. Specify one of -c, -t or -x."] Help -> printUsage @@ -39,13 +46,13 @@ main' (Options { optFile = file, List -> printEntries . Tar.read . decompress compression =<< input Append | compression /= None -> die ["Append cannot be used together with compression."] - | file == "-" + | file' == "-" -> die ["Append must be used on a file, not stdin/stdout."] | otherwise -> Tar.append file dir files where - input = if file == "-" then BS.getContents else BS.readFile file - output = if file == "-" then BS.putStr else BS.writeFile file + input = if file' == "-" then BS.getContents else BS.readFile file' + output = if file' == "-" then BS.putStr else BS.writeFile file' printEntries :: Tar.Entries Tar.FormatError -> IO () printEntries = Tar.foldEntries (\entry rest -> printEntry entry >> rest) @@ -72,16 +79,16 @@ data Verbosity = Verbose | Concise ------------------------ -- List archive contents -entryInfo :: Verbosity -> Tar.GenEntry FilePath FilePath -> String +entryInfo :: Verbosity -> Tar.GenEntry PosixPath PosixPath -> String entryInfo Verbose = detailedInfo -entryInfo Concise = Tar.entryTarPath +entryInfo Concise = show . Tar.entryTarPath -detailedInfo :: Tar.GenEntry FilePath FilePath -> String +detailedInfo :: Tar.GenEntry PosixPath PosixPath -> String detailedInfo entry = unwords [ typeCode : permissions , justify 19 (owner ++ '/' : group) size , time - , name ++ link ] + , show name ++ link ] where typeCode = case Tar.entryContent entry of Tar.HardLink _ -> 'h' @@ -107,7 +114,7 @@ detailedInfo entry = group = nameOrID groupName groupId (Tar.Ownership ownerName groupName ownerId groupId) = Tar.entryOwnership entry - nameOrID n i = if null n then show i else n + nameOrID n i = if n == mempty then show i else show n size = case Tar.entryContent entry of Tar.NormalFile _ fileSize -> show fileSize _ -> "0" @@ -115,8 +122,8 @@ detailedInfo entry = time = formatEpochTime "%Y-%m-%d %H:%M" (Tar.entryTime entry) name = Tar.entryTarPath entry link = case Tar.entryContent entry of - Tar.HardLink l -> " link to " ++ l - Tar.SymbolicLink l -> " -> " ++ l + Tar.HardLink l -> " link to " ++ show l + Tar.SymbolicLink l -> " -> " ++ show l _ -> "" justify :: Int -> String -> String -> String @@ -214,3 +221,4 @@ die errs = do mapM_ (\e -> hPutStrLn stderr $ "htar: " ++ e) errs hPutStrLn stderr "Try `htar --help' for more information." exitFailure + diff --git a/tar.cabal b/tar.cabal index 483ad8e..9a7a7fd 100644 --- a/tar.cabal +++ b/tar.cabal @@ -53,8 +53,11 @@ library tar-internal bytestring >= 0.10 && < 0.13, containers >= 0.2 && < 0.8, deepseq >= 1.1 && < 1.6, - directory >= 1.3.1 && < 1.4, - filepath < 1.5, + exceptions, + directory >= 1.3.8.0 && < 1.4, + filepath >= 1.5 &&< 1.6, + file-io >= 0.1.0.2 &&< 0.2, + os-string >= 2.0.0 &&< 2.1, time < 1.13 exposed-modules: @@ -92,7 +95,7 @@ test-suite properties bytestring >= 0.10, containers, deepseq, - directory >= 1.2, + directory >= 1.3.8.0 && < 1.4, file-embed, filepath, QuickCheck == 2.*, @@ -134,7 +137,7 @@ benchmark bench tar, bytestring >= 0.10, filepath, - directory >= 1.2, + directory >= 1.3.8.0 && < 1.4, array, containers, deepseq,