halfs-2.0: test/src/Tests/Instances.hs
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE FlexibleInstances #-}
module Tests.Instances
where
import Control.Applicative ((<$>), (<*>))
import Control.Exception (assert)
import Control.Monad (foldM, replicateM)
import Data.Bits (shiftL)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.List (nub, genericTake)
import Data.Serialize
import Data.Time
import Data.Word
import System.Random
import Test.QuickCheck
import Test.QuickCheck.Monadic hiding (assert)
import Halfs.BlockMap (Extent(..))
import Halfs.Inode ( Ext(..)
, ExtRef(..)
, Inode(..)
, InodeRef(..)
, computeNumAddrs
, minimalExtSize
, computeMinimalInodeSize
, minExtBlocks
, minInodeBlocks
, nilER
)
import Halfs.Directory
import Halfs.Protection (UserID(..), GroupID(..))
import Halfs.SuperBlock (SuperBlock(..))
import Tests.Types
--------------------------------------------------------------------------------
-- Block Device generators and helpers
-- | Generate an arbitrary geometry (modified by function given by the
-- first parameter) and employ the given geometry-requiring generator to
-- supply data to the given property.
forAllBlocksM :: Monad m =>
(BDGeom -> BDGeom)
-- ^ geometry transformer
-> (BDGeom -> Gen [(Word64, ByteString)])
-- ^ data generator
-> ([(Word64, ByteString)] -> BDGeom -> PropertyM m b)
-- ^ property constructor
-> PropertyM m b
forAllBlocksM f gen prop =
forAllM arbBDGeom $ \g -> let g' = f g in forAllM (gen g') (flip prop g')
-- | Generate a power of 2 given an exponent range in [0, 63]
powTwo :: Int -> Int -> Gen Word64
powTwo l h = assert (l >= 0 && h <= 63) $ shiftL 1 <$> choose (l, h)
arbBDGeom :: Gen BDGeom
arbBDGeom = arbitrary
-- | Creates arbitrary "filesystem data" : just block addresses and
-- block data, constrained by the given device geometry
arbFSData :: BDGeom -> Gen [(Word64, ByteString)]
arbFSData g = listOf1 $ (,) <$> arbBlockAddr g <*> arbBlockData g
-- | Creates arbitrary contiguous "filesystem data" : consecutive runs
-- of block addresses and accompanying block data, constrained by the
-- given device geometry
arbContiguousData :: BDGeom -> Gen [(Word64, ByteString)]
arbContiguousData g = do
let numBlks = fromIntegral $ bdgSecCnt g
limit = 64 -- artificial limit on number of contiguous blocks
-- generated; keeps generated data on the small side
numContig <- if numBlks > 1 -- maybe we can't create continguous blocks
then choose (2 :: Integer, max 2 (min limit (numBlks `div` 2)))
else return 1
baseAddrs <- (\x -> map fromIntegral [x .. x + numContig])
`fmap` choose (0 :: Integer, numBlks - numContig)
zip baseAddrs `fmap` vectorOf (fromIntegral numContig) (arbBlockData g)
arbBlockAddr :: BDGeom -> Gen Word64
arbBlockAddr (BDGeom cnt _sz) =
fromIntegral `fmap` choose (0 :: Integer, ub)
where ub = fromIntegral $ cnt - 1
arbBlockData :: BDGeom -> Gen ByteString
arbBlockData (BDGeom _cnt sz) = bytes (fromIntegral sz)
byte :: Gen Word8
byte = fromIntegral `fmap` choose (0 :: Int, 255)
bytes :: Int -> Gen ByteString
bytes n = BS.pack `fmap` replicateM n byte
printableBytes :: Int -> Gen ByteString
printableBytes n = BS.pack `fmap` replicateM n printableByte
printableByte :: Gen Word8
printableByte = fromIntegral `fmap` choose (33 :: Int, 126)
filename :: Int -> Gen String
filename maxLen =
resize maxLen $
listOf1 (elements $ ['0' .. '9'] ++ ['A'..'Z'] ++ ['a'..'z'] ++ ['_', '-'])
--------------------------------------------------------------------------------
-- BlockMap generators and helpers
newtype UnallocDecision = UnallocDecision Bool deriving Show
-- | Given an extent, generates subextents that cover it; useful for creating
-- allocation sequences. To keep the number of subextents relatively small, the
-- first two subextents generated cover ~75% of the input extent. The input
-- extent should be of reasonable size (>= 8) in order to avoid degenerate
-- corner cases.
arbExtents :: Extent -> Gen [Extent]
arbExtents ext@(Extent _ ub)
| ub < 8 = fail $ "Tests.Instances.arbExtents: "
++ "Input extent size is too small (<8)"
| otherwise = arbExtents' ext
arbExtents' :: Extent -> Gen [Extent]
arbExtents' (Extent b ub) = do
filledQuarter <- fill (Extent (b + soFar) (ub - soFar))
let r = Extent b halfCnt : (Extent (b + halfCnt) quarterCnt : filledQuarter)
-- monotonically decreasing size over region groups
assert (halfCnt >= quarterCnt &&
quarterCnt >= sum (map extSz filledQuarter)) $ do
-- distinct base addrs
assert (let bs = map extBase r in length bs == length (nub bs)) $ do
-- exactly covers input extent and contains and no 0-size extents
assert (ub == foldr (\e -> assert (extSz e > 0) (extSz e +)) 0 r) $ do
return r
where
halfCnt = ub `div` 2
quarterCnt = ub `div` 4 + 1
soFar = halfCnt + quarterCnt
--
fill :: Extent -> Gen [Extent]
fill (Extent _ 0) = return []
fill (Extent b' ub') = do
sz <- choose (1, ub')
rest <- fill $ Extent (b' + sz) (ub' - sz)
return (Extent b' sz : rest)
-- | A hacky, inefficient-but-good-enough permuter
permute :: [a] -> Gen [a]
permute xs = do
let len = fromIntegral $ length xs
foldM rswap xs $ replicate len len
where
rswap [] _ = return []
rswap (x:xs') len = do
i <- choose (0, len - 1)
return $ let (l,r) = splitAt i xs'
in l ++ [x] ++ r
--------------------------------------------------------------------------------
-- Instances and helpers
instance Arbitrary UnallocDecision where
arbitrary = UnallocDecision `fmap` arbitrary
-- instance Arbitrary BDGeom where
-- arbitrary =
-- BDGeom
-- <$> powTwo 10 13 -- 1024..8192 sectors
-- <*> powTwo 9 12 -- 512b..4K sector size
-- -- => 512K .. 32M filesystem size
instance Arbitrary BDGeom where
arbitrary = return $ BDGeom 512 512
-- Generate an arbitrary version 1 superblock with coherent free and
-- used block counts. Block size and count are constrained by the
-- Arbitrary instance for BDGeom.
instance Arbitrary SuperBlock where
arbitrary = do
BDGeom cnt sz <- arbitrary
free <- choose (0, cnt)
SuperBlock
<$> return 1 -- version
<*> return sz -- blockSize
<*> return cnt -- blockCount
<*> arbitrary -- unmountClean
<*> return free -- freeBlocks
<*> return (cnt - free) -- usedBlocks
<*> arbitrary -- fileCount
<*> IR `fmap` arbitrary -- rootDir
<*> IR `fmap` return 1 -- blockMapStart
-- Generate an arbitrary inode with mostly coherent fields (filesize/allocated
-- block relationships are not cogent, however) based on the minimal inode size
-- computation for an arbitrary device geometry.
instance (Arbitrary a, Ord a, Serialize a, Show a) => Arbitrary (Inode a) where
arbitrary = do
BDGeom _ blkSz <- arbitrary
createTm <- arbitrary
addrCnt <- computeNumAddrs blkSz minInodeBlocks
=<< computeMinimalInodeSize createTm
Inode
<$> IR `fmap` arbitrary -- inoParent
<*> return (nilER, 0) -- inoLastER
<*> IR `fmap` arbitrary -- inoAddress
<*> arbitrary -- inoFileSize
<*> arbitrary -- inoAllocBlocks
<*> arbitrary -- inoFileType
<*> arbitrary -- inoMode
<*> arbitrary -- inoNumLinks
<*> return createTm -- inoCreateTime
<*> arbitrary `suchThat` (>= createTm) -- inoModifyTime
<*> arbitrary `suchThat` (>= createTm) -- inoAccessTime
<*> arbitrary `suchThat` (>= createTm) -- inoChangeTime
<*> arbitrary -- inoUser
<*> arbitrary -- inoGroup
<*> (arbitrary >>= \cont -> do -- inoCont
let blockCount' = min (blockCount cont) addrCnt
return
cont{ address = nilER
, blockCount = blockCount'
, blockAddrs = genericTake blockCount' (blockAddrs cont)
, numAddrs = min (numAddrs cont) addrCnt
}
)
-- Generate an arbitrary inode 'extension' (i.e., an Ext) with coherent fields
-- based on the minimal ext size computaton for an arbitrary device geometry
instance Arbitrary Ext where
arbitrary = do
BDGeom _ blkSz <- arbitrary
addrCnt <- computeNumAddrs blkSz minExtBlocks =<< minimalExtSize
numBlocks <- fromIntegral `fmap` choose (0, addrCnt)
Ext
<$> ER `fmap` (arbitrary `suchThat` (>=1)) -- address
<*> ER `fmap` arbitrary -- nextExt
<*> return (fromIntegral numBlocks) -- blockCount
<*> replicateM numBlocks validBlockAddr -- blockAddrs
-- Transient:
<*> return addrCnt -- numAddrs
where
validBlockAddr = let arb = arbitrary :: Gen (Positive Word64)
in (\(Positive v) -> v) <$> arb
-- Generate an arbitrary directory entry
instance Arbitrary DirectoryEntry where
arbitrary =
DirEnt
<$> (listOf1 arbitrary :: Gen String) -- deName
<*> IR `fmap` arbitrary -- deInode
<*> arbitrary -- deUser
<*> arbitrary -- deGroup
<*> (arbitrary :: Gen FileMode) -- deMode
<*> elements [RegularFile, Directory, Symlink] -- deType
instance Arbitrary UserID where
arbitrary = UID <$> arbitrary
instance Arbitrary GroupID where
arbitrary = GID <$> arbitrary
instance Arbitrary FileMode where
arbitrary =
FileMode <$> gp <*> gp <*> gp
where
gp = validAccess >>= permute
validAccess = elements [ []
, [Read]
, [Write]
, [Execute]
, [Read,Write]
, [Read,Execute]
, [Write,Execute]
, [Read,Write,Execute]
]
instance Arbitrary FileType where
arbitrary = elements [ RegularFile, Directory, Symlink ]
instance Arbitrary UTCTime where
arbitrary = UTCTime <$> arbitrary <*> arbitrary
instance Arbitrary Day where
arbitrary =
fromGregorian <$> choose (1900, 2200) <*> choose (1, 12) <*> choose (1, 31)
instance Arbitrary DiffTime where
arbitrary = do
sec <- choose (0, 86400)
ps <- choose (0, 10000000000000) -- 10^13, intentionally exceeds picosecond
-- resolution
return $ secondsToDiffTime sec + picosecondsToDiffTime ps
instance Random Word64 where
randomR = integralRandomR
random = randomR (minBound, maxBound)
integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)
integralRandomR (a,b) g =
case randomR (fromIntegral a :: Integer, fromIntegral b :: Integer) g of
(x, g') -> (fromIntegral x, g')