90 lines
3.5 KiB
Plaintext
90 lines
3.5 KiB
Plaintext
|
{-# LANGUAGE OverloadedStrings #-}
|
||
|
|
module Main ( main ) where
|
||
|
|
|
||
|
|
import Codec.Archive
|
||
|
|
import Codec.Archive.Roundtrip (itPacksUnpacks, itPacksUnpacksViaFS, roundtrip, roundtripFreaky, roundtripStrict)
|
||
|
|
import Codec.Archive.Test
|
||
|
|
import Data.Either (isRight)
|
||
|
|
import Data.Foldable (traverse_)
|
||
|
|
import System.Directory (doesDirectoryExist, listDirectory)
|
||
|
|
import System.FilePath ((</>))
|
||
|
|
import System.IO.Temp (withSystemTempDirectory)
|
||
|
|
import Test.Hspec
|
||
|
|
|
||
|
|
testFp :: FilePath -> Spec
|
||
|
|
testFp fp = parallel $ it ("sucessfully unpacks/packs (" ++ fp ++ ")") $
|
||
|
|
roundtrip fp >>= (`shouldSatisfy` isRight)
|
||
|
|
|
||
|
|
testFpStrict :: FilePath -> Spec
|
||
|
|
testFpStrict fp = parallel $ it ("works on strict bytestring (" ++ fp ++ ")") $
|
||
|
|
roundtripStrict fp >>= (`shouldSatisfy` isRight)
|
||
|
|
|
||
|
|
testFpFreaky :: FilePath -> Spec
|
||
|
|
testFpFreaky fp = parallel $ it ("works on nonstandard bytestring (" ++ fp ++ ")") $
|
||
|
|
roundtripFreaky fp >>= (`shouldSatisfy` isRight)
|
||
|
|
|
||
|
|
unpack :: FilePath -> IO (Either ArchiveResult ())
|
||
|
|
unpack fp = withSystemTempDirectory "libarchive" $
|
||
|
|
\tmp -> runArchiveM $ unpackArchive fp tmp
|
||
|
|
|
||
|
|
readArchiveFile' :: FilePath -> IO (Either ArchiveResult [Entry])
|
||
|
|
readArchiveFile' = runArchiveM . readArchiveFile
|
||
|
|
|
||
|
|
testUnpackLibarchive :: FilePath -> Spec
|
||
|
|
testUnpackLibarchive fp = parallel $ it ("unpacks " ++ fp) $
|
||
|
|
unpack fp >>= (`shouldSatisfy` isRight)
|
||
|
|
|
||
|
|
testReadArchiveFile :: FilePath -> Spec
|
||
|
|
testReadArchiveFile fp = parallel $ it ("reads " ++ fp) $
|
||
|
|
readArchiveFile' fp >>= (`shouldSatisfy` isRight)
|
||
|
|
|
||
|
|
main :: IO ()
|
||
|
|
main = do
|
||
|
|
|
||
|
|
dir <- doesDirectoryExist "test/data"
|
||
|
|
tarballs <- if dir then listDirectory "test/data" else pure []
|
||
|
|
let tarPaths = ("test/data" </>) <$> tarballs
|
||
|
|
|
||
|
|
hspec $
|
||
|
|
describe "roundtrip" $ do
|
||
|
|
|
||
|
|
traverse_ testFp tarPaths
|
||
|
|
#ifndef LOW_MEMORY
|
||
|
|
traverse_ testFpFreaky tarPaths
|
||
|
|
traverse_ testFpStrict tarPaths
|
||
|
|
#endif
|
||
|
|
traverse_ testUnpackLibarchive tarPaths
|
||
|
|
traverse_ testReadArchiveFile tarPaths
|
||
|
|
|
||
|
|
context "with symlinks" $ do
|
||
|
|
let entries =
|
||
|
|
[ simpleDir "x/"
|
||
|
|
, simpleFile "x/a.txt" (NormalFile "referenced")
|
||
|
|
, simpleFile "x/b.txt" (Symlink "a.txt" SymlinkUndefined)
|
||
|
|
]
|
||
|
|
itPacksUnpacks entries
|
||
|
|
itPacksUnpacksViaFS entries
|
||
|
|
|
||
|
|
context "with hardlinks" $ do
|
||
|
|
let entries =
|
||
|
|
[ simpleDir "x/"
|
||
|
|
, simpleFile "x/a.txt" (NormalFile "shared")
|
||
|
|
, simpleFile "x/b.txt" (Hardlink "x/a.txt")
|
||
|
|
]
|
||
|
|
itPacksUnpacks entries
|
||
|
|
context "issue#4" $ itPacksUnpacksViaFS entries
|
||
|
|
|
||
|
|
context "with forward referenced hardlinks" $ do
|
||
|
|
let entries =
|
||
|
|
[ simpleDir "x/"
|
||
|
|
, simpleFile "x/b.txt" (Hardlink "x/a.txt")
|
||
|
|
, simpleFile "x/a.txt" (NormalFile "shared")
|
||
|
|
]
|
||
|
|
itPacksUnpacks entries
|
||
|
|
xcontext "re-ordering on unpack" $ itPacksUnpacksViaFS entries
|
||
|
|
|
||
|
|
xcontext "having entry without ownership" . itPacksUnpacks $
|
||
|
|
[ stripOwnership (simpleFile "a.txt" (NormalFile "text")) ]
|
||
|
|
xcontext "having entry without timestamp" . itPacksUnpacks $
|
||
|
|
[ stripTime (simpleFile "a.txt" (NormalFile "text")) ]
|