[Haskell] filesystem verification utility

[Anand Mitra]

Hi,

I had a requirement to generate various kinds of I/O patterns on a
filesystem and subsequently verify this. The initial version of the
program below implements a random I/O pattern with multiple threads.
Even when the number of I/O is as small as 200 and 10 concurrent
theads, the amount of memory used is huge. When I run the program it
consumes close to 1to2GB memory. Moreover the rate at which it
generates the I/O is very low which is not good for testing a
filesystem. I have used System.POSIX.IO but I tried System.IO and did
not see much difference either. I would appreciate help in identifying
ways to improve this.


{-# OPTIONS -fglasgow-exts #-}
import System.Random
import Data.List
import Monad
import System.Posix.IO
import System.Posix.Types
import Data.Time.Clock
import System.Posix.Files
import Data.Maybe
import GHC.IO.Device (SeekMode(..))
import Control.Exception
import Data.Typeable
import System
import Control.Concurrent

--myrandomRlist :: (Num t, Random t) => t -> IO [t]
--myrandomRlist x = liftM (randomRs (0,x)) newStdGen

myrandomRlist :: (Num t, Random t) => t ->t -> StdGen  ->  [t]
myrandomRlist min max seed = randomRs (min,max)  seed

data IoLoc = IoLoc {offset :: FileOffset, size::ByteCount, num::Int  }
            deriving (Show, Typeable)
instance Exception IoLoc

data Corrupt = Corrupt String IoLoc
            deriving (Show, Typeable)
instance Exception Corrupt

data FileHdr = FileHdr {fileName::FilePath, seed::StdGen,
                       minIoSize::Int, maxIoSize::Int, ioCount::Int}
              deriving (Show)

data FileIO = FileIO {fd::Fd, params::FileHdr, fileData::[IoLoc]}

genPattern :: FilePath -> IoLoc -> String
genPattern f l =
    take (read $ show $size l) (cycle  $ "(" ++ f ++ ")"  ++ "[" ++
(show (offset l)) ++ ":" ++ (show (size l)) ++ (show (num l)) ++ "]")

doHdrRead :: Fd -> IO [Char]
doHdrRead fd = do
 (str, count) <- fdRead fd 100
 return (takeWhile (\x-> not (x == '\n')) str)

doGetHdr :: Fd -> IO FileHdr
doGetHdr fd = do
 file <- doHdrRead fd
 seed <- doHdrRead fd
 minIoSize <- doHdrRead fd
 maxIoSize <- doHdrRead fd
 ioCount <- doHdrRead fd
 return (FileHdr file (read seed) (read minIoSize) (read maxIoSize)
(read ioCount))

doHdrFromFile :: FilePath -> IO FileIO
doHdrFromFile name = do
 fd <- openFd name  ReadWrite (Just ownerModes)  (OpenFileFlags
{append=False, exclusive=False, noctty=True, nonBlock=False,
trunc=False})
 hdr <- doGetHdr fd
 return (FileIO fd hdr [])

doHdrWrite :: Fd -> [Char] -> IO ByteCount
doHdrWrite fd str = do
 fdWrite fd (take 100 (str ++ "\n" ++ (cycle ['\0'])))

doWriteHdr :: Fd -> FileHdr -> IO ByteCount
doWriteHdr fd hdr = do
 doHdrWrite fd (show (fileName hdr))
 doHdrWrite fd (show (seed hdr))
 doHdrWrite fd (show (minIoSize hdr))
 doHdrWrite fd (show (maxIoSize hdr))
 doHdrWrite fd (show (ioCount hdr))

doWriteFile :: FilePath -> IO FileHdr
doWriteFile name = do
 fd <- openFd name  ReadWrite (Just ownerModes)  (OpenFileFlags
{append=False, exclusive=False, noctty=True, nonBlock=False,
trunc=True})
 seed <- newStdGen
 hdr <- return (FileHdr name seed 4096 (2*8096) 200)
 doWriteHdr fd hdr
 return hdr

overLap (IoLoc off1' sz1' num1) (IoLoc off2' sz2' num2) =
   ((off1 > off2) && (off1 < off2 +sz2)) ||((off1+sz1 >off2)
&&(off1+sz1 < off2 +sz2))
   where
     off1 = read (show off1')
     sz1 = read (show sz1')
     off2 = read (show off2')
     sz2 = read (show sz2')


genIoList1 :: [IoLoc] -> [Int] -> [Int] -> Int -> Int -> [IoLoc]

genIoList1 list offset size _ 0 =
   list
genIoList1 list offset size 0 _ =
   list

genIoList1 list (offset:os) (size:ss) count bound =
   if isNothing $ find (overLap x) list
            then genIoList1 ([x] ++ list) os ss (count - 1) (bound -1)
            else genIoList1 list os ss count (bound -1)
   where
     x = IoLoc (read (show offset)) (read(show size)) count
--      offset = (read (show offset1))
--      size = (read(show size1))

genIoList :: FileHdr -> [IoLoc]
genIoList (FileHdr name seed min max count) =
   genIoList1 []  (myrandomRlist 4000 1099511627776 seed)
(myrandomRlist min max seed) count (count*2)

doActualIo :: Fd -> IoLoc -> String -> IO ()
doActualIo fd (IoLoc off sz num) str = do
 off <- fdSeek fd AbsoluteSeek off
 fdWrite fd str
 return ()

doVerifyIo :: Fd -> IoLoc -> String -> IO ()
doVerifyIo fd (IoLoc off sz num) str = do
 off <- fdSeek fd AbsoluteSeek off
 (filedata, count) <- fdRead fd sz
 if str == filedata
    then return ()
    else throwIO (Corrupt ("Data corruption in #" ++  (take 200 str)
++ "#"  ++ (take 200 filedata))(IoLoc off sz num))

mainWrite file  = do
 hdr <- doWriteFile file
 hdrIO <- doHdrFromFile file
 iolst <- return $ genIoList hdr
 app <- return $ zip iolst (map (genPattern (fileName hdr)) iolst)
 putStrLn (fileName hdr)
 mapM (\(x,y)-> doActualIo (fd hdrIO)  x y) app
 mapM (\(x,y)-> doVerifyIo (fd hdrIO)  x y) app
 return hdr

mainVerify file = do
 hdrIO <- doHdrFromFile file
 hdr <- return (params hdrIO)
 iolst <- return $ genIoList hdr
 file <- return $ filter (\x->not ( x=='"')) (fileName hdr)
 app <- return $ zip iolst (map (genPattern file) iolst)
 putStrLn $ filter (\x->not ( x=='"')) (fileName hdr)
 mapM (\(x,y)-> doVerifyIo (fd hdrIO)  x y) app
 return hdr


main =  do
 x <- getArgs
 if (length x) == 3
   then do
     main1
   else do
     putStrLn "USAGE:\nfile-io write/verify <full-path file name>
<number of threads>  \
\\n\n\
\Simple IO load generator with write verification. This utility is designed\n\
\to generate multi-threaded IO load which will write a pattern to the file. \n\
\When this is invoked with the same parameters with the verify option \n\
\the data written will be verified.\n\
\ "

main1 = do
 [op, name, numProcs] <- getArgs
 m <- newEmptyMVar
 n <- return $read numProcs
 case op of
   "write" -> do mapM forkIO  [(fillfile (name ++ (show i)) ) m|i<-[1..n]]
   "verify" -> do mapM forkIO [(verifyfile (name ++ (show i)) ) m|i<-[1..n]]
 x <- mapM takeMVar $ take (read numProcs) $ repeat m
 putStrLn $ show $ and x

fillfile filename m = do
 mainWrite filename
 putMVar m True

verifyfile filename m = do
 mainVerify filename
 putMVar m True