← Back to branch summary

~ubuntu-branches/ubuntu/precise/ghc/precise

« back to all changes in this revision

Viewing changes to libraries/Win32/System/Win32/FileMapping.hsc

  • Committer: Bazaar Package Importer
  • Author(s): Joachim Breitner
  • Date: 2011-01-17 12:49:24 UTC
  • Revision ID: james.westby@ubuntu.com-20110117124924-do1pym1jlf5o636m
Tags: upstream-7.0.1
Import upstream version 7.0.1

Show diffs side-by-side

added added

removed removed

Lines of Context:
libraries/Win32/System/Win32/FileMapping.hsc
 
1
-----------------------------------------------------------------------------
 
2
-- |
 
3
-- Module      :  System.Win32.FileMapping
 
4
-- Copyright   :  (c) Esa Ilari Vuokko, 2006
 
5
-- License     :  BSD-style (see the file LICENSE)
 
6
--
 
7
-- Maintainer  :  Esa Ilari Vuokko <ei@vuokko.info>
 
8
-- Stability   :  provisional
 
9
-- Portability :  portable
 
10
--
 
11
-- A collection of FFI declarations for interfacing with Win32 mapped files.
 
12
--
 
13
-----------------------------------------------------------------------------
 
14
module System.Win32.FileMapping where
 
15
 
 
16
import System.Win32.Types   ( HANDLE, DWORD, BOOL, SIZE_T, LPCTSTR, withTString
 
17
                            , failIf, failIfNull, DDWORD, ddwordToDwords
 
18
                            , iNVALID_HANDLE_VALUE )
 
19
import System.Win32.Mem
 
20
import System.Win32.File
 
21
import System.Win32.Info
 
22
 
 
23
import Control.Exception        ( mask_, bracket )
 
24
import Data.ByteString          ( ByteString )
 
25
import Data.ByteString.Internal ( fromForeignPtr )
 
26
import Foreign                  ( Ptr, nullPtr, plusPtr, maybeWith, FunPtr
 
27
                                , ForeignPtr, newForeignPtr )
 
28
 
 
29
#include "windows.h"
 
30
 
 
31
---------------------------------------------------------------------------
 
32
-- Derived functions
 
33
---------------------------------------------------------------------------
 
34
 
 
35
-- | Maps file fully and returns ForeignPtr and length of the mapped area.
 
36
-- The mapped file is opened read-only and shared reading.
 
37
mapFile :: FilePath -> IO (ForeignPtr a, Int)
 
38
mapFile path = do
 
39
    bracket
 
40
        (createFile path gENERIC_READ fILE_SHARE_READ Nothing oPEN_EXISTING fILE_ATTRIBUTE_NORMAL Nothing)
 
41
        (closeHandle)
 
42
        $ \fh -> bracket
 
43
            (createFileMapping (Just fh) pAGE_READONLY 0 Nothing)
 
44
            (closeHandle)
 
45
            $ \fm -> do
 
46
                fi <- getFileInformationByHandle fh
 
47
                fp <- mask_ $ do
 
48
                    ptr <- mapViewOfFile fm fILE_MAP_READ 0 0
 
49
                    newForeignPtr c_UnmapViewOfFileFinaliser ptr
 
50
                return (fp, fromIntegral $ bhfiSize fi)
 
51
 
 
52
-- | As mapFile, but returns ByteString
 
53
mapFileBs :: FilePath -> IO ByteString
 
54
mapFileBs p = do
 
55
    (fp,i) <- mapFile p
 
56
    return $ fromForeignPtr fp 0 i
 
57
 
 
58
data MappedObject = MappedObject HANDLE HANDLE FileMapAccess
 
59
 
 
60
-- | Opens an existing file and creates mapping object to it.
 
61
withMappedFile
 
62
    :: FilePath             -- ^ Path
 
63
    -> Bool                 -- ^ Write? (False = read-only)
 
64
    -> Maybe Bool           -- ^ Sharing mode, no sharing, share read, share read+write
 
65
    -> (Integer -> MappedObject -> IO a) -- ^ Action
 
66
    -> IO a
 
67
withMappedFile path write share act =
 
68
    bracket
 
