diff --git a/Codec/Archive/Tar.hs b/Codec/Archive/Tar.hs --- a/Codec/Archive/Tar.hs +++ b/Codec/Archive/Tar.hs @@ -202,8 +202,11 @@ -> [RawFilePath] -- ^ Files and directories to archive, relative to base dir -> IO () create tar base paths = - withRawFilePath tar $ (\p -> writeFileL p (Just newFilePerms) . write =<< pack base paths) + withRawFilePath tar $ (\p -> either go go p) + where + go p = writeFileL p (Just newFilePerms) . write =<< pack base paths + -- | Extract all the files contained in a @\".tar\"@ file. -- -- It is equivalent to calling the standard @tar@ program like so: @@ -235,7 +238,7 @@ extract :: RawFilePath -- ^ Destination directory -> RawFilePath -- ^ Tarball -> IO () -extract dir tar = unpack dir . read =<< (withRawFilePath tar $ readFile) +extract dir tar = unpack dir . read =<< (withRawFilePath tar $ either readFile readFile) -- | Append new entries to a @\".tar\"@ file from a directory of files. -- diff --git a/Codec/Archive/Tar/Pack.hs b/Codec/Archive/Tar/Pack.hs --- a/Codec/Archive/Tar/Pack.hs +++ b/Codec/Archive/Tar/Pack.hs @@ -62,7 +62,7 @@ preparePaths :: RawFilePath -> [RawFilePath] -> IO [RawFilePath] preparePaths baseDir paths = fmap concat $ interleave - [ do isDir <- withRawFilePath (baseDir path) $ \p -> doesDirectoryExist p + [ do isDir <- withRawFilePath (baseDir path) $ \p -> either doesDirectoryExist doesDirectoryExist p if isDir then do entries <- getDirectoryContentsRecursive (baseDir path) let entries' = map (path ) entries @@ -104,7 +104,7 @@ -> IO Entry packFileEntry filepath tarpath = do mtime <- getModTime filepath - executable <- withRawFilePath filepath $ isExecutable + executable <- withRawFilePath filepath $ either isExecutable isExecutable file <- openFd filepath SPI.ReadOnly [] Nothing >>= SPI.fdToHandle size <- hFileSize file content <- L.hGetContents file @@ -151,7 +151,7 @@ recurseDirectories :: RawFilePath -> [RawFilePath] -> IO [RawFilePath] recurseDirectories _ [] = return [] recurseDirectories base (dir:dirs) = unsafeInterleaveIO $ do - (files, dirs') <- collect [] [] =<< ((fmap . fmap) toFilePath $ (withRawFilePath (base dir) $ getDirsFiles')) + (files, dirs') <- collect [] [] =<< ((fmap . fmap) toFilePath $ (withRawFilePath (base dir) $ either getDirsFiles' getDirsFiles')) files' <- recurseDirectories base (dirs' ++ dirs) return (dir : files ++ files') @@ -163,7 +163,7 @@ collect files dirs' (entry:entries) = do let dirEntry = dir entry dirEntry' = FilePath.Posix.addTrailingPathSeparator dirEntry - isDirectory <- withRawFilePath (base dirEntry) $ doesDirectoryExist + isDirectory <- withRawFilePath (base dirEntry) $ either doesDirectoryExist doesDirectoryExist if isDirectory then collect files (dirEntry':dirs') entries else collect (dirEntry:files) dirs' entries @@ -171,5 +171,5 @@ getModTime :: RawFilePath -> IO EpochTime getModTime path = do - t <- withRawFilePath path $ getModificationTime + t <- withRawFilePath path $ either getModificationTime getModificationTime return . floor . utcTimeToPOSIXSeconds $ t diff --git a/Codec/Archive/Tar/Unpack.hs b/Codec/Archive/Tar/Unpack.hs --- a/Codec/Archive/Tar/Unpack.hs +++ b/Codec/Archive/Tar/Unpack.hs @@ -91,15 +91,19 @@ -- 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. - withRawFilePath absDir (\p -> createDirRecursive newDirPerms p) - withRawFilePath absPath (\p -> writeFileL p (Just newFilePerms) content) + withRawFilePath absDir (\p -> either (createDirRecursive newDirPerms) + (createDirRecursive newDirPerms) p) + withRawFilePath absPath (\p -> case p of + Right x -> writeFileL x (Just newFilePerms) content + Left x -> writeFileL x (Just newFilePerms) content) setModTime absPath mtime where absDir = baseDir FilePath.Native.takeDirectory path absPath = baseDir path extractDir path mtime = do - withRawFilePath absPath $ \p -> createDirRecursive newDirPerms p + withRawFilePath absPath $ \p -> either (createDirRecursive newDirPerms) + (createDirRecursive newDirPerms) p setModTime absPath mtime where absPath = baseDir path @@ -112,10 +116,16 @@ emulateLinks = mapM_ $ \(relPath, relLinkTarget) -> do let absPath = baseDir relPath absTarget = FilePath.Native.takeDirectory absPath relLinkTarget - withRawFilePath absPath $ \absPath' -> withRawFilePath absTarget $ \absTarget' -> copyFile absTarget' absPath' Overwrite + let copy x y = copyFile x y Overwrite + withRawFilePath absPath $ \absPath' -> withRawFilePath absTarget $ \absTarget' -> case (absTarget', absPath') of + (Right x, Right y) -> copy x y + (Left x, Right y) -> copy x y + (Right x, Left y) -> copy x y + (Left x, Left y) -> copy x y setModTime :: RawFilePath -> EpochTime -> IO () -setModTime path t = withRawFilePath path $ \p -> do - setModificationTime p (fromIntegral t) - `Exception.catch` \e -> - if isPermissionError e then return () else throwIO e +setModTime path t = withRawFilePath path $ \p -> either go go p + where + go p = setModificationTime p (fromIntegral t) + `Exception.catch` \e -> + if isPermissionError e then return () else throwIO e diff --git a/tar-bytestring.cabal b/tar-bytestring.cabal --- a/tar-bytestring.cabal +++ b/tar-bytestring.cabal @@ -1,5 +1,5 @@ name: tar-bytestring -version: 0.6.0.0 +version: 0.6.1.0 license: BSD3 license-file: LICENSE author: Duncan Coutts @@ -35,15 +35,15 @@ if os(windows) build-depends: unbuildable<0 buildable: False - build-depends: base >= 4.12 && < 5, - bytestring >= 0.10, - array < 0.6, - time >= 1.8, - containers >= 0.2 && < 0.6, - deepseq >= 1.1 && < 1.5, - hpath-io >= 0.11.0, - hpath >= 0.10.2, - hpath-filepath >= 0.10.2, + build-depends: base >= 4.12 && < 5, + bytestring >= 0.10, + array < 0.6, + time >= 1.8, + containers >= 0.2 && < 0.6, + deepseq >= 1.1 && < 1.5, + hpath-io >= 0.12.0 && < 0.13, + hpath >= 0.11.0 && < 0.12, + hpath-filepath >= 0.10.2 && < 0.11, unix, word8 @@ -73,26 +73,26 @@ PatternGuards ScopedTypeVariables - ghc-options: -Wall -fno-warn-unused-imports + ghc-options: -Wall -fno-warn-unused-imports -O2 -fspec-constr-recursive=16 -fmax-worker-args=16 test-suite properties if os(windows) build-depends: unbuildable<0 buildable: False type: exitcode-stdio-1.0 - build-depends: base >= 4.12 && < 5, - bytestring >= 0.10, + build-depends: base >= 4.12 && < 5, + bytestring >= 0.10, array, containers, deepseq, - time >= 1.8, + time >= 1.8, bytestring-handle, QuickCheck == 2.*, tasty >= 0.10, tasty-quickcheck >= 0.8, - hpath-io >= 0.11.0, - hpath >= 0.10.2, - hpath-filepath >= 0.10.2, + hpath-io >= 0.12.0 && < 0.13, + hpath >= 0.11.0 && < 0.12, + hpath-filepath >= 0.10.2 && < 0.11, unix, word8 @@ -134,17 +134,17 @@ type: exitcode-stdio-1.0 hs-source-dirs: . bench main-is: bench/Main.hs - build-depends: base >= 4.12 && < 5, - bytestring >= 0.10, + build-depends: base >= 4.12 && < 5, + bytestring >= 0.10, time, array, containers, deepseq, time, - criterion >= 1.0, - hpath-io >= 0.11.0, - hpath >= 0.10.2, - hpath-filepath >= 0.10.2, + criterion >= 1.0, + hpath-io >= 0.12.0 && < 0.13, + hpath >= 0.11.0 && < 0.12, + hpath-filepath >= 0.10.2 && < 0.11, unix, word8