Tests.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TupleSections #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Codec.Archive.Tar.Index.Tests
-- Copyright   :  (c) 2010-2015 Duncan Coutts
-- License     :  BSD3
--
-- Maintainer  :  duncan@community.haskell.org
-- Portability :  portable
--
-----------------------------------------------------------------------------
module Codec.Archive.Tar.Index.Tests (
    prop_lookup,
    prop_toList,
    prop_valid,
    prop_serialise_deserialise,
    prop_serialiseSize,
#ifdef MIN_VERSION_bytestring_handle
    prop_index_matches_tar,
#endif
    prop_finalise_unfinalise,
  ) where

import Codec.Archive.Tar (GenEntries(..), Entries, GenEntry, Entry, GenEntryContent(..))
import Codec.Archive.Tar.Index.Internal (TarIndexEntry(..), TarIndex(..), IndexBuilder, TarEntryOffset(..))
import qualified Codec.Archive.Tar.Index.Internal as Tar
import qualified Codec.Archive.Tar.Index.IntTrie as IntTrie
import qualified Codec.Archive.Tar.Index.IntTrie.Tests as IntTrie
import qualified Codec.Archive.Tar.Index.StringTable as StringTable
import qualified Codec.Archive.Tar.Index.StringTable.Tests as StringTable
import qualified Codec.Archive.Tar.Types as Tar
import qualified Codec.Archive.Tar.Write as Tar

import qualified Data.ByteString        as BS
import qualified Data.ByteString.Char8  as BS.Char8
import qualified Data.ByteString.Lazy   as LBS
import Data.Int
import Data.Monoid ((<>))
import qualified System.FilePath.Posix as FilePath
import System.IO

import Prelude hiding (lookup)
import qualified Prelude
import Test.QuickCheck
import Test.QuickCheck.Property (ioProperty)
import Control.Applicative ((<$>), (<*>))
import Control.Monad (unless)
import Data.Bifunctor (first)
import Data.List (nub, sort, sortBy, stripPrefix, isPrefixOf, uncons)
import qualified Data.List.NonEmpty as NE
import Data.Maybe
import Data.Function (on)
import Control.Exception (SomeException, try, throwIO)

#ifdef MIN_VERSION_bytestring_handle
import qualified Data.ByteString.Handle as HBS
#endif

-- Not quite the properties of a finite mapping because we also have lookups
-- that result in completions.

