packman-0.3.0: Test/TestExceptions.hs

{-
  Some tests to verify that serialisation works as expected
-}
module Main(mytests, main)
    where

import GHC.Packing

import qualified Data.Array.IArray as A
import Control.Concurrent

import System.Environment
import System.IO

import System.Directory
import qualified Data.ByteString as B
import Control.Exception
import Data.Typeable

-- import Distribution.TestSuite
import System.Exit
import Control.Monad

-- this test uses the trySerialize routine. We expect to trigger some
-- exceptions and catch them as appropriate.

catchPackExc :: IO () -> IO ()
catchPackExc io = io `catch` (\e -> putStrLn (show (e::PackException)))

expectException :: (Show a) => PackException -> IO a -> IO Bool
expectException exception action
    = do putStrLn ("expect exception:\n" ++ show exception)
         action >>= print
         return False
      `catch` \e -> do putStrLn ("Got: " ++ show e)
                       return (e == exception)

main :: IO ()
main = do putStrLn "Running all tests"
          args <- getArgs
          let n    = if (length args < 2) then 3 else read (args!!1)
              size = if null args then 128 else read (head args)::Int
          -- test data from arguments, avoiding over-optimisation
              arr, arr2, output :: A.Array Int Int
              arr  = A.array (0,127) [ (i,i) | i <- [0..127] ]
              output = A.amap (2*) arr
              arr2 = A.listArray (0,2*n-1) (take (2*n) (A.elems arr))
              cfg  = (output, arr2, n)
          (mapM_ (runIt cfg) mytests) `finally` (rmv testfile)

-- file used for all tests
testfile :: FilePath
testfile = "testfile"

type Config = (A.Array Int Int, A.Array Int Int, Int)

type MyTest = Config -> (String, IO Bool)

-- run a defined test
runIt :: Config -> MyTest -> IO ()
runIt cfg f
    = do putStrLn $ "Test: " ++ name ++ ": "
         result <- action
         putStrLn $ "Result: " ++ show result
         if not result then error "test failed!" else return ()
    where (name, action) = f cfg

-- all configured tests, see below
mytests :: [ MyTest ]
mytests = [ evalArray,  packArray, packThreadId, packMVar,
            unpackOther, unpackWrongType, unpackTruncated, unpackGarbled ]

evalArray :: MyTest
evalArray (output, _, n)
    = ("eval. array",
       do let out = show $ take n $ A.elems output
          putStrLn $ "Evaluated: " ++ out
          return (out == "[0,2,4]"))

packArray :: MyTest
packArray (output, arr2, n)
    = ("duplicating an array of 128 elements",
              do packet1 <- trySerialize output
                 putStrLn (take (3*80) (show packet1) ++ "...")
                 putStrLn "now unpacking (deserialize):"
                 copy <- deserialize packet1
                 putStrLn ("unpacked, now evaluate")
                 putStrLn (show copy)
                 return $
                    take (2*n) (A.elems copy) == A.elems (A.amap (2*) arr2)
             )

packThreadId :: MyTest
packThreadId _ = ("packing a thread ID (unsupported)",
                  do t <- myThreadId
                     expectException P_UNSUPPORTED $ trySerialize t
                 )
packMVar :: MyTest
packMVar _ = ("packing an MVar (should be cannotpack)",
              do m <- newEmptyMVar :: IO (MVar Integer)
                 expectException P_CANNOTPACK $ trySerialize m
             )

unpackOther :: MyTest
unpackOther _ = ("deserialise other binary's data (binary mismatch)",
                 expectException P_BinaryMismatch
                 (decodeFromFile "pack.old" :: IO (A.Array Int Int))
                )

unpackWrongType :: MyTest
unpackWrongType  (output, arr2, n)
    = ("deserialise wrong type from file (type mismatch)",
                   do encodeToFile testfile arr2
                      expectException P_TypeMismatch
                       (decodeFromFile testfile :: IO (A.Array Int Double))
                  )

unpackTruncated :: MyTest
unpackTruncated  (output, arr2, n)
    = ("deserialise truncated data. Expected: parse error",
       do encodeToFile testfile arr2
          blob <- B.readFile testfile
          B.writeFile testfile (B.take 50 blob)
               -- take more than FingerPrint (4 x Word64)
          expectException P_ParseError
              (decodeFromFile testfile :: IO (A.Array Int Int))
      )

unpackGarbled :: MyTest
unpackGarbled (output, arr2, n)
    = ("deserialise garbled data. Expected: garbled data",
       do encodeToFile testfile arr2
          blob <- B.readFile testfile
          B.writeFile testfile (tamperWith blob)
          expectException P_GARBLED
           (decodeFromFile testfile :: IO (A.Array Int Int))
      )

tamperWith :: B.ByteString -> B.ByteString
tamperWith b = B.concat [b1, B.pack [11,11], B.drop 2 b2]
    where n       = B.length b
          (b1,b2) = B.splitAt (n - 10) b
-- do not touch the FingerPrints (4 x Word64)

-- file cleanup, catching all exceptions
rmv :: FilePath -> IO ()
rmv f = (removeFile f) `catch` (\e -> print (e::SomeException))


-- need a time-wasting function which allocates...
nfib :: Integer -> Integer
nfib 0 = 1
nfib 1 = 1
nfib n = let n1 = nfib (n-1)
             n2 = nfib (n-2)
         in 1 + 2*n1 + n2 - n1