halfs-0.2: HighLevelTests.hs

{-# LANGUAGE PatternSignatures #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  HighLevelTests
--
-- Maintainer  :  Isaac Jones <ijones@galois.com>
-- Stability   :  alpha
-- Portability :  GHC
--
-- Explanation: Implements higher-level interfaces like copying whole
-- files.  Implements high-level tests that tie together multiple modules.

module HighLevelTests where

import Halfs (withFSWrite, unmountFS, unmountWriteFS, withFSRead, mountFSMV,
              rename, mkdir, getDirectoryContents, openFileAtPathWrite,
              syncPeriodicallyWrite,
              openFileAtPathRead, withNewFSWrite, unlink, openAppend, seek,
              closeWrite, makeFiles, write,
              fsckWrite, closeWrite, closeRead, openRead, readReadRef)
import qualified Halfs as H (read)

import Halfs.TestFramework (Test(..), UnitTests, hunitToUnitTest,
                            assertCmd, assertEqual, assertBool)
import Halfs.BasicIO (devBufferReadHost, devBufferWriteHost,
                      getInodeWrite, getMemoryBlock)
import Binary(openBinMem, resetBin, put, get)
import Halfs.Inode (Inode(..), InodeMetadata(..), getPointerAt)
import Halfs.FSRoot (FSRoot(..))
import Halfs.FileHandle (FileHandle(..), FileMode(WriteMode), fhCloseWrite,
                         fhRead, fhWrite, fhSize)
import Halfs.FSState (FSWrite, FSRW, StateHandle(..), readToWrite, unsafeLiftIOWrite,
                      putStrLnWriteRead, unsafeLiftIORW, evalFSWriteIOMV,
                      unsafeLiftIOWriteWithRoot, unsafeReadGet, unsafeLiftIORead,
                      runFSWriteIO, throwError, runFSReadIO, unsafeWriteGet)
import Halfs.Buffer (strToNewBuff, newBuff, buffToStrSize)
import Halfs.Blocks (getBlockFromCacheOrDeviceWrite, getDiskAddrOfBlockWrite)
import Halfs.BufferBlock(mkDiskAddressBlock, getPartBufferBlock)
import Halfs.TheBlockMap(TheBlockMap(..))
import System.RawDevice(RawDevice, devBufferWrite, devBufferRead, newDevice)
import qualified Binary (get)
import Halfs.Utils (FileType(..), bytesPerBlock, mRemoveFile )
import Data.Integral ( INInt, inIntToInt, intToINLong, INLong
                     , fromIntegral', fromIntegral'')
import Data.Word (Word8)

-- base
import System.IO(openFile, hClose, hFileSize, IOMode(ReadMode))
import System.IO.Error (isFullError)
import System.Posix.IO (OpenMode(..), openFd, closeFd, defaultFileFlags)
import System.Posix.Files(unionFileModes, ownerReadMode, ownerWriteMode, groupReadMode)
import Control.Monad(when)
import Control.Monad.Error(throwError, catchError)
import Control.Concurrent( MVar, modifyMVar_, newEmptyMVar
                         , takeMVar, newMVar, putMVar
                         , forkIO, threadDelay)
import System.Random(randomR, getStdRandom)
import qualified Control.Exception as CE (finally)
--UNUSED:import qualified Control.Exception as CE (catch, throwIO)
import Control.Exception (finally)
import Data.Queue(queueToList)

-- ------------------------------------------------------------
-- * Interacting with host filesystem
-- ------------------------------------------------------------

-- |FIX: For now only works with file size < bufferSize. overwrites
-- existing file.
copyFromHost :: FSRoot
             -> FilePath -- ^From (host)
             -> FilePath -- ^To (fs)
             -> IO ((FileHandle, INInt), FSRoot)
copyFromHost fsroot fromPath toPath = do
  fileSize <- (do h <- openFile fromPath ReadMode
                  s <- hFileSize h
                  hClose h
                  return s)

  hFrom <- openFd fromPath ReadWrite Nothing defaultFileFlags
  putStrLn $ "copyFromHost fileSize: " ++ (show fileSize)
  buffer <- openBinMem $ fromIntegral'' fileSize
  devBufferReadHost hFrom 0 buffer (fromIntegral'' fileSize)
  closeFd hFrom
  resetBin buffer
  (toFsHandle, newRoot)
      <- runFSWriteIO (openFileAtPathWrite Halfs.FileHandle.WriteMode toPath File False) fsroot
  runFSWriteIO (do r <- fhWrite toFsHandle buffer 0 (fromIntegral'' fileSize)
                   fhCloseWrite toFsHandle
                   return r
               ) newRoot

-- |FIX: For now only works with file size < bufferSize. overwrites
-- existing file.
copyToHost :: FSRoot
           -> FilePath -- ^From (fs)
           -> FilePath -- ^To (host)
           -> IO ((FileHandle, INInt), FSRoot)
copyToHost fsroot0 fromPath toPath = do
  ((fromFsHandle, bytesToCopy), fsroot1)
      <- runFSReadIO (do a <- openFileAtPathRead fromPath
                         b <- fhSize a
                         return (a,b)
                     ) fsroot0 (\e -> throwError e)
  -- FIX: do this one block at a time?  may run out of memory on big files.
  putStrLn $ "copyTo bin mem: " ++ (show bytesToCopy)
  -- Put up with fromIntegral'' here because this is just testing code.
  buffer <- openBinMem (fromIntegral'' (bytesToCopy::INLong))
  readVal@((_, numRead), _fsroot2) <-
      runFSReadIO (fhRead fromFsHandle buffer 0 (fromIntegral'' bytesToCopy))
                       fsroot1 (\e -> throwError e)
  resetBin buffer
  hTo <- openFd toPath ReadWrite (Just (foldl1 unionFileModes [ ownerReadMode
                                                              , ownerWriteMode
                                                              , groupReadMode]))
                  defaultFileFlags
  devBufferWriteHost hTo 0 buffer (inIntToInt numRead)
  closeFd hTo
  return readVal

-- ------------------------------------------------------------
-- * Testing
-- ------------------------------------------------------------

-- Problem: This function doesn't properly use the mvar for
-- threading. maybe I should make it impossible to get the mvar out
-- without blocking...

copyAndCheckFile :: String -> FilePath -> FilePath -> Test
copyAndCheckFile message path targetFS =
   TestLabel message $ TestCase $ do
      let targetNative = "tests/fromFS"
      mRemoveFile targetNative
      withFSWrite dirFS (unsafeLiftIOWriteWithRoot (\fsroot -> do
        catchError (do
          (_, fsroot1) <- copyFromHost fsroot path targetFS
          unmountFS fsroot1
         ) (unmountAndThrow fsroot))) -- clean unmount
      withFSWrite dirFS  (unsafeLiftIOWriteWithRoot (\fsroot -> do
        catchError (do
          (_, fsroot1) <- copyToHost fsroot targetFS targetNative
          assertCmd ("diff " ++ path ++ " " ++ targetNative)
                      ("fs file copy failed: " ++ message)
          (_, fsroot2) <- runFSWriteIO (unlink targetFS) fsroot1
          unmountFS fsroot2
         ) (unmountAndThrow fsroot))) -- clean unmount

unmountAndThrow :: FSRoot -> IOError -> IO ()
unmountAndThrow fsroot e = unmountFS fsroot >> throwError e

dirFS :: FilePath
dirFS = "halfs-client1"

unitTests :: Bool -> UnitTests
unitTests runFast = hunitToUnitTest (hunitTests runFast)

assertEqualRW :: (Eq a, Show a, FSRW m) => String -> a -> a -> m ()
assertEqualRW s a b = unsafeLiftIORW $ assertEqual s a b

assertBoolRW :: (FSRW m) => String -> Bool -> m ()
assertBoolRW s b = unsafeLiftIORW $ assertBool s b

-- ------------------------------------------------------------
-- * Multi-Threaded tests
-- ------------------------------------------------------------

-- Helpers:

addResult :: MVar [Maybe String] -> (Maybe String) -> IO ()
addResult mv b =
  modifyMVar_ mv (\l -> return (b:l))

assertMString Nothing = assertBool "" True
assertMString (Just s) = assertBool s False

waitAll :: [MVar a] -> IO ()
waitAll l = mapM_ takeMVar l

myForkIO :: IO () -> IO (MVar ())
myForkIO io = do
  mvar <- newEmptyMVar
  forkIO (io `finally` putMVar mvar ())
  return mvar

delayRandom :: Int -- ^Max number of seconds to delay
            -> IO ()
delayRandom s = do
  randNum <- getStdRandom (\g -> randomR (0, secondToMicroSecond s) g)
  threadDelay randNum

secondToMicroSecond n = n * 1000000

-- TESTS
nSheeps :: Int -> FilePath -> FSWrite [Maybe String]
nSheeps n dirName = do
  mkdir dirName
  makeFiles n dirName "sheep"
  return [Nothing]

runTest :: MVar [Maybe String] -- ^Results
        -> StateHandle
        -> FSWrite [Maybe String]
        -> IO (MVar ())
runTest mv h f =
 myForkIO $ do delayRandom 10
--               results <- CE.catch (evalFSWriteIOMV f h)
--                                   (\e -> addResult mv (Just (show e))
--                                          >> CE.throwIO e)
               results <- evalFSWriteIOMV f h
               mapM_ (addResult mv) results

-- |Doesn't block on outer blocker.
runTest' :: MVar [Maybe String] -- ^Results
         -> MVar FSRoot
         -> FSWrite [Maybe String]
         -> IO (MVar ())
runTest' mv h f =
 myForkIO $ do delayRandom 10
               results <- evalFSWriteIOMV f (StateHandle h Nothing)
               mapM_ (addResult mv) results

-- Controller:

multiThreadTests :: Bool -> Test
multiThreadTests runFast =
  TestLabel ("multi-thread tests") $ TestCase $ do
  blocker <- newMVar ()
  -- should fork off a sync thread:
  stateHandle@(StateHandle smallMv _)
      <- mountFSMV Nothing dirFS (Just blocker) False 500
  resultsMV <- newMVar []

  let rt = runTest resultsMV stateHandle
  let rt' = runTest' resultsMV smallMv
  let (sheepThreads, extraThreads, syncThreads)
          = if runFast
            then (50, 50, 1)
            else (300, 100, 5)
  -- many threads, grab the nSheep mvar many times and make only 4 dirs each.
  waitOn2 <- mapM rt [nSheeps 2 ("/sheeps" ++ (show n)) | n <- [1..sheepThreads] ]

  -- 50 fsck threads
  waitOn3 <- mapM rt (replicate extraThreads (fsckWrite >> return [Nothing]))
  waitOnSync <- mapM rt' (replicate syncThreads (syncPeriodicallyWrite blocker False
                                      >> return [Nothing]))

  waitOn1 <- mapM rt [ fsckWrite >> return [Nothing]
                     , nSheeps extraThreads "/sheeps" -- grabs mvar only once.
                     , fsckWrite >> return [Nothing]
                     ]

  waitAll $ concat [waitOn1, waitOn2, waitOn3]

  evalFSWriteIOMV unmountWriteFS stateHandle
  -- the sync thread won't die 'till we unmount.
  waitAll waitOnSync

  results <- takeMVar resultsMV
  mapM assertMString results
  putStrLn "unmounting"
  return ()