prop_lookup :: ValidPaths -> NonEmptyFilePath -> Property
prop_lookup (ValidPaths paths) (NonEmptyFilePath p) =
  case (Tar.lookup index p, Prelude.lookup p paths) of
    (Nothing,                    Nothing)          -> property True
    (Just (TarFileEntry offset), Just (_,offset')) -> offset === offset'
    (Just (TarDir entries),      Nothing)          ->
      fmap NE.head (NE.group (sort (map fst entries))) ===
        fmap NE.head (NE.group (sort completions))
    _                                              -> property False
  where
    index = construct paths
    completions = map fst $
      mapMaybe (uncons . FilePath.splitDirectories) $
        mapMaybe (stripPrefix (p ++ "/") . fst) paths

prop_toList :: ValidPaths -> Property
prop_toList (ValidPaths paths) =
    sort (Tar.toList index)
 === sort [ (path, off) | (path, (_sz, off)) <- paths ]
  where
    index = construct paths

prop_valid :: ValidPaths -> Property
prop_valid (ValidPaths paths) =
  StringTable.prop_valid   pathbits .&&.
  IntTrie.prop_lookup      intpaths .&&.
  IntTrie.prop_completions intpaths .&&.
  prop'

  where
    index@(TarIndex pathTable _ _) = construct paths

    pathbits = concatMap (map BS.Char8.pack . FilePath.splitDirectories . fst)
                         paths

    intpaths :: [([IntTrie.Key], IntTrie.Value)]
    intpaths =
      map (first (map (\(Tar.PathComponentId n) -> IntTrie.Key (fromIntegral n)))) $
        mapMaybe (\(path, (_size, offset)) -> (, IntTrie.Value offset) <$> Tar.toComponentIds pathTable path) paths

    prop' = conjoin $ flip map paths $ \(file, (_size, offset)) ->
      case Tar.lookup index file of
        Just (TarFileEntry offset') -> offset' === offset
        _                           -> property False

prop_serialise_deserialise :: ValidPaths -> Property
prop_serialise_deserialise (ValidPaths paths) =
    Just (index, BS.empty) === (Tar.deserialise . Tar.serialise) index
  where
    index = construct paths

prop_serialiseSize :: ValidPaths -> Property
prop_serialiseSize (ValidPaths paths) =
    case (LBS.toChunks . Tar.serialiseLBS) index of
      [c1] -> BS.length c1 === Tar.serialiseSize index
      _    -> property False
  where
    index = construct paths

newtype NonEmptyFilePath = NonEmptyFilePath FilePath deriving Show

instance Arbitrary NonEmptyFilePath where
  arbitrary = NonEmptyFilePath . FilePath.joinPath
                <$> listOf1 (elements ["a", "b", "c", "d"])

newtype ValidPaths = ValidPaths [(FilePath, (Int64, TarEntryOffset))] deriving Show

instance Arbitrary ValidPaths where
  arbitrary = do
      paths <- makeNoPrefix <$> listOf arbitraryPath
      sizes <- vectorOf (length paths) (getNonNegative <$> arbitrary)
      let offsets = scanl (\o sz -> o + 1 + blocks sz) 0 sizes
      return (ValidPaths (zip paths (zip sizes offsets)))
    where
      arbitraryPath   = FilePath.joinPath
                         <$> listOf1 (elements ["a", "b", "c", "d"])
      makeNoPrefix [] = []
      makeNoPrefix (k:ks)
        | all (not . isPrefixOfOther k) ks
                     = k : makeNoPrefix ks
        | otherwise  =     makeNoPrefix ks

      isPrefixOfOther a b = a `isPrefixOf` b || b `isPrefixOf` a

      blocks :: Int64 -> TarEntryOffset
      blocks size = fromIntegral (1 + ((size - 1) `div` 512))

-- Helper for bulk construction.
construct :: [(FilePath, (Int64, TarEntryOffset))] -> TarIndex
construct =
    either (const undefined) id
  . Tar.build
  . foldr (\(path, (size, _off)) es -> Next (testEntry path size) es) Done

example0 :: Entries ()
example0 =
         testEntry "foo-1.0/foo-1.0.cabal" 1500 -- at block 0
  `Next` testEntry "foo-1.0/LICENSE"       2000 -- at block 4
  `Next` testEntry "foo-1.0/Data/Foo.hs"   1000 -- at block 9
  `Next` Done

example1 :: Entries ()
example1 =
  Next (testEntry "./" 1500) Done <> example0

testEntry :: FilePath -> Int64 -> Entry
testEntry name size = case Tar.toTarPath False name of
  Left err -> error err
  Right path -> Tar.simpleEntry path (NormalFile mempty size)

-- | Simple tar archive containing regular files only
data SimpleTarArchive = SimpleTarArchive {
    simpleTarEntries :: Tar.Entries ()
  , simpleTarRaw     :: [(FilePath, LBS.ByteString)]
  , simpleTarBS      :: LBS.ByteString
  }

instance Show SimpleTarArchive where
  show = show . simpleTarRaw

#ifdef MIN_VERSION_bytestring_handle
prop_index_matches_tar :: SimpleTarArchive -> Property
prop_index_matches_tar sta =
    ioProperty (try go >>= either (\e -> throwIO (e :: SomeException))
                                  (\_ -> return True))
  where
    go :: IO ()
    go = do
      h <- HBS.readHandle True (simpleTarBS sta)
      goEntries h 0 (simpleTarEntries sta)

    goEntries :: Handle -> TarEntryOffset -> Entries () -> IO ()
    goEntries _ _ Done =
      return ()
    goEntries _ _ (Fail _) =
      throwIO (userError "Fail entry in SimpleTarArchive")
    goEntries h offset (Tar.Next e es) = do
      goEntry h offset e
      goEntries h (Tar.nextEntryOffset e offset) es

    goEntry :: Handle -> TarEntryOffset -> Tar.Entry -> IO ()
    goEntry h offset e = do
      e' <- Tar.hReadEntry h offset
      case (Tar.entryContent e, Tar.entryContent e') of
        (Tar.NormalFile bs sz, Tar.NormalFile bs' sz') ->
          unless (sz == sz' && bs == bs') $
            throwIO $ userError "Entry mismatch"
        _otherwise ->
          throwIO $ userError "unexpected entry types"
#endif

instance Arbitrary SimpleTarArchive where
  arbitrary = do
      numEntries <- sized $ \n -> choose (0, n)
      rawEntries <- mkRaw numEntries
      let entries = mkList rawEntries
      return SimpleTarArchive {
          simpleTarEntries = mkEntries entries
        , simpleTarRaw     = rawEntries
        , simpleTarBS      = Tar.write entries
        }
    where
      mkRaw :: Int -> Gen [(FilePath, LBS.ByteString)]
      mkRaw 0 = return []
      mkRaw n = do
         -- Pick a size around 0, 1, or 2 block boundaries
         sz <- sized $ \n -> elements (take n fileSizes)
         bs <- LBS.pack `fmap` vectorOf sz arbitrary
         es <- mkRaw (n - 1)
         return $ ("file" ++ show n, bs) : es

      mkList :: [(FilePath, LBS.ByteString)] -> [Tar.Entry]
      mkList []            = []
      mkList ((fp, bs):es) = case Tar.toTarPath False fp of
        Left err -> error err
        Right path -> entry : mkList es
          where
            entry   = Tar.simpleEntry path content
            content = NormalFile bs (LBS.length bs)

      mkEntries :: [Tar.Entry] -> Tar.Entries ()
      mkEntries []     = Tar.Done
      mkEntries (e:es) = Tar.Next e (mkEntries es)

      -- Sizes around 0, 1, and 2 block boundaries
      fileSizes :: [Int]
      fileSizes = [
                           0 ,    1 ,    2
        ,  510 ,  511 ,  512 ,  513 ,  514
        , 1022 , 1023 , 1024 , 1025 , 1026
        ]

-- | t'IndexBuilder' constructed from a 'SimpleIndex'
newtype SimpleIndexBuilder = SimpleIndexBuilder IndexBuilder
  deriving Show

instance Arbitrary SimpleIndexBuilder where
  arbitrary = SimpleIndexBuilder . build' . simpleTarEntries <$> arbitrary
    where
      -- like 'build', but don't finalize
      build' :: Show e => Entries e -> IndexBuilder
      build' = go Tar.empty
        where
          go !builder (Next e es) = go (Tar.addNextEntry e builder) es
          go !builder  Done       = builder
          go !_       (Fail err)  = error (show err)

prop_finalise_unfinalise :: SimpleIndexBuilder -> Property
prop_finalise_unfinalise (SimpleIndexBuilder index) =
    Tar.unfinalise (Tar.finalise index) === index

#if !(MIN_VERSION_base(4,5,0))
(<>) :: Monoid m => m -> m -> m
(<>) = mappend
#endif