69
        (createFile path access share' Nothing oPEN_EXISTING fILE_ATTRIBUTE_NORMAL Nothing)
 
70
        (closeHandle)
 
71
        $ \fh -> bracket
 
72
            (createFileMapping (Just fh) page 0 Nothing)
 
73
            (closeHandle)
 
74
            $ \fm -> do
 
75
                bhfi <- getFileInformationByHandle fh
 
76
                act (fromIntegral $ bhfiSize bhfi) (MappedObject fh fm mapaccess)
 
77
    where
 
78
        access    = if write then gENERIC_READ+gENERIC_WRITE else gENERIC_READ
 
79
        page      = if write then pAGE_READWRITE else pAGE_READONLY
 
80
        mapaccess = if write then fILE_MAP_ALL_ACCESS else fILE_MAP_READ
 
81
        share' = case share of
 
82
            Nothing     -> fILE_SHARE_NONE
 
83
            Just False  -> fILE_SHARE_READ
 
84
            Just True   -> fILE_SHARE_READ + fILE_SHARE_WRITE
 
85
 
 
86
-- | Maps area into memory.
 
87
withMappedArea
 
88
    :: MappedObject     -- ^ Mapped object, from withMappedFile
 
89
    -> Integer          -- ^ Position in file
 
90
    -> Int              -- ^ Size of mapped area
 
91
    -> (Ptr a -> IO b)  -- ^ Action
 
92
    -> IO b
 
93
withMappedArea (MappedObject _ mh access) pos size act = do
 
94
    si <- getSystemInfo
 
95
    let gran = fromIntegral $ siAllocationGranularity si
 
96
        (blocks, offset) = divMod pos gran
 
97
        start = blocks*gran
 
98
        size' = fromIntegral $ size + fromIntegral (pos - start)
 
99
    bracket
 
100
        (mapViewOfFileEx mh access (fromIntegral start) size' nullPtr)
 
101
        (unmapViewOfFile)
 
102
        (act . flip plusPtr (fromIntegral offset))
 
103
 
 
104
---------------------------------------------------------------------------
 
105
-- Enums
 
106
---------------------------------------------------------------------------
 
107
type ProtectSectionFlags = DWORD
 
108
#{enum ProtectSectionFlags,
 
109
    , sEC_COMMIT    = SEC_COMMIT
 
110
    , sEC_IMAGE     = SEC_IMAGE
 
111
    , sEC_NOCACHE   = SEC_NOCACHE
 
112
    , sEC_RESERVE   = SEC_RESERVE
 
113
    }
 
114
type FileMapAccess = DWORD
 
115
#{enum FileMapAccess,
 
116
    , fILE_MAP_ALL_ACCESS   = FILE_MAP_ALL_ACCESS
 
117
    , fILE_MAP_COPY         = FILE_MAP_COPY
 
118
    , fILE_MAP_READ         = FILE_MAP_READ
 
119
    , fILE_MAP_WRITE        = FILE_MAP_WRITE
 
120
    }
 
121
 
 
122
---------------------------------------------------------------------------
 
123
-- API in Haskell
 
124
---------------------------------------------------------------------------
 
125
createFileMapping :: Maybe HANDLE -> ProtectFlags -> DDWORD -> Maybe String -> IO HANDLE
 
126
createFileMapping mh flags mosize name =
 
127
    maybeWith withTString name $ \name ->
 
128
        failIf (==nullPtr) "createFileMapping: CreateFileMapping" $ c_CreateFileMapping handle nullPtr flags moshi moslow name
 
129
    where
 
130
        (moshi,moslow) = ddwordToDwords mosize
 
131
        handle = maybe iNVALID_HANDLE_VALUE id mh
 
132
 
 
133
openFileMapping :: FileMapAccess -> BOOL -> Maybe String -> IO HANDLE
 
134
openFileMapping access inherit name =
 
135
    maybeWith withTString name $ \name ->
 
136
        failIf (==nullPtr) "openFileMapping: OpenFileMapping" $
 
137
            c_OpenFileMapping access inherit name
 
138
 
 
139
mapViewOfFileEx :: HANDLE -> FileMapAccess -> DDWORD -> SIZE_T -> Ptr a -> IO (Ptr b)
 
140
mapViewOfFileEx h access offset size base = 
 
141
    failIfNull "mapViewOfFile(Ex): c_MapViewOfFileEx" $
 
142
        c_MapViewOfFileEx h access ohi olow size base
 
143
    where
 
144
        (ohi,olow) = ddwordToDwords offset
 
145
 
 
146
mapViewOfFile :: HANDLE -> FileMapAccess -> DDWORD -> SIZE_T -> IO (Ptr a)
 
147
mapViewOfFile h a o s = mapViewOfFileEx h a o s nullPtr
 
148
 
 
149
unmapViewOfFile :: Ptr a -> IO ()
 
150
unmapViewOfFile v = c_UnmapViewOfFile v >> return ()
 
151
 
 
152
---------------------------------------------------------------------------
 
153
-- Imports
 
154
---------------------------------------------------------------------------
 
155
foreign import stdcall "windows.h OpenFileMappingW"
 
156
    c_OpenFileMapping :: DWORD -> BOOL -> LPCTSTR -> IO HANDLE
 
157
 
 
158
foreign import stdcall "windows.h CreateFileMappingW"
 
159
    c_CreateFileMapping :: HANDLE -> Ptr () -> DWORD -> DWORD -> DWORD -> LPCTSTR -> IO HANDLE 
 
160
 
 
161
foreign import stdcall "windows.h MapViewOfFileEx"
 
162
    c_MapViewOfFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> SIZE_T -> Ptr a -> IO (Ptr b)
 
163
 
 
164
foreign import stdcall "windows.h UnmapViewOfFile"
 
165
    c_UnmapViewOfFile :: Ptr a -> IO BOOL
 
166
 
 
167
{-# CFILES cbits/HsWin32.c #-}
 
168
foreign import ccall "HsWin32.h &UnmapViewOfFileFinaliser"
 
169
    c_UnmapViewOfFileFinaliser :: FunPtr (Ptr a -> IO ())