diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -44,6 +44,14 @@ , Option ['h'] ["help"] (NoArg Help) "help" ] +quit :: Bool -> String -> IO a +quit failure msg = do + hPutStr stderr msg + _ <- exitWith $ if failure + then ExitFailure 1 + else ExitSuccess + return undefined + main :: IO () main = do argv <- getArgs @@ -53,9 +61,10 @@ (o, _, _) | Version `elem` o -> do putStrLn ("version " ++ showVersion version) exitWith ExitSuccess - (o, _, _) | Help `elem` o -> error $ usageInfo header options + (o, _, _) | Help `elem` o -> quit False $ usageInfo header options (o, (a:as), []) -> return (o, a:as) - (_, _, errs) -> error $ concat errs ++ "\n" ++ usageInfo header options + (_, [], []) -> quit True $ usageInfo header options + (_, _, errs) -> quit True $ concat errs ++ "\n" ++ usageInfo header options let verbosity = if Quiet `elem` opts then [] else [OptVerbose] let debug = Debug `elem` opts let cmd = case filter (`notElem` [Quiet, Help, Version, Debug]) opts of diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,14 @@ +zip-archive 0.3.2 + + * Add ZipOption to preserve symbolic links (#37, Tommaso Piazza). + Add OptPreserveSymbolicLinks constructor to ZipOption. If this option + is set, symbolic links will be preserved. Symbolic links are not + supported on Windows. + + * Require binary >= 0.6 (#36). + + * Improve exit handling in zip-archive program. + zip-archive 0.3.1.1 * readEntry: Read file as a strict ByteString. This avoids diff --git a/src/Codec/Archive/Zip.hs b/src/Codec/Archive/Zip.hs --- a/src/Codec/Archive/Zip.hs +++ b/src/Codec/Archive/Zip.hs @@ -70,7 +70,7 @@ import Data.Typeable (Typeable) import Text.Printf import System.FilePath -import System.Directory ( doesDirectoryExist, getDirectoryContents, createDirectoryIfMissing ) +import System.Directory ( doesDirectoryExist, getDirectoryContents, createDirectoryIfMissing, ) import Control.Monad ( when, unless, zipWithM ) import qualified Control.Exception as E import System.Directory ( getModificationTime ) @@ -81,12 +81,13 @@ import Control.Applicative #endif #ifndef _WINDOWS -import System.Posix.Files ( setFileTimes, setFileMode, fileMode, getFileStatus ) +import System.Posix.Files ( setFileTimes, setFileMode, fileMode, getSymbolicLinkStatus, symbolicLinkMode, readSymbolicLink, isSymbolicLink) #endif -- from bytestring import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as B +import qualified Data.ByteString.Lazy.Char8 as C (pack) -- text import qualified Data.Text.Lazy as TL @@ -155,6 +156,7 @@ | OptVerbose -- ^ Print information to stderr | OptDestination FilePath -- ^ Directory in which to extract | OptLocation FilePath Bool -- ^ Where to place file when adding files and whether to append current path + | OptPreserveSymbolicLinks -- ^ Preserve symbolic links as such. This option is ignored on Windows. deriving (Read, Show, Eq) data ZipException = @@ -252,17 +254,34 @@ readEntry :: [ZipOption] -> FilePath -> IO Entry readEntry opts path = do isDir <- doesDirectoryExist path +#ifdef _WINDOWS + let isSymLink = False +#else + fs <- getSymbolicLinkStatus path + let isSymLink = isSymbolicLink fs +#endif -- make sure directories end in / and deal with the OptLocation option let path' = let p = path ++ (case reverse path of ('/':_) -> "" - _ | isDir -> "/" + _ | isDir && not isSymLink -> "/" + _ | isDir && isSymLink -> "" | otherwise -> "") in (case [(l,a) | OptLocation l a <- opts] of ((l,a):_) -> if a then l p else l takeFileName p _ -> p) - contents <- if isDir - then return B.empty - else B.fromStrict <$> S.readFile path + contents <- +#ifndef _WINDOWS + if isSymLink + then do + linkTarget <- readSymbolicLink path + return $ C.pack linkTarget + else +#endif + if isDir + then + return B.empty + else + B.fromStrict <$> S.readFile path #if MIN_VERSION_directory(1,2,0) modEpochTime <- fmap (floor . utcTimeToPOSIXSeconds) $ getModificationTime path @@ -275,7 +294,11 @@ #ifdef _WINDOWS return $ entry #else - do fm <- fmap fileMode $ getFileStatus path + do + let fm = if isSymLink + then symbolicLinkMode + else fileMode fs + let modes = fromIntegral $ shiftL (toInteger fm) 16 return $ entry { eExternalFileAttributes = modes, eVersionMadeBy = versionMadeBy } @@ -327,12 +350,17 @@ setFileTimeStamp path (eLastModified entry) -- | Add the specified files to an 'Archive'. If 'OptRecursive' is specified, --- recursively add files contained in directories. If 'OptVerbose' is specified, +-- recursively add files contained in directories. if 'OptPreserveSymbolicLinks' +-- is specified, don't recurse into it. If 'OptVerbose' is specified, -- print messages to stderr. addFilesToArchive :: [ZipOption] -> Archive -> [FilePath] -> IO Archive addFilesToArchive opts archive files = do filesAndChildren <- if OptRecursive `elem` opts +#ifdef _WINDOWS then mapM getDirectoryContentsRecursive files >>= return . nub . concat +#else + then mapM (getDirectoryContentsRecursive' opts) files >>= return . nub . concat +#endif else return files entries <- mapM (readEntry opts) filesAndChildren return $ foldr addEntryToArchive archive entries @@ -426,18 +454,38 @@ (TOD epochsecs _) = addToClockTime timeSinceEpoch (TOD 0 0) in epochsecs +#ifndef _WINDOWS +getDirectoryContentsRecursive' :: [ZipOption] -> FilePath -> IO [FilePath] +getDirectoryContentsRecursive' opts path = do + if OptPreserveSymbolicLinks `elem` opts + then do + isDir <- doesDirectoryExist path + if isDir + then do + isSymLink <- fmap isSymbolicLink $ getSymbolicLinkStatus path + if isSymLink + then return [path] + else getDirectoryContentsRecursivelyBy (getDirectoryContentsRecursive' opts) path + else return [path] + else getDirectoryContentsRecursive path +#endif + getDirectoryContentsRecursive :: FilePath -> IO [FilePath] getDirectoryContentsRecursive path = do isDir <- doesDirectoryExist path if isDir - then do + then getDirectoryContentsRecursivelyBy getDirectoryContentsRecursive path + else return [path] + +getDirectoryContentsRecursivelyBy :: (FilePath -> IO [FilePath]) -> FilePath -> IO [FilePath] +getDirectoryContentsRecursivelyBy exploreMethod path = do contents <- getDirectoryContents path let contents' = map (path ) $ filter (`notElem` ["..","."]) contents - children <- mapM getDirectoryContentsRecursive contents' + children <- mapM exploreMethod contents' if path == "." then return (concat children) else return (path : concat children) - else return [path] + setFileTimeStamp :: FilePath -> Integer -> IO () setFileTimeStamp file epochtime = do diff --git a/tests/test-zip-archive.hs b/tests/test-zip-archive.hs --- a/tests/test-zip-archive.hs +++ b/tests/test-zip-archive.hs @@ -70,8 +70,10 @@ testFromToArchive :: FilePath -> Test testFromToArchive _tmpDir = TestCase $ do - archive <- addFilesToArchive [OptRecursive] emptyArchive ["LICENSE", "src"] - assertEqual "for (toArchive $ fromArchive archive)" archive (toArchive $ fromArchive archive) + archive1 <- addFilesToArchive [OptRecursive] emptyArchive ["LICENSE", "src"] + assertEqual "for (toArchive $ fromArchive archive)" archive1 (toArchive $ fromArchive archive1) + archive2 <- addFilesToArchive [OptRecursive, OptPreserveSymbolicLinks] emptyArchive ["tests/test_dir_with_symlinks"] + assertEqual "for (toArchive $ fromArchive archive)" archive2 (toArchive $ fromArchive archive2) testReadWriteEntry :: FilePath -> Test testReadWriteEntry tmpDir = TestCase $ do @@ -89,6 +91,13 @@ archive2 <- addFilesToArchive [OptRecursive, OptVerbose] archive1 ["LICENSE", "src"] assertBool "for recursive and nonrecursive addFilesToArchive" (length (filesInArchive archive1) < length (filesInArchive archive2)) +#ifndef _WINDOWS + archive3 <- addFilesToArchive [OptVerbose, OptRecursive] emptyArchive ["tests/test_dir_with_symlinks"] + archive4 <- addFilesToArchive [OptVerbose, OptRecursive, OptPreserveSymbolicLinks] emptyArchive ["tests/test_dir_with_symlinks"] + assertBool "for recursive and recursive by preserving symlinks addFilesToArchive" + (length (filesInArchive archive4) < length (filesInArchive archive3)) +#endif + testDeleteEntries :: FilePath -> Test testDeleteEntries _tmpDir = TestCase $ do diff --git a/zip-archive.cabal b/zip-archive.cabal --- a/zip-archive.cabal +++ b/zip-archive.cabal @@ -1,5 +1,5 @@ Name: zip-archive -Version: 0.3.1.1 +Version: 0.3.2 Cabal-Version: >= 1.10 Build-type: Simple Synopsis: Library for creating and modifying zip archives. @@ -35,7 +35,7 @@ Build-depends: base >= 3 && < 5, pretty, containers else Build-depends: base < 3 - Build-depends: binary >= 0.5, zlib, filepath, bytestring >= 0.10.0, + Build-depends: binary >= 0.6, zlib, filepath, bytestring >= 0.10.0, array, mtl, text >= 0.11, old-time, digest >= 0.0.0.1, directory, time Exposed-modules: Codec.Archive.Zip