libarchive-3.0.2.2: test/Spec.cpphs

{-# LANGUAGE OverloadedStrings #-}
module Main ( main ) where

import           Codec.Archive
import           Codec.Archive.Roundtrip (itPacksUnpacks, itPacksUnpacksViaFS, roundtrip, roundtripFreaky, roundtripStrict, roundtripStrict')
import           Codec.Archive.Test
import qualified Data.ByteString         as BS
import qualified Data.ByteString.Lazy    as BSL
import           Data.Either             (isRight)
import           Data.Foldable           (traverse_)
import           System.Directory        (doesDirectoryExist, listDirectory)
import           System.FilePath         ((</>))
import           System.IO.Temp          (withSystemTempDirectory)
#ifdef mingw32_HOST_OS
import           System.Environment
import           Test.Hspec  hiding ( parallel )
import           Test.Hspec.Core.Runner

parallel :: SpecWith a -> SpecWith a
parallel = id
#else
import           Test.Hspec
#endif

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)

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 FilePath BS.ByteString])
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)

repack :: ([Entry FilePath BS.ByteString] -> BSL.ByteString) -> String -> FilePath -> Spec
repack packer str fp = parallel $ it ("should repack (" ++ str ++ ")") $ do
    res <- runArchiveM $ packer <$> readArchiveFile fp
    res `shouldSatisfy` bsValid

bsValid :: Either a BSL.ByteString -> Bool
bsValid = \x -> case x of { Left{} -> False; Right b -> not $ BSL.null b }

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_ (\fp -> repack entriesToBSLzip ("zip/" ++ fp) fp) tarPaths
            traverse_ (repack entriesToBSLCpio "cpio") tarPaths
            -- traverse_ (repack entriesToBSLXar "xar") tarPaths
            traverse_ (repack entriesToBSLShar "shar") tarPaths
            traverse_ (repack entriesToBSL7zip "7zip") tarPaths
            traverse_ testFpFreaky tarPaths
            traverse_ testFpStrict 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")) ]
  where
#ifdef mingw32_HOST_OS
    hspec' spec = getArgs >>= readConfig defaultConfig >>= (\c -> withArgs [] . runSpec spec $ c{ configConcurrentJobs = Nothing }) >>= evaluateSummary
#else
    hspec' = hspec
#endif