Test.hs

module Storage.Hashed.Test( tests ) where

import Prelude hiding ( read )
import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.ByteString.Char8 as BS
import System.Process
import System.Directory( doesFileExist, removeFile )
import Control.Monad( forM_, when )
import Data.Maybe
import Data.Word
import Data.Bits
import Data.List( (\\), sort )
import Storage.Hashed
import Storage.Hashed.AnchoredPath
import Storage.Hashed.Tree
import Storage.Hashed.Index
import Storage.Hashed.Utils
import Storage.Hashed.Darcs

import Test.HUnit
import Test.Framework( testGroup )
import Test.QuickCheck

import Test.Framework.Providers.HUnit
import Test.Framework.Providers.QuickCheck

------------------------
-- Test Data
--

files = [ floatPath "hashed-storage.cabal"
        , floatPath "Storage/Hashed.hs"
        , floatPath "Storage/Hashed/Index.hs" ]

emptyStub = Stub (return emptyTree) Nothing

testTree =
    makeTree [ (makeName "foo", emptyStub)
             , (makeName "subtree", SubTree sub)
             , (makeName "substub", Stub getsub Nothing) ]
    where sub = makeTree [ (makeName "stub", emptyStub)
                         , (makeName "substub", Stub getsub2 Nothing)
                         , (makeName "x", SubTree emptyTree) ]
          getsub = return sub
          getsub2 = return $ makeTree [ (makeName "file", File emptyBlob) ]

---------------------------
-- Test list
--

tests = [ testGroup "darcs" darcs
        , testGroup "Storage.Hashed.Index" index
        , testGroup "Storage.Hashed.Tree" tree
        , testGroup "Storage.Hashed.Utils" utils ]

--------------------------
-- Tests
--

darcs = [ testCase "specific files" have_files
        , testCase "pristine files" have_pristine_files
        , testCase "list == darcs show manifest" darcs_manifest
        , testCase "content == darcs show contents" darcs_contents ]
    where
      check_file t f = assertBool
                       ("path " ++ show f ++ " is in tree")
                       (isJust $ find t f)
      check_files = forM_ files . check_file
      have_files = readPlainTree "." >>= expand >>= check_files
      have_pristine_files =
         readDarcsPristine "." >>= expand >>= check_files

      -- NB. When hashed-storage replace slurpies in darcs, the following 2
      -- tests become useless, since they just check our code against darcs.
      darcs_manifest = do
        f <- lines `fmap` readProcess "darcs" ["show", "files" ] ""
        t <- readDarcsPristine "." >>= expand
        forM_ (f \\ ["."]) (\x -> check_file t (floatPath x))
        forM_ (list t)
              (\x -> assertBool (show (fst x) ++ " is in darcs show files") $
                     anchorPath "." (fst x) `elem` f)
      darcs_contents = do
        t <- readDarcsPristine "." >>= expand
        sequence_ [
          do our <- read b
             darcs <- readProcess "darcs" [ "show", "contents",
                                            anchorPath "." p ] ""
             assertEqual "contents match" (BL.unpack our) darcs
         | (p, File b) <- list t ]

index = [ testCase "index listing" check_index
        , testCase "index content" check_index_content
        , testCase "index versioning" check_index_versions ]
    where pristine = readDarcsPristine "." >>= expand
          build_index =
            do x <- pristine
               exist <- doesFileExist "_darcs/index"
               when exist $ removeFile "_darcs/index"
               idx <- updateIndexFrom "_darcs/index" darcsTreeHash x >>= expand
               return (x, idx)
          check_index =
            do (pris, idx) <- build_index
               (sort $ map fst $ list idx) @?= (sort $ map fst $ list pris)
          check_blob_pair p x y =
              do a <- read x
                 b <- read y
                 assertEqual ("content match on " ++ show p) a b
          check_index_content =
            do (_, idx) <- build_index
               plain <- readPlainTree "."
               x <- sequence $ zipCommonFiles check_blob_pair plain idx
               assertBool "files match" (length x > 0)
          check_index_versions =
            do writeFile "_darcs/index" "nonsense index... do not crash!"
               pris <- pristine
               idx <- expand =<<
                        readOrUpgradeIndex "_darcs/index" darcsTreeHash pristine
               (sort $ map fst $ list idx) @?= (sort $ map fst $ list pris)

tree = [ testCase "modifyTree" check_modify
       , testCase "complex modifyTree" check_modify_complex
       , testCase "expand" check_expand
       , testCase "expandPath" check_expand_path ]
    where blob x = File $ Blob (return (BL.pack x)) (Just $ sha256 $ BL.pack x)
          name = Name . BS.pack
          check_modify =
              let t = makeTree [(name "foo", blob "bar")]
                  modify = modifyTree t (floatPath "foo") (Just $ blob "bla")
               in do x <- read $ fromJust $ findFile t (floatPath "foo")
                     y <- read $ fromJust $ findFile modify (floatPath "foo")
                     assertEqual "old version" x (BL.pack "bar")
                     assertEqual "new version" y (BL.pack "bla")
          check_modify_complex =
              let t = makeTree [ (name "foo", blob "bar")
                               , (name "bar", SubTree t1) ]
                  t1 = makeTree [ (name "foo", blob "bar") ]
                  modify = modifyTree t (floatPath "bar/foo") (Just $ blob "bla")
               in do foo <- read $ fromJust $ findFile t (floatPath "foo")
                     foo' <- read $ fromJust $ findFile modify (floatPath "foo")
                     bar_foo <- read $ fromJust $
                                findFile t (floatPath "bar/foo")
                     bar_foo' <- read $ fromJust $
                                 findFile modify (floatPath "bar/foo")
                     assertEqual "old foo" foo (BL.pack "bar")
                     assertEqual "old bar/foo" bar_foo (BL.pack "bar")
                     assertEqual "new foo" foo' (BL.pack "bar")
                     assertEqual "new bar/foo" bar_foo' (BL.pack "bla")
          no_stubs t = null [ () | (_, Stub _ _) <- list t ]
          path = floatPath "substub/substub/file"
          badpath = floatPath "substub/substub/foo"
          check_expand = do
            x <- expand testTree
            assertBool "no stubs in testTree" $ not (no_stubs testTree)
            assertBool "stubs in expanded tree" $ no_stubs x
            assertBool "path reachable" $ path `elem` (map fst $ list x)
            assertBool "badpath not reachable" $
                       badpath `notElem` (map fst $ list x)
          check_expand_path = do
            t <- expandPath testTree path
            assertBool "path reachable" $ path `elem` (map fst $ list t)
            assertBool "badpath not reachable" $
                       badpath `notElem` (map fst $ list t)

utils = [ testProperty "xlate32" prop_xlate32
        , testProperty "xlate64" prop_xlate64 ]
    where prop_xlate32 x = (xlate32 . xlate32) x == x where types = x :: Word32
          prop_xlate64 x = (xlate64 . xlate64) x == x where types = x :: Word64

instance Arbitrary Word32 where
    arbitrary = do x <- arbitrary :: Gen Int
                   return $ fromIntegral x

instance Arbitrary Word64 where
    arbitrary = do x <- arbitrary :: Gen Int
                   y <- arbitrary :: Gen Int
                   let x' = fromIntegral x
                       y' = fromIntegral y
                   return $ x' .|. (y' `shift` 32)