summaryrefslogtreecommitdiff
path: root/libraries/base/GHC/Windows.hs
blob: 2cee2d89088177421a3b430b101d746b4f1aafdf (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE NoImplicitPrelude #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.Windows
-- Copyright   :  (c) The University of Glasgow, 2009
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  internal
-- Portability :  non-portable
--
-- Windows functionality used by several modules.
--
-- ToDo: this just duplicates part of System.Win32.Types, which isn't
-- available yet.  We should move some Win32 functionality down here,
-- maybe as part of the grand reorganisation of the base package...
--
-----------------------------------------------------------------------------

module GHC.Windows (
        -- * Types
        BOOL,
        LPBOOL,
        BYTE,
        DWORD,
        DDWORD,
        UINT,
        ULONG,
        ErrCode,
        HANDLE,
        LPWSTR,
        LPTSTR,
        LPCTSTR,
        LPVOID,
        LPDWORD,
        LPSTR,
        LPCSTR,
        LPCWSTR,
        WORD,
        UCHAR,
        NTSTATUS,

        -- * Constants
        iNFINITE,
        iNVALID_HANDLE_VALUE,

        -- * System errors
        throwGetLastError,
        failWith,
        getLastError,
        getErrorMessage,
        errCodeToIOError,

        -- ** Guards for system calls that might fail
        failIf,
        failIf_,
        failIfNull,
        failIfZero,
        failIfFalse_,
        failUnlessSuccess,
        failUnlessSuccessOr,

        -- ** Mapping system errors to errno
        -- $errno
        c_maperrno,
        c_maperrno_func,

        -- * Misc
        ddwordToDwords,
        dwordsToDdword,
        nullHANDLE,
    ) where

import Data.Bits (finiteBitSize, shiftL, shiftR, (.|.), (.&.))
import Data.Char
import Data.List (dropWhileEnd)
import Data.Maybe
import Data.Word
import Data.Int
import Foreign.C.Error
import Foreign.C.String
import Foreign.C.Types
import Foreign.Ptr
import GHC.Base
import GHC.Enum (maxBound)
import GHC.IO
import GHC.Num
import GHC.Real (fromIntegral)
import System.IO.Error

import qualified Numeric

#include "windows_cconv.h"

type BOOL     = Bool
type LPBOOL   = Ptr BOOL
type BYTE     = Word8
type DWORD    = Word32
type UINT     = Word32
type ULONG    = Word32
type ErrCode  = DWORD
type HANDLE   = Ptr ()
type LPWSTR   = Ptr CWchar
type LPCTSTR  = LPTSTR
type LPVOID   = Ptr ()
type LPDWORD  = Ptr DWORD
type LPSTR    = Ptr CChar
type LPCSTR   = LPSTR
type LPCWSTR  = LPWSTR
type WORD     = Word16
type UCHAR    = Word8
type NTSTATUS = Int32

nullHANDLE :: HANDLE
nullHANDLE = nullPtr

-- Not really a basic type, but used in many places
type DDWORD        = Word64

-- | Be careful with this.  LPTSTR can mean either WCHAR* or CHAR*, depending
-- on whether the UNICODE macro is defined in the corresponding C code.
-- Consider using LPWSTR instead.
type LPTSTR = LPWSTR

iNFINITE :: DWORD
iNFINITE = 0xFFFFFFFF -- urgh

iNVALID_HANDLE_VALUE :: HANDLE
iNVALID_HANDLE_VALUE = wordPtrToPtr (-1)

-- | Get the last system error, and throw it as an 'IOError' exception.
throwGetLastError :: String -> IO a
throwGetLastError where_from =
    getLastError >>= failWith where_from

-- | Convert a Windows error code to an exception, then throw it.
failWith :: String -> ErrCode -> IO a
failWith fn_name err_code =
    errCodeToIOError fn_name err_code >>= throwIO

-- | Convert a Windows error code to an exception.
errCodeToIOError :: String -> ErrCode -> IO IOError
errCodeToIOError fn_name err_code = do
    msg <- getErrorMessage err_code

    -- turn GetLastError() into errno, which errnoToIOError knows
    -- how to convert to an IOException we can throw.
    -- XXX we should really do this directly.
    let errno = c_maperrno_func err_code

    let msg' = dropWhileEnd isSpace msg -- drop trailing \n
        ioerror = errnoToIOError fn_name errno Nothing Nothing
                    `ioeSetErrorString` msg'
    return ioerror

-- | Get a string describing a Windows error code.  This uses the
-- @FormatMessage@ system call.
getErrorMessage :: ErrCode -> IO String
getErrorMessage err_code =
    mask_ $ do
        c_msg <- c_getErrorMessage err_code
        if c_msg == nullPtr
          then return $ "Error 0x" ++ Numeric.showHex err_code ""
          else do msg <- peekCWString c_msg
                  -- We ignore failure of freeing c_msg, given we're already failing
                  _ <- localFree c_msg
                  return msg

failIf :: (a -> Bool) -> String -> IO a -> IO a
failIf p wh act = do
    v <- act
    if p v then throwGetLastError wh else return v

failIf_ :: (a -> Bool) -> String -> IO a -> IO ()
failIf_ p wh act = do
    v <- act
    if p v then throwGetLastError wh else return ()

failIfNull :: String -> IO (Ptr a) -> IO (Ptr a)
failIfNull = failIf (== nullPtr)

failIfZero :: (Eq a, Num a) => String -> IO a -> IO a
failIfZero = failIf (== 0)

failIfFalse_ :: String -> IO Bool -> IO ()
failIfFalse_ = failIf_ not

failUnlessSuccess :: String -> IO ErrCode -> IO ()
failUnlessSuccess fn_name act = do
    r <- act
    if r == 0 then return () else failWith fn_name r

failUnlessSuccessOr :: ErrCode -> String -> IO ErrCode -> IO Bool
failUnlessSuccessOr val fn_name act = do
    r <- act
    if r == 0 then return False
        else if r == val then return True
        else failWith fn_name r

-- $errno
--
-- On Windows, @errno@ is defined by msvcrt.dll for compatibility with other
-- systems, and is distinct from the system error as returned
-- by @GetLastError@.

-- | Map the last system error to an errno value, and assign it to @errno@.
foreign import ccall unsafe "maperrno"             -- in Win32Utils.c
   c_maperrno :: IO ()

-- | Pure function variant of 'c_maperrno' that does not call @GetLastError@
-- or modify @errno@.
foreign import ccall unsafe "maperrno_func"        -- in Win32Utils.c
   c_maperrno_func :: ErrCode -> Errno

foreign import ccall unsafe "base_getErrorMessage" -- in Win32Utils.c
    c_getErrorMessage :: DWORD -> IO LPWSTR

foreign import WINDOWS_CCONV unsafe "windows.h LocalFree"
    localFree :: Ptr a -> IO (Ptr a)

-- | Get the last system error produced in the current thread.
foreign import WINDOWS_CCONV unsafe "windows.h GetLastError"
    getLastError :: IO ErrCode

----------------------------------------------------------------
-- Misc helpers
----------------------------------------------------------------

ddwordToDwords :: DDWORD -> (DWORD,DWORD)
ddwordToDwords n =
        (fromIntegral (n `shiftR` finiteBitSize (undefined :: DWORD))
        ,fromIntegral (n .&. fromIntegral (maxBound :: DWORD)))

dwordsToDdword:: (DWORD,DWORD) -> DDWORD
dwordsToDdword (hi,low) = (fromIntegral low) .|. (fromIntegral hi `shiftL` finiteBitSize hi)