ghcup-hs/3rdparty/libarchive/test/Spec.cpphs

90 lines
3.5 KiB
Plaintext
Raw Normal View History

{-# 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")) ]