libarchive-3.0.6.0: test/Spec.cpphs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
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.List (uncons)
import           Data.Foldable           (traverse_)
import           System.Directory        (doesDirectoryExist, listDirectory)
import           System.FilePath         ((</>))
import           System.IO.Temp          (withSystemTempDirectory)
import           Control.Exception (evaluate)
import           Control.DeepSeq
#ifdef mingw32_HOST_OS
import           System.Environment
import           Test.Hspec.Core.Runner
#endif
import           Test.Hspec

import qualified Data.ByteString.Base16        as B16
import qualified Crypto.Hash.SHA256            as SHA256
import qualified Data.Text.Encoding            as E
import qualified Data.Text                     as T

testFp :: FilePath -> Spec
testFp fp = it ("sucessfully unpacks/packs (" ++ fp ++ ")") $
    roundtrip fp >>= (`shouldSatisfy` isRight)

testFpStrict :: FilePath -> Spec
testFpStrict fp = it ("works on strict bytestring (" ++ fp ++ ")") $
    roundtripStrict fp >>= (`shouldSatisfy` isRight)

testFpStrict' :: FilePath -> Spec
testFpStrict' fp = it ("works on strict bytestring (" ++ fp ++ ")") $
    roundtripStrict' fp >>= (`shouldSatisfy` isRight)

testFpFreaky :: FilePath -> Spec
testFpFreaky fp = it ("works on nonstandard bytestring (" ++ fp ++ ")") $
    roundtripFreaky fp >>= (`shouldSatisfy` isRight)

unpack :: FilePath -> IO (Either ArchiveResult ())
unpack fp = withSystemTempDirectory "libarchive" $
    \tmp -> fmap force (evaluate =<< (runArchiveM $ unpackArchive fp tmp))

readArchiveFile' :: FilePath -> IO (Either ArchiveResult [Entry FilePath BS.ByteString])
readArchiveFile' fp = evaluate =<< (runArchiveM . readArchiveFile $ fp)

testUnpackLibarchive :: FilePath -> Spec
testUnpackLibarchive fp = it ("unpacks " ++ fp) $
    unpack fp >>= (`shouldSatisfy` isRight)

testReadArchiveFile :: FilePath -> Spec
testReadArchiveFile fp = it ("reads " ++ fp) $
    readArchiveFile' fp >>= (`shouldSatisfy` isRight)

repack :: ([Entry FilePath BS.ByteString] -> BSL.ByteString) -> String -> FilePath -> Spec
repack packer str fp = it ("should repack (" ++ str ++ ")") $ do
    res <- fmap force (evaluate =<< (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 }

testArchiveContentChecksum :: FilePath  -- ^ archive
                           -> FilePath  -- ^ file inside archive
						   -> String    -- ^ base64 encoded sha256sum
						   -> Spec
testArchiveContentChecksum archive file sha = it ("Verify checksum of " <> file <> " in archive " <> archive) $ do
  entries' <-  runArchiveM (readArchiveFile archive)
  entries <- either (ioError . userError . show) pure $ entries'
  let cabal_exe = uncons . fmap content . filter (\Entry{..} -> filepath == file) $ entries
  c <- case cabal_exe of
         (Just (NormalFile c, _)) -> pure c
         _ -> ioError $ userError $ "Could not find file " <> file <> " in archive " <> archive
  digest <- either (ioError . userError . show) pure . E.decodeUtf8' . B16.encode . SHA256.hash $ c
  digest `shouldBe` T.pack sha

main :: IO ()
main = do

    dir <- doesDirectoryExist "test/data"
    tarballs <- if dir then listDirectory "test/data" else pure []
    let tarPaths = ("test/data" </>) <$> tarballs

    hspec' $ do
        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")) ]

        describe "checksums" $ do
		  testArchiveContentChecksum
		    "test/data/plan_json.zip"
			"plan.json"
			"5eac50e94666fff2491e43f81a670ef243c272aa3afe1fc59c720004fe186feb"

  where
#ifdef mingw32_HOST_OS
    hspec' spec = getArgs >>= readConfig defaultConfig >>= (\c -> withArgs [] . runSpec spec $ c{ configConcurrentJobs = Nothing }) >>= evaluateSummary
#else
    hspec' = hspec
#endif