-- ------------------------------------------------------------
-- * Block-level atomicity tests
-- ------------------------------------------------------------

toggle :: Word8 -> Word8
toggle 0 = 1
toggle 1 = 0
toggle 3 = 4
toggle 4 = 3
toggle n = (n-1)

writer :: RawDevice -> Word8 -> Int -> IO ()
writer lowDev n timeLeft
    | timeLeft <= 0 = return ()
    | otherwise = do
        let word8s = replicate bytesPerBlock (n::Word8)
        block <- getMemoryBlock
        mapM (put block) word8s
        resetBin block
        devBufferWrite lowDev 1 block
        writer lowDev (toggle n) (timeLeft - 1)

reader lowDev timeLeft
    | timeLeft <= 0 = return ()
    | otherwise = do
        block <- getMemoryBlock
        devBufferRead lowDev 1 block
        resetBin block
        ((h::Word8):words) <- sequence $ replicate bytesPerBlock (get block)
        let allEq = and [h == w | w <- words]
        assertBool ("Failure in test for block-level atomicity at timeLeft = " ++
                              show timeLeft ++ ": " ++
                              show (h:words))
                   allEq
        reader lowDev (timeLeft - 1)

testBuffs :: Test
testBuffs = TestLabel ("block-level atomicity tests") $ TestCase $ do
  lowDev  <- newDevice Nothing "halfs-client1" 2
  --  highDev <- makeRawDevice "halfs-4EYES"
  -- make block uniform before any read operations
  writer lowDev 1 1
  let numIterations = 100
  waitWriters <- mapM myForkIO [ writer lowDev 1 numIterations
                               , writer lowDev 0 numIterations
                               , writer lowDev 3 numIterations
                               , writer lowDev 4 numIterations]

  threadDelay (secondToMicroSecond 2)
  waitReaders <- mapM myForkIO (replicate 5 (reader lowDev numIterations))

  waitAll $ concat [waitWriters, waitReaders]

