diff --git a/System/IO/MMap.hs b/System/IO/MMap.hs --- a/System/IO/MMap.hs +++ b/System/IO/MMap.hs @@ -52,6 +52,8 @@ import qualified Data.ByteString as BS (ByteString) import qualified Data.ByteString.Lazy as BSL (ByteString,fromChunks) +import Debug.Trace + -- TODO: -- - support native characters (Unicode) in FilePath -- - support externally given HANDLEs and FDs @@ -162,7 +164,7 @@ -- permissions, region parameter specifies -- size, if file size is lower it will be -- extended with zeros - deriving (Eq,Ord,Enum) + deriving (Eq,Ord,Enum,Show,Read) sanitizeFileRegion :: (Integral a,Bounded a) => String -> ForeignPtr () -> Mode -> Maybe (Int64,a) -> IO (Int64,a) sanitizeFileRegion filepath handle ReadWriteEx (Just region) @@ -223,9 +225,9 @@ where mmap handle = do (offset,size) <- sanitizeFileRegion filepath handle mode offsetsize - let align = offset `mod` fromIntegral c_system_io_granularity + let align = offset `mod` fromIntegral c_system_io_granularity let offsetraw = offset - align - let sizeraw = size + fromIntegral align + let sizeraw = size + fromIntegral align ptr <- withForeignPtr handle $ \handle -> c_system_io_mmap_mmap handle (fromIntegral $ fromEnum mode) (fromIntegral offsetraw) (fromIntegral sizeraw) @@ -282,21 +284,23 @@ -> IO [(ForeignPtr a,Int,Int)] -- ^ (ptr,offset,size) mmapFileForeignPtrLazy filepath mode offsetsize = do checkModeRegion filepath mode offsetsize - bracket (mmapFileOpen filepath mode) - (finalizeForeignPtr) mmap + bracketOnError (mmapFileOpen filepath mode) + (finalizeForeignPtr) mmap where mmap handle = do (offset,size) <- sanitizeFileRegion filepath handle mode offsetsize return $ map (mapChunk handle) (chunks offset size) + -- FIXME: might be we need NOINLINE pragma here, investigate later mapChunk handle (offset,size) = unsafePerformIO $ withForeignPtr handle $ \handle -> do - let align = offset `mod` fromIntegral c_system_io_granularity + let align = offset `mod` fromIntegral c_system_io_granularity offsetraw = offset - align - sizeraw = size + fromIntegral align + sizeraw = size + fromIntegral align ptr <- c_system_io_mmap_mmap handle (fromIntegral $ fromEnum mode) (fromIntegral offsetraw) (fromIntegral sizeraw) when (ptr == nullPtr) $ - throwErrno $ "mmap of '" ++ filepath ++ "' failed" + throwErrno $ "lazy mmap of '" ++ filepath ++ + "' chunk(" ++ show offset ++ "," ++ show size ++") failed" let rawsizeptr = castIntToPtr sizeraw foreignptr <- newForeignPtrEnv c_system_io_mmap_munmap_funptr rawsizeptr ptr return (foreignptr,fromIntegral offset,size) @@ -305,7 +309,7 @@ chunks offset 0 = [] chunks offset size | size <= fromIntegral chunkSize = [(offset,fromIntegral size)] | otherwise = let offset2 = ((offset + chunkSize + chunkSize - 1) `div` chunkSize) * chunkSize - size2 = offset2 - offset + size2 = offset2 - offset in (offset,fromIntegral size2) : chunks offset2 (size-size2) -- | Maps region of file and returns it as 'BSL.ByteString'. File is diff --git a/mmap.cabal b/mmap.cabal --- a/mmap.cabal +++ b/mmap.cabal @@ -1,5 +1,5 @@ Name: mmap -Version: 0.5.2 +Version: 0.5.3 Stability: alpha License: BSD3 License-File: LICENSE @@ -40,12 +40,14 @@ else Buildable: False Build-depends: base<5, bytestring, HUnit, directory - Extensions: ForeignFunctionInterface, ScopedTypeVariables + Extensions: ForeignFunctionInterface, ScopedTypeVariables, CPP Hs-source-dirs: . CC-options: -Wall -D_DEBUG Include-dirs: cbits if os(mingw32) + cpp-options: -DWINDOWS C-sources: cbits/win32.c + Build-depends: Win32 else C-sources: cbits/posix.c diff --git a/tests/mmaptest.hs b/tests/mmaptest.hs --- a/tests/mmaptest.hs +++ b/tests/mmaptest.hs @@ -1,4 +1,4 @@ - +{-# LANGUAGE ForeignFunctionInterface, CPP #-} module Main where @@ -16,40 +16,45 @@ import System.Directory import Foreign.C.Types (CInt,CLLong) import Control.Monad - -{- - -Things to test: - -1. Opening an existing file. -2. Opening non exisitng file. -3. Opening a file we don't have rights to. -4. Opening read only file for writting. -5. Opening zero lenght file read only -6. Opening zero lenght file read write -7. Extending file size. -8. MMaping only part of file. -9. MMaping negative offset. -10. Mmaping beyond end of file without extending -11. Mmaping 3GB file. -12. Mmaping 5GB file under 32bit (fail) -13. Mmaping 5GB file under 32bit (success) - --} +import System.IO +#ifdef WINDOWS +import qualified System.Win32.File as W +#endif ignoreExceptions doit = (doit >> return ()) `catch` (\e -> return ()) foreign import ccall unsafe "HsMmap.h system_io_mmap_counters" c_system_io_counters :: IO CInt +removeFileDelayed :: FilePath -> IO () +#ifdef WINDOWS +removeFileDelayed filepath = do + h <- W.createFile filepath + W.dELETE + W.fILE_SHARE_NONE + Nothing + W.oPEN_ALWAYS + W.fILE_FLAG_DELETE_ON_CLOSE + Nothing + W.closeHandle h +#else +removeFileDelayed filepath = removeFile filepath +#endif content = BSC.pack "Memory mapping of files for POSIX and Windows" +contentLazy = BSL.fromChunks [content] test_normal_readonly = do BSC.writeFile "test_normal.bin" content bs <- mmapFileByteString "test_normal.bin" Nothing bs @?= content +test_normal_readonly_lazy = do + let filename = "test_normalQ.bin" + BSC.writeFile filename content + bs <- mmapFileByteStringLazy filename Nothing + bs @?= contentLazy + test_normal_readonly_zero_length = do BSC.writeFile "test_zerolength.bin" BSC.empty bs <- mmapFileByteString "test_zerolength.bin" Nothing @@ -63,9 +68,15 @@ test_no_permission_readonly = do let filename = "test_nopermission.bin" - ignoreExceptions $ setPermissions filename (Permissions {readable = True, writable = True, executable = True, searchable = True}) + ignoreExceptions $ setPermissions filename (Permissions {readable = True, + writable = True, + executable = True, + searchable = True}) BSC.writeFile filename content - setPermissions filename (Permissions {readable = False, writable = False, executable = False, searchable = False}) + setPermissions filename (Permissions {readable = False, + writable = False, + executable = False, + searchable = False}) Permissions {readable = readable} <- getPermissions filename -- no way to clear read flag under Windows, skip the test if not readable @@ -102,6 +113,13 @@ let exp = BSC.empty bs @?= exp +test_normal_offset_size_zero_readonly_lazy = do + let filename = "test_normal6x.bin" + BSC.writeFile filename content + bs <- mmapFileByteStringLazy filename (Just (5,0)) + let exp = BSL.empty + bs @?= exp + test_normal_offset_beyond_eof_readonly = do let filename = "test_normal9.bin" BSC.writeFile filename content @@ -109,6 +127,14 @@ mmapFileByteString filename (Just (1000,5)) assertFailure "Should throw exception" +test_normal_offset_beyond_eof_readonly_lazy = do + -- although lazy, should throw exception + let filename = "test_normal9.bin" + BSC.writeFile filename content + ignoreExceptions $ do + mmapFileByteStringLazy filename (Just (1000,5)) + assertFailure "Should throw exception" + test_normal_offset_plus_size_beyond_eof_readonly = do let filename = "test_normal7.bin" BSC.writeFile filename content @@ -124,6 +150,24 @@ bs <- BSC.unsafePackCStringLen (castPtr ptr,size) bs @?= BSC.take 5000 (BSC.drop 4 (content `BSC.append` BSC.replicate 10000 '\0')) +test_delete_while_mmapped = do + let filename = "test_normalU.bin" + BSC.writeFile filename content + mmapWithFilePtr filename ReadOnly Nothing $ \(ptr,size) -> do + removeFileDelayed filename + bs <- BSC.unsafePackCStringLen (castPtr ptr,size) + bs @?= content + v <- doesFileExist filename + False @=? v + +test_readwriteex_lazy_make_a_touch = do + let filename = "test_normal8.bin" + BSC.writeFile filename content + let threegb = 3*1000*1000*1000 + ignore <- mmapFileForeignPtrLazy filename ReadWriteEx (Just (4,threegb)) + let size = sum (Prelude.map (\(_,_,s) -> s) ignore) + size @?= fromIntegral threegb + test_create_offset_plus_size_readwriteex = do let filename = "test_normal9.bin" ignoreExceptions $ removeFile filename @@ -154,23 +198,48 @@ counters <- c_system_io_counters return (counters @?= 0) -alltests = [ "Normal read only mmap" ~: test_normal_readonly - , "Zero length file mmap" ~: test_normal_readonly_zero_length - , "File does not exist" ~: test_non_existing_readonly - , "No permission to read file" ~: test_no_permission_readonly - , "Signal error when negative offset given" ~: test_normal_negative_offset_readonly - , "Signal error when negative size given" ~: test_normal_negative_size_readonly - , "Test if we can cut part of file" ~: test_normal_offset_size_readonly - , "Test if we can cut zero length part of file" ~: test_normal_offset_size_zero_readonly - , "Should throw error if mmaping readonly beyond end of file" ~: test_normal_offset_beyond_eof_readonly - , "Should throw error if mmaping readonly with size beyond end of file" ~: test_normal_offset_plus_size_beyond_eof_readonly - , "Should ReadWriteEx mmap existing file and resize" ~: test_normal_offset_plus_size_beyond_eof_readwriteex - , "Should ReadWriteEx mmap new file and resize" ~: test_create_offset_plus_size_readwriteex - , "ReadWriteEx must have range specified" ~: test_create_nothing_readwriteex_should_throw - , "Report error in file creation" ~: test_create_readwriteex_no_way +alltests = [ "Normal read only mmap" ~: + test_normal_readonly + , "Normal read only mmap lazy" ~: + test_normal_readonly_lazy + , "Zero length file mmap" ~: + test_normal_readonly_zero_length + , "File does not exist" ~: + test_non_existing_readonly + , "No permission to read file" ~: + test_no_permission_readonly + , "Signal error when negative offset given" ~: + test_normal_negative_offset_readonly + , "Signal error when negative size given" ~: + test_normal_negative_size_readonly + , "Test if we can cut part of file" ~: + test_normal_offset_size_readonly + , "Test if we can cut zero length part of file" ~: + test_normal_offset_size_zero_readonly + , "Test if we can cut zero length part of file lazy" ~: + test_normal_offset_size_zero_readonly_lazy + , "Should throw error if mmaping readonly beyond end of file" ~: + test_normal_offset_beyond_eof_readonly + , "Should throw error if mmaping readonly beyond end of file" ~: + test_normal_offset_beyond_eof_readonly_lazy + , "Should throw error if mmaping readonly with size beyond end of file lazy" ~: + test_normal_offset_plus_size_beyond_eof_readonly + , "Should ReadWriteEx mmap existing file and resize" ~: + test_normal_offset_plus_size_beyond_eof_readwriteex + , "Should ReadWriteEx mmap new file and resize" ~: + test_create_offset_plus_size_readwriteex + , "ReadWriteEx must have range specified" ~: + test_create_nothing_readwriteex_should_throw + , "Report error in file creation" ~: + test_create_readwriteex_no_way + , "ReadWriteEx in lazy should extend file beyond 3GB when mapped in" ~: + test_readwriteex_lazy_make_a_touch + , "Remove file while mmaped" ~: + test_delete_while_mmapped -- insert tests above this line - , "Counters should be zero" ~: test_counters_zero + , "Counters should be zero" ~: + test_counters_zero ] main = do