diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +# ztar 1.0.0 + +Breaking changes: +* Compiled against `zip-1.0.0` + # ztar 0.2.0 Breaking changes: diff --git a/src/Codec/Archive/ZTar.hs b/src/Codec/Archive/ZTar.hs --- a/src/Codec/Archive/ZTar.hs +++ b/src/Codec/Archive/ZTar.hs @@ -62,7 +62,7 @@ createFrom' compression (toFilePath -> archive) (toFilePath -> dir) paths = createFrom compression archive dir paths --- | Extract an archive to the given directory. Automatically detects the compression algorithm. +-- | Extract an archive to the given directory. Automatically detects the compression algorithm -- used in the archive. extract :: FilePath -- ^ archive to extract -> FilePath -- ^ destination directory @@ -71,6 +71,7 @@ Tar.TarFormat -> Tar.extract archive dir GZip.GZipFormat -> GZip.extract archive dir Zip.ZipFormat -> Zip.extract archive dir + "" -> fail $ "Trying to extract empty file: " ++ archive _ -> fail $ "Could not recognize archive format: " ++ archive -- | Same as 'extract' but using Path types. diff --git a/src/Codec/Archive/ZTar/GZip.hs b/src/Codec/Archive/ZTar/GZip.hs --- a/src/Codec/Archive/ZTar/GZip.hs +++ b/src/Codec/Archive/ZTar/GZip.hs @@ -6,7 +6,6 @@ Functions to create/extract GZIP-compressed archives. -} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} diff --git a/src/Codec/Archive/ZTar/Tar.hs b/src/Codec/Archive/ZTar/Tar.hs --- a/src/Codec/Archive/ZTar/Tar.hs +++ b/src/Codec/Archive/ZTar/Tar.hs @@ -6,8 +6,6 @@ Functions to create/extract uncompressed tar archives. -} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} diff --git a/src/Codec/Archive/ZTar/Zip.hs b/src/Codec/Archive/ZTar/Zip.hs --- a/src/Codec/Archive/ZTar/Zip.hs +++ b/src/Codec/Archive/ZTar/Zip.hs @@ -21,11 +21,10 @@ import Control.Monad.IO.Class (liftIO) import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BS -import Path (parseAbsFile, parseAbsDir, parseRelFile) import System.Directory ( createDirectoryIfMissing - , doesFileExist , doesDirectoryExist + , doesFileExist , listDirectory , makeAbsolute , withCurrentDirectory @@ -34,8 +33,19 @@ -- | A pattern matching any ByteString in the Zip format. pattern ZipFormat :: ByteString -pattern ZipFormat <- ((BS.pack [0x50, 0x4B, 0x03, 0x04] `BS.isPrefixOf`) -> True) +pattern ZipFormat <- (matchesZip -> True) +matchesZip :: ByteString -> Bool +matchesZip s = any (`BS.isPrefixOf` s) zipMagicNumbers + where + zipMagicNumbers = map BS.pack + [ [0x50, 0x4B, 0x03, 0x04] + -- empty archive + , [0x50, 0x4B, 0x05, 0x06] + -- spanned archive + , [0x50, 0x4B, 0x07, 0x08] + ] + -- | Create a new archive compressed with Zip from the given paths. -- -- It is equivalent to calling the standard 'zip' program like so: @@ -46,7 +56,7 @@ -> [FilePath] -- ^ files and paths to compress, relative to base directory -> IO () create archive base paths = do - archive' <- makeAbsolute archive >>= parseAbsFile + archive' <- makeAbsolute archive withCurrentDirectory base $ Zip.createArchive archive' $ mapM_ insert paths where insert path = do @@ -57,9 +67,8 @@ | isDir -> insertDir path | otherwise -> fail $ "Path does not exist: " ++ path insertFile path = do - path' <- parseRelFile path - path'' <- Zip.mkEntrySelector path' - Zip.loadEntry Zip.BZip2 (const $ return path'') path' + path' <- Zip.mkEntrySelector path + Zip.loadEntry Zip.BZip2 path' path insertDir path = let mkPath = if path == "." then id else (path ) in mapM_ (insert . mkPath) =<< liftIO (listDirectory path) @@ -74,6 +83,4 @@ -> IO () extract archive dir = do createDirectoryIfMissing True dir - archive' <- makeAbsolute archive >>= parseAbsFile - dir' <- makeAbsolute dir >>= parseAbsDir - Zip.withArchive archive' $ Zip.unpackInto dir' + Zip.withArchive archive $ Zip.unpackInto dir diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -2,24 +2,25 @@ import Codec.Archive.ZTar import Control.Monad (forM, forM_) -import Control.Monad.Extra (unlessM) import qualified Data.ByteString as BS import Data.ByteString.Arbitrary (ArbByteString(..)) -import Data.List (dropWhileEnd, intercalate, nub) +import Data.List (isPrefixOf, nub) import Data.Maybe (fromJust) import Path ( Dir , File - , Rel , Path + , Rel , absdir , fromAbsFile + , fromRelDir , parent , parseRelDir , parseRelFile , () ) import Path.IO (doesFileExist, ensureDir, isLocationOccupied, withTempDir) +import qualified System.FilePath.Windows as Windows import Test.QuickCheck import Test.QuickCheck.Monadic import Test.Tasty (defaultMain, testGroup) @@ -27,34 +28,32 @@ main :: IO () main = defaultMain $ testGroup "ztar" - [ testProperty "Create/extract uncompressed tar archives" $ testZTar NoCompression - , testProperty "Create/extract GZip tar archives" $ testZTar GZip - , testProperty "Create/extract Zip archives" $ testZTar Zip + [ testProperty "Create/extract uncompressed tar archives" $ testZTar 25 NoCompression + , testProperty "Create/extract GZip tar archives" $ testZTar 20 GZip + , testProperty "Create/extract Zip archives" $ testZTar 15 Zip ] -testZTar :: Compression -> Property -testZTar compression = monadicIO $ do - archive:src:dest:paths <- pick $ uniqueListOf 4 arbitrary - - files <- forM paths $ \path -> do - Blind (ABS contents) <- pick arbitrary - return (toRelFile path, contents) +testZTar :: Int -> Compression -> Property +testZTar n compression = withMaxSuccess n $ monadicIO $ do + [archive, src, dest] <- pick $ uniqueListOf 3 arbitrary + files <- pick arbitraryFileTree run $ withTempDir [absdir|/tmp|] "" $ \dir -> do let archive' = dir toRelFile archive src' = dir toRelDir src dest' = dir toRelDir dest + ensureDir $ parent archive' + ensureDir src' + ensureDir dest' + -- write files to be bundled forM_ files $ \(path, contents) -> do let path' = src' path - -- case writing `a` when `a/b` already exists - unlessM (isLocationOccupied path') $ do - ensureDir $ parent path' - BS.writeFile (fromAbsFile path') contents + ensureDir $ parent path' + BS.writeFile (fromAbsFile path') contents -- create and extract archive - ensureDir $ parent archive' create' compression archive' src' extract' archive' dest' @@ -72,44 +71,59 @@ {- Helpers -} --- | Generate a unique list with length at least N. +toRelFile :: ValidName -> Path Rel File +toRelFile = fromJust . parseRelFile . unName + +toRelDir :: ValidName -> Path Rel Dir +toRelDir = fromJust . parseRelDir . unName + +maybeSlash :: Maybe (Path Rel Dir) -> Path Rel t -> Path Rel t +maybeSlash Nothing path = path +maybeSlash (Just dir) path = dir path + +-- | Generate a unique list with length of N. uniqueListOf :: Eq a => Int -> Gen a -> Gen [a] -uniqueListOf 0 gen = nub <$> listOf gen +uniqueListOf 0 _ = return [] uniqueListOf n gen = do rest <- uniqueListOf (n - 1) gen x <- gen `suchThat` (`notElem` rest) return $ x : rest --- | A valid relative file path. -newtype ValidPath = ValidPath { unPath :: FilePath } - deriving (Show,Eq) - -instance Arbitrary ValidPath where - arbitrary = ValidPath . truncatePath . intercalate "/" . map unName <$> listOf1 arbitrary - where - truncatePath = dropWhileEnd (`elem` ['/', '.']) . take 50 - -toRelFile :: ValidPath -> Path Rel File -toRelFile = fromJust . parseRelFile . unPath - -toRelDir :: ValidPath -> Path Rel Dir -toRelDir = fromJust . parseRelDir . unPath +-- | An arbitrary file tree and their contents. +arbitraryFileTree :: Gen [(Path Rel File, BS.ByteString)] +arbitraryFileTree = mkFileTree Nothing (0 :: Int) + where + mkFileTree (Just dir) _ + | length (fromRelDir dir) > 50 = return [] + mkFileTree _ 5 = return [] -- max depth of 5 directories + mkFileTree dir depth = do + paths <- nub <$> listOf arbitrary + fmap concat $ forM paths $ \path -> do + -- exponentially less likely to go into subdirectories + isFile <- frequency [(1, pure False), (2^depth, pure True)] + if isFile + then do + Blind (ABS contents) <- arbitrary + return [(dir `maybeSlash` toRelFile path, contents)] + else mkFileTree (Just $ dir `maybeSlash` toRelDir path) (depth + 1) -- | A valid file or directory name. newtype ValidName = ValidName { unName :: String } - deriving (Show) + deriving (Show,Eq) +{-# ANN module "HLint: ignore Use ||" #-} instance Arbitrary ValidName where arbitrary = do -- https://stackoverflow.com/a/2306003/8565175 name <- take 14 <$> listOf1 (elements validChars) - if or - [ last name == '.' - , name `elem` ["nul"] - -- https://superuser.com/questions/259703/get-mac-tar-to-stop-putting-filenames-in-tar-archives - , name !! 0 == '.' && name !! 1 == '_' - ] - then arbitrary - else return $ ValidName name + if isValid name + then return $ ValidName name + else arbitrary where validChars = ['a'..'z'] ++ ['0'..'9'] ++ ['.', '_', '-'] + isValid name = not $ or + [ last name == '.' + -- https://superuser.com/questions/259703/get-mac-tar-to-stop-putting-filenames-in-tar-archives + , "._" `isPrefixOf` name + , not $ Windows.isValid name + ] diff --git a/ztar.cabal b/ztar.cabal --- a/ztar.cabal +++ b/ztar.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: c39489aefc941fc38bd650d9f61d4cfbc64a46eb644a01468a3c27fad9de23b4 +-- hash: f6bbd45a4e7adaa7ce7e25a88acfaf3aff646afa6bfd8d1835c36d21c23449e8 name: ztar -version: 0.2.0 +version: 1.0.0 synopsis: Creating and extracting arbitrary archives description: Creating and extracting arbitrary archives. category: Codec @@ -52,7 +52,7 @@ , process , text , unix-compat - , zip >=0.2 && <0.3 + , zip >=1.0 && <1.2 , zlib >=0.6 && <0.7 if flag(dev) ghc-options: -Werror @@ -88,7 +88,7 @@ , base , bytestring , bytestring-arbitrary - , extra + , filepath , path , path-io , tasty