diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,13 @@ +# ztar 0.0.3 + +Breaking changes: +* `create` now takes compression algorithm + +Other changes: +* `extract` automatically detects compression algorithm used +* `extract` now handles ZIP archives and uncompressed TAR archives +* Add integration testing + # ztar 0.0.2 * Add createGZ' diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,28 @@ # ztar -Reading and writing compressed `.tar` archives. +Reading and writing arbitrary archives. -An extension of the `tar` library that can create/extract compressed tar archives. +An extension of the `tar` library that, similar to the `tar` UNIX executable, +can create an archive with a given compression algorithm and automatically +detect the compression algorithm of an archive when extracting. + +``` +import Codec.Archive.ZTar + +-- equivalent to `Codec.Archive.Tar.create "archive.tar" "dist/" ["."]` +create' NoCompression "archive.tar" "dist/" ["."] + +-- helper to compress a single directory; equivalent to previous line +create NoCompression "archive.tar" "dist/" + +-- compress with GZip +create GZip "archive.tar.gz" "dist/" + +-- compress with Zip +create Zip "archive.zip" "dist/" + +-- automatically determines compression +extract "archive-tar/" "archive.tar" +extract "archive-gz/" "archive.tar.gz" +extract "archive-zip/" "archive.zip" +``` diff --git a/src/Codec/Archive/Tar/GZip.hs b/src/Codec/Archive/Tar/GZip.hs deleted file mode 100644 --- a/src/Codec/Archive/Tar/GZip.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-| -Module : Codec.Archive.Tar.GZip -Maintainer : Brandon Chinn -Stability : experimental -Portability : portable - -Functions to create/extract compressed tar archives. --} - -module Codec.Archive.Tar.GZip (createGZ, createGZ', extractGZ) where - -import qualified Codec.Archive.Tar as Tar -import qualified Codec.Compression.GZip as GZ -import qualified Data.ByteString.Lazy as BS - --- | Create a new @.tar@ file from the given directory. --- --- It is equivalent to calling the standard 'tar' program like so: --- --- @$ tar -czf tarball.tar -C dir .@ --- --- See 'Tar.create' for more details. -createGZ :: FilePath -- ^ tar archive - -> FilePath -- ^ directory to archive - -> IO () -createGZ tar dir = createGZ' tar dir ["."] - --- | Create a new @.tar@ file from the given paths. --- --- It is equivalent to calling the standard 'tar' program like so: --- --- @$ tar -czf tarball.tar -C base paths@ --- --- See 'Tar.create' for more details. -createGZ' :: FilePath -- ^ tar archive - -> FilePath -- ^ base directory - -> [FilePath] -- ^ files and paths to compress, relative to base directory - -> IO () -createGZ' tar base paths = BS.writeFile tar . GZ.compress . Tar.write =<< Tar.pack base paths - --- | Extract all the files contained in a @.tar@ file. --- --- It is equivalent to calling the standard 'tar' program like so: --- --- @$ tar -xzf tarball.tar -C dir@ --- --- See 'Tar.extract' for more details. -extractGZ :: FilePath -- ^ destination directory - -> FilePath -- ^ tar archive - -> IO () -extractGZ dir tar = Tar.unpack dir . Tar.read . GZ.decompress =<< BS.readFile tar diff --git a/src/Codec/Archive/ZTar.hs b/src/Codec/Archive/ZTar.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Archive/ZTar.hs @@ -0,0 +1,61 @@ +{-| +Module : Codec.Archive.ZTar +Maintainer : Brandon Chinn +Stability : experimental +Portability : portable + +Functions to create/extract archives. +-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} + +module Codec.Archive.ZTar + ( Compression(..) + , create + , create' + , extract + ) where + +import qualified Data.ByteString.Lazy as BS + +import qualified Codec.Archive.ZTar.GZip as GZip +import qualified Codec.Archive.ZTar.Tar as Tar +import qualified Codec.Archive.ZTar.Zip as Zip + +-- | The compression algorithm to use when creating an archive. +data Compression + = NoCompression + | GZip + | Zip + deriving (Show) + +-- | Create a new archive from the given directory using the given compression algorithm. +create :: Compression + -> FilePath -- ^ archive file to create + -> FilePath -- ^ directory to archive + -> IO () +create compression archive dir = create' compression archive dir ["."] + +-- | Create a new archive from the given paths using the given compression algorithm. +create' :: Compression + -> FilePath -- ^ archive file to create + -> FilePath -- ^ base directory + -> [FilePath] -- ^ files and paths to compress, relative to base directory + -> IO () +create' compression = case compression of + NoCompression -> Tar.create + GZip -> GZip.create + Zip -> Zip.create + +-- | Extract an archive to the given directory. Automatically detects the compression algorithm. +-- used in the archive. +extract :: FilePath -- ^ destination directory + -> FilePath -- ^ archive to extract + -> IO () +extract dir archive = BS.readFile archive >>= \case + Tar.TarFormat -> Tar.extract dir archive + GZip.GZipFormat -> GZip.extract dir archive + Zip.ZipFormat -> Zip.extract dir archive + _ -> fail $ "Could not recognize archive format: " ++ archive diff --git a/src/Codec/Archive/ZTar/GZip.hs b/src/Codec/Archive/ZTar/GZip.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Archive/ZTar/GZip.hs @@ -0,0 +1,47 @@ +{-| +Module : Codec.Archive.ZTar.GZip +Maintainer : Brandon Chinn +Stability : experimental +Portability : portable + +Functions to create/extract GZIP-compressed archives. +-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} + +module Codec.Archive.ZTar.GZip + ( pattern GZipFormat + , create + , extract + ) where + +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Compression.GZip as GZ +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as BS + +-- | A pattern matching any ByteString in the GZip format. +pattern GZipFormat :: ByteString +pattern GZipFormat <- ((BS.pack [0x1F, 0x8B] `BS.isPrefixOf`) -> True) + +-- | Create a new archive compressed with GZip from the given paths. +-- +-- It is equivalent to calling the standard 'tar' program like so: +-- +-- @$ tar -czf archive -C base paths@ +create :: FilePath -- ^ archive to create + -> FilePath -- ^ base directory + -> [FilePath] -- ^ files and paths to compress, relative to base directory + -> IO () +create archive base paths = BS.writeFile archive . GZ.compress . Tar.write =<< Tar.pack base paths + +-- | Extract all the files contained in an archive compressed with GZip. +-- +-- It is equivalent to calling the standard 'tar' program like so: +-- +-- @$ tar -xf archive -C dir@ +extract :: FilePath -- ^ destination directory + -> FilePath -- ^ archive to extract + -> IO () +extract dir archive = Tar.unpack dir . Tar.read . GZ.decompress =<< BS.readFile archive diff --git a/src/Codec/Archive/ZTar/Tar.hs b/src/Codec/Archive/ZTar/Tar.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Archive/ZTar/Tar.hs @@ -0,0 +1,56 @@ +{-| +Module : Codec.Archive.ZTar.Tar +Maintainer : Brandon Chinn +Stability : experimental +Portability : portable + +Functions to create/extract uncompressed tar archives. +-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} + +module Codec.Archive.ZTar.Tar + ( pattern TarFormat + , create + , extract + ) where + +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as BS + +import qualified Codec.Archive.Tar as Tar + +-- | A pattern matching any ByteString in an uncompressed TAR format. +pattern TarFormat :: ByteString +pattern TarFormat <- (matchesTar -> True) + +matchesTar :: ByteString -> Bool +matchesTar (BS.drop 0x101 -> s) = any (`BS.isPrefixOf` s) tarMagicNumbers + where + tarMagicNumbers = map BS.pack + [ [0x75, 0x73, 0x74, 0x61, 0x72, 0x00, 0x30, 0x30] + , [0x75, 0x73, 0x74, 0x61, 0x72, 0x20, 0x20, 0x00] + ] + +-- | Create a new uncompressed tar archive from the given paths. +-- +-- It is equivalent to calling the standard 'tar' program like so: +-- +-- @$ tar -cf archive -C base paths@ +create :: FilePath -- ^ archive to create + -> FilePath -- ^ base directory + -> [FilePath] -- ^ files and paths to compress, relative to base directory + -> IO () +create = Tar.create + +-- | Extract all the files contained in an uncompressed tar archive. +-- +-- It is equivalent to calling the standard 'tar' program like so: +-- +-- @$ tar -xf archive -C dir@ +extract :: FilePath -- ^ destination directory + -> FilePath -- ^ archive to extract + -> IO () +extract = Tar.extract diff --git a/src/Codec/Archive/ZTar/Zip.hs b/src/Codec/Archive/ZTar/Zip.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Archive/ZTar/Zip.hs @@ -0,0 +1,75 @@ +{-| +Module : Codec.Archive.ZTar.Zip +Maintainer : Brandon Chinn +Stability : experimental +Portability : portable + +Functions to create/extract ZIP-compressed archives. +-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} + +module Codec.Archive.ZTar.Zip + ( pattern ZipFormat + , create + , extract + ) where + +import qualified Codec.Archive.Zip as Zip +import Control.Monad.IO.Class (liftIO) +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as BS +import System.Directory + ( createDirectoryIfMissing + , doesFileExist + , doesDirectoryExist + , listDirectory + , renameFile + , withCurrentDirectory + ) +import System.FilePath (()) + +-- | A pattern matching any ByteString in the Zip format. +pattern ZipFormat :: ByteString +pattern ZipFormat <- ((BS.pack [0x50, 0x4B, 0x03, 0x04] `BS.isPrefixOf`) -> True) + +-- | Create a new archive compressed with Zip from the given paths. +-- +-- It is equivalent to calling the standard 'zip' program like so: +-- +-- @$ CURR=$PWD; (cd base && zip -r archive paths && mv archive $CURR)@ +create :: FilePath -- ^ archive to create + -> FilePath -- ^ base directory + -> [FilePath] -- ^ files and paths to compress, relative to base directory + -> IO () +create archive base paths = do + withCurrentDirectory base $ Zip.createArchive archive $ mapM_ insert paths + renameFile (base archive) archive + where + insert path = do + isFile <- liftIO $ doesFileExist path + isDir <- liftIO $ doesDirectoryExist path + if + | isFile -> insertFile path + | isDir -> insertDir path + | otherwise -> fail $ "Path does not exist: " ++ path + insertFile path = do + 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) + +-- | Extract all the files contained in an archive compressed with Zip. +-- +-- It is equivalent to calling the standard 'zip' program like so: +-- +-- @$ mkdir -p dir && unzip archive -d dir@ +extract :: FilePath -- ^ destination directory + -> FilePath -- ^ archive to extract + -> IO () +extract dir archive = do + createDirectoryIfMissing True dir + Zip.withArchive archive $ Zip.unpackInto dir diff --git a/test/Example.hs b/test/Example.hs --- a/test/Example.hs +++ b/test/Example.hs @@ -1,16 +1,24 @@ {-# LANGUAGE QuasiQuotes #-} -import Codec.Archive.Tar.GZip (createGZ, extractGZ) +import Codec.Archive.ZTar import Control.Monad (unless) import Path import Path.IO (ensureDir, removeDirRecur, removeFile, withSystemTempDir) main :: IO () -main = withSystemTempDir "" $ \dir -> do +main = mapM_ runTest + [ NoCompression + , GZip + , Zip + ] + +runTest :: Compression -> IO () +runTest compression = withSystemTempDir "" $ \dir -> do + putStrLn $ "\nTesting: " ++ show compression mapM_ (mkFile dir) files - createGZ (fromRelFile archive) $ fromAbsDir dir + create compression (fromRelFile archive) $ fromAbsDir dir - extractGZ (fromRelDir extractDir) $ fromRelFile archive + extract (fromRelDir extractDir) $ fromRelFile archive contents <- mapM (readFile . fromRelFile . (extractDir )) files putStrLn $ unlines contents unless (contents == map show files) $ diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE QuasiQuotes #-} + +import Codec.Archive.ZTar +import Control.Monad (forM, forM_) +import Control.Monad.Extra (unlessM) +import Data.List (dropWhileEnd, intercalate, nub) +import Data.Maybe (fromJust) +import Path + ( Dir + , File + , Rel + , Path + , absdir + , fromAbsDir + , fromAbsFile + , parent + , parseRelDir + , parseRelFile + , () + ) +import Path.IO (doesFileExist, ensureDir, isLocationOccupied, withTempDir) +import Test.QuickCheck (Arbitrary(..), Gen, Property, elements, listOf, listOf1, suchThat) +import Test.QuickCheck.Monadic (monadicIO, pick, run) +import Test.Tasty (defaultMain, testGroup) +import Test.Tasty.QuickCheck (testProperty) + +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 + ] + +testZTar :: Compression -> Property +testZTar compression = monadicIO $ do + archive:src:dest:paths <- pick $ uniqueListOf 4 arbitrary + + run $ withTempDir [absdir|/tmp|] "" $ \dir -> do + let paths' = map toRelFile paths + archive' = dir toRelFile archive + src' = dir toRelDir src + dest' = dir toRelDir dest + + -- write files to be bundled + forM_ paths' $ \path -> do + let path' = src' path + -- case writing `a` when `a/b` already exists + unlessM (isLocationOccupied path') $ do + ensureDir $ parent path' + writeFile (fromAbsFile path') (show path) + + -- create and extract archive + ensureDir $ parent archive' + create compression (fromAbsFile archive') (fromAbsDir src') + extract (fromAbsDir dest') (fromAbsFile archive') + + -- check files + fmap and $ forM paths' $ \path -> do + let path' = dest' path + isExist <- isLocationOccupied path' + isFile <- doesFileExist path' + case (isExist, isFile) of + (False, _) -> return False + (True, True) -> do + contents <- readFile $ fromAbsFile path' + return $ contents == show path + (True, False) -> return True + +{- Helpers -} + +-- | Generate a unique list with length at least N. +uniqueListOf :: Eq a => Int -> Gen a -> Gen [a] +uniqueListOf 0 gen = nub <$> listOf gen +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 + +-- | A valid file or directory name. +newtype ValidName = ValidName { unName :: String } + deriving (Show) + +instance Arbitrary ValidName where + arbitrary = do + -- https://stackoverflow.com/a/2306003/8565175 + name <- take 14 <$> listOf1 (elements validChars) + if last name == '.' || name `elem` ["nul"] + then arbitrary + else return $ ValidName name + where + validChars = ['a'..'z'] ++ ['0'..'9'] ++ ['.', '_', '-'] diff --git a/ztar.cabal b/ztar.cabal --- a/ztar.cabal +++ b/ztar.cabal @@ -1,12 +1,12 @@ name: ztar -version: 0.0.2 +version: 0.0.3 license: BSD3 license-file: LICENSE.md author: Brandon Chinn maintainer: Brandon Chinn category: Codec -synopsis: Creating and extracting compressed tar archives -description: Creating and extracting compressed tar archives. +synopsis: Creating and extracting arbitrary archives +description: Creating and extracting arbitrary archives. build-type: Simple cabal-version: 1.18 extra-doc-files: CHANGELOG.md, README.md @@ -15,17 +15,34 @@ type: git location: https://github.com/brandonchinn178/ztar.git +flag dev + description: Turn on development settings. + manual: True + default: False + library hs-source-dirs: src default-language: Haskell2010 - exposed-modules: Codec.Archive.Tar.GZip + exposed-modules: Codec.Archive.ZTar + Codec.Archive.ZTar.GZip + Codec.Archive.ZTar.Tar + Codec.Archive.ZTar.Zip build-depends: base >= 4.7 && < 5 , bytestring >= 0.10.8 && < 0.11 + , directory >= 1.3 && < 1.4 + , filepath >= 1.4.1 && < 1.5 , tar >= 0.5 && < 0.6 + , zip >= 1.0 && < 1.2 , zlib >= 0.6 && < 0.7 - ghc-options: - -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wcompat - -Wredundant-constraints -Wnoncanonical-monad-instances + ghc-options: -Wall + if flag(dev) + ghc-options: -Werror + if flag(dev) && impl(ghc >= 8.0) + ghc-options: -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wnoncanonical-monad-instances + -Wnoncanonical-monadfail-instances test-suite example type: exitcode-stdio-1.0 @@ -36,3 +53,35 @@ , path , path-io , ztar + ghc-options: -Wall + if flag(dev) + ghc-options: -Werror + if flag(dev) && impl(ghc >= 8.0) + ghc-options: -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wnoncanonical-monad-instances + -Wnoncanonical-monadfail-instances + +test-suite ztar-test + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + main-is: Test.hs + build-depends: base + , extra + , path + , path-io + , QuickCheck + , tasty + , tasty-quickcheck + , ztar + ghc-options: -Wall + if flag(dev) + ghc-options: -Werror + if flag(dev) && impl(ghc >= 8.0) + ghc-options: -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wnoncanonical-monad-instances + -Wnoncanonical-monadfail-instances