-- ------------------------------------------------------------
-- * Collection of tests
-- ------------------------------------------------------------

slowTests = [testBuffs]


hunitTests :: Bool  -- ^run fast?
           -> [Test]
hunitTests runFast = (if runFast then [] else slowTests) ++
  [TestLabel "shell.hs: mkdir tmp" $ TestCase $ do
     withNewFSWrite dirFS 5000  (mkdir "/tmp" >> unmountWriteFS)
  ,(multiThreadTests runFast)
  ,copyAndCheckFile "one-block file" "tests/from" "/tmp/toNative"
  ,copyAndCheckFile "small file" "tests/smallFile" "/tmp/smallFile"
  ,copyAndCheckFile "small file 2" "tests/smallFile" "/tmp/smallFile"
  ,copyAndCheckFile "multi-block file" "tests/multiBlockFile" "/tmp/multiBlockFile"
  ,copyAndCheckFile "level-2 file" "tests/70KFile" "/70KFile"
  ,TestLabel "move" $ TestCase $ do
   withFSWrite dirFS (unsafeLiftIOWriteWithRoot (\fsroot -> do
     (_, fsroot) <- copyFromHost fsroot "tests/multiBlockFile" "/tmp/multiBlockFile"
     unmountFS fsroot))

   withFSWrite dirFS (do
     let ls = readToWrite . getDirectoryContents
     ls "/tmp" >>= assertEqualRW "tmp dir has files we created"
                        [".", "multiBlockFile"]
     rename "/tmp/multiBlockFile" "/tmp/multiBlockFile2"
     ls "/tmp" >>= assertEqualRW "ls after a move"
                        [".", "multiBlockFile2"]
     unmountWriteFS
    )
  ]