winio (empty) → 0.1
raw patch · 7 files changed
+924/−0 lines, 7 filesdep +basedep +bytestringdep +extensible-exceptionssetup-changed
Dependencies added: base, bytestring, extensible-exceptions, network, winerror
Files
- LICENSE +22/−0
- Network/Socket/ByteString/Compat.hs +31/−0
- Network/Socket/Compat.hs +29/−0
- Setup.hs +4/−0
- System/Windows/IO.hs +504/−0
- cbits/HsWinIO.c +312/−0
- winio.cabal +22/−0
+ LICENSE view
@@ -0,0 +1,22 @@+Copyright 2007-2009 Felix Martini. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + 1. Redistributions of source code must retain the above copyright notice + this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE.
+ Network/Socket/ByteString/Compat.hs view
@@ -0,0 +1,31 @@+{- | + Module : Network.Socket.ByteString.Compat + Copyright : 2009 Felix Martini + License : BSD-style (see LICENSE for license terms) + + Maintainer : felix@felixmartini.com + Stability : Experimental + + Functions in this module are compatible with functions in the + Network.Socket.ByteString module from the network-bytestring + package but use I/O functions from the winio package. +-} + +module Network.Socket.ByteString.Compat where + +import Data.ByteString (ByteString) +import Network.Socket (Socket, SockAddr) + +import qualified System.Windows.IO as IO + +send :: Socket -> ByteString -> IO Int +send = IO.sendBS + +sendTo :: Socket -> ByteString -> SockAddr -> IO Int +sendTo = IO.sendToBS + +recv :: Socket -> Int -> IO ByteString +recv = IO.recvBS + +recvFrom :: Socket -> Int -> IO (ByteString, SockAddr) +recvFrom = IO.recvFromBS
+ Network/Socket/Compat.hs view
@@ -0,0 +1,29 @@+{- | + Module : Network.Socket.Compat + Copyright : 2009 Felix Martini + License : BSD-style (see LICENSE for license terms) + + Maintainer : felix@felixmartini.com + Stability : Experimental + + Functions in this module are compatible with functions in the + Network.Socket module but use I/O functions from the winio package. +-} + +module Network.Socket.Compat where + +import Network.Socket (Family, ProtocolNumber, Socket, SocketType, SockAddr) +import qualified Network.Socket as Socket +import qualified System.Windows.IO as IO + +socket :: Family -> SocketType -> ProtocolNumber -> IO Socket +socket fam sock_type proto_num = do + sock <- Socket.socket fam sock_type proto_num + IO.associateSocketWithPort sock + return sock + +accept :: Socket -> IO (Socket, SockAddr) +accept sock = do + (client_sock, client_addr) <- Socket.accept sock + IO.associateSocketWithPort client_sock + return (client_sock, client_addr)
+ Setup.hs view
@@ -0,0 +1,4 @@+#!/usr/bin/env runhaskell + +import Distribution.Simple +main = defaultMain
+ System/Windows/IO.hs view
@@ -0,0 +1,504 @@+{-# LANGUAGE ForeignFunctionInterface #-} +{- | + Module : System.Windows.IO + Copyright : 2007-2009 Felix Martini + License : BSD-style (see LICENSE for license terms) + + Maintainer : felix@felixmartini.com + Stability : Experimental + + Low-level I/O functions using the Windows API. +-} + +module System.Windows.IO + ( HANDLE + , ShareMode(..) + + , openFile + , openTempFile + , getFileSize + , setFileSize + , getPosition + , setPosition + + , associateWithPort + , associateSocketWithPort + + , read + , write + , send + , sendTo + , recv + , recvFrom + , readBS + , writeBS + , sendBS + , sendToBS + , recvBS + , recvFromBS + + , closeHandle + ) where + +import Prelude hiding (read) + +import Control.Concurrent (ThreadId) +import Control.Concurrent.MVar (MVar) +import Control.Monad (when) +import Data.Bits ((.|.)) +import Data.ByteString.Internal (ByteString(..)) +import Data.Int (Int64) +import Data.IORef (IORef) +import Data.Word (Word8, Word32, Word64) +import Foreign.C.String (CWString) +import Foreign.C.Types (CInt) +import Foreign.Ptr (Ptr) +import Foreign.StablePtr (StablePtr) +import Network.Socket (Socket(..), SockAddr) +import System.IO (IOMode(..), SeekMode(..), FilePath) +import System.IO.Unsafe (unsafePerformIO) +import System.Windows.Error + +import qualified Control.Concurrent as Concur +import qualified Control.Concurrent.MVar as MVar +import qualified Control.Exception.Extensible as Ex +import qualified Data.ByteString.Internal as B +import qualified Data.IORef as IORef +import qualified Network.Socket as Socket +import qualified Network.Socket.Internal as Socket +import qualified Foreign.C.String as CString +import qualified Foreign.Ptr as Ptr +import qualified Foreign.ForeignPtr as ForeignPtr +import qualified Foreign.Marshal as Marshal +import qualified Foreign.StablePtr as StablePtr +import qualified Foreign.Storable as Storable +import qualified System.IO.Error as IOErr + +-- ------------- +-- General types + +-- | A Windows handle. +type HANDLE = Ptr () + +-- | File share mode. Determines if other processes can access the +-- open file. +data ShareMode = ShareRead + | ShareWrite + | ShareReadWrite + | NotShared + deriving (Show) + +-- --------------------- +-- Windows API constants + +-- File pointer +fileBegin = 0 :: Word32 +fileCurrent = 1 :: Word32 +fileEnd = 2 :: Word32 + +-- Access rights +genericRead = 0x80000000 :: Word32 +genericWrite = 0x40000000 :: Word32 +genericExecute = 0x20000000 :: Word32 +genericAll = 0x10000000 :: Word32 +fileAppendData = 0x00000004 :: Word32 + +-- Share modes +fileShareRead = 0x00000001 :: Word32 +fileShareWrite = 0x00000002 :: Word32 +fileShareDelete = 0x00000004 :: Word32 + +-- Attributes and flags +fileAttributeReadonly = 0x00000001 :: Word32 +fileAttributeNormal = 0x00000080 :: Word32 +fileAttributeTemporary = 0x00000100 :: Word32 +fileFlagOverlapped = 0x40000000 :: Word32 + +-- Creation disposition +createNew = 1 :: Word32 +createAlways = 2 :: Word32 +openExisting = 3 :: Word32 +openAlways = 4 :: Word32 +truncateExisting = 5 :: Word32 + +-- Infinite timeout +infinite :: Word32 +infinite = 0xFFFFFFFF + +-- -------------- +-- File functions + +-- | Open a file. The share mode determines if other processes can +-- access the open file. +openFile :: FilePath -> IOMode -> ShareMode -> IO HANDLE +openFile filepath iomode sharemode = do + let (access, create) = + case iomode of + ReadMode -> (genericRead, openExisting) + WriteMode -> (genericWrite, createAlways) + ReadWriteMode -> (genericRead .|. genericWrite, openAlways) + AppendMode -> (fileAppendData, openAlways) + let share = + case sharemode of + ShareRead -> fileShareRead + ShareWrite -> fileShareWrite + ShareReadWrite -> fileShareRead .|. fileShareWrite + NotShared -> 0 + hdl <- CString.withCWString filepath $ \fp -> + throwWinErrorIfInvalidHandle $ + c_CreateFile fp + access + share + Ptr.nullPtr + create + fileFlagOverlapped + Ptr.nullPtr + associateWithPort hdl + return hdl + +-- | Get the file size. +getFileSize :: HANDLE -> IO Int64 +getFileSize hdl = Marshal.alloca $ \s -> do + throwWinErrorIfFalse $ c_GetFileSize hdl s + Storable.peek s + +-- | Set a new file size. +setFileSize :: HANDLE -> Int64 -> IO () +setFileSize hdl s = do + fp <- getPosition hdl + setPosition hdl s AbsoluteSeek + throwWinErrorIfFalse $ c_SetEndOfFile hdl + setPosition hdl fp AbsoluteSeek + +-- | Get the current file position. +getPosition :: HANDLE -> IO Int64 +getPosition hdl = Marshal.alloca $ \pos -> do + throwWinErrorIfFalse $ c_GetFilePointer hdl pos + Storable.peek pos + +-- | Set a new file position. +setPosition :: HANDLE -> Int64 -> SeekMode -> IO () +setPosition hdl offset mode = do + let method = case mode of + AbsoluteSeek -> fileBegin + RelativeSeek -> fileCurrent + SeekFromEnd -> fileEnd + throwWinErrorIfFalse $ c_SetFilePointer hdl offset method + +-- --------------- +-- Temporary Files + +-- Maximum allowed path length. +maxPath :: Int +maxPath = 260 + +-- | Get the default temporary directory. +getTempPath :: IO FilePath +getTempPath = + -- 16-bit chars + Marshal.allocaBytes (fromIntegral (2 * maxPath)) $ \tmp_path -> do + throwWinErrorIf (== 0) $ + c_GetTempPath (fromIntegral maxPath) tmp_path + CString.peekCWString tmp_path + +-- | Get a unique temporary file name. No more than three characters of +-- the prefix string are used. An empty prefix string is allowed. +getTempFileName :: FilePath -> String -> IO FilePath +getTempFileName dir prefix = do + when (length dir > maxPath - 14) $ + ioError $ IOErr.mkIOError + IOErr.illegalOperationErrorType + "System.Windows.IO.getTempFileName: \ + \Path length is too long." + Nothing (Just dir) + dir' <- if null dir then getTempPath else return dir + let prefix3 = take 3 prefix + Marshal.allocaBytes (2 * maxPath) $ \filename -> + CString.withCWString dir' $ \d -> + CString.withCWString prefix3 $ \p3 -> do + throwWinErrorIf (== 0) $ + c_GetTempFileName d p3 0 filename + CString.peekCWString filename + +-- | Open a temporary file with a filename prefix. If the directory +-- path is an empty string then the default temporary directory will be +-- used. No more than three characters of the prefix string are used. +-- An empty prefix string is allowed. +openTempFile :: FilePath -> String -> IO (FilePath, HANDLE) +openTempFile dir prefix = do + filename <- getTempFileName dir prefix + hdl <- CString.withCWString filename $ \file -> do + throwWinErrorIfInvalidHandle $ + c_CreateFile file + (genericRead .|. genericWrite) + 0 + Ptr.nullPtr + createAlways + (fileFlagOverlapped .|. fileAttributeTemporary) + Ptr.nullPtr + return (filename, hdl) + +-- ------------------------- +-- I/O manager (threaded RTS) + +-- | I/O completion port. +completionPort :: IORef HANDLE +{-# NOINLINE completionPort #-} +completionPort = unsafePerformIO $ do + hdl <- throwWinErrorIfInvalidHandle (c_NewCompletionPort 1) + startIOManager hdl + IORef.newIORef hdl + +-- | Associate a Windows handle with the I/O completion port. +associateWithPort :: HANDLE -> IO () +associateWithPort hdl = do + port <- IORef.readIORef completionPort + throwWinErrorIfFalse (c_AssociateHandleWithPort hdl port) + +-- | Associate a socket with the I/O completion port. +associateSocketWithPort :: Socket -> IO () +associateSocketWithPort sock = do + port <- IORef.readIORef completionPort + throwWinErrorIfFalse $ + c_AssociateSocketWithPort (Socket.fdSocket sock) port + +-- | Start the IO manager. +startIOManager :: HANDLE -> IO ThreadId +startIOManager port = Concur.forkIO (handleCompletions port) + +-- | Handle completed I/O actions obtained from an I/O completion port. +handleCompletions :: HANDLE -> IO () +handleCompletions port = do + Marshal.alloca $ \num_bytes_ptr -> Marshal.alloca $ \userdata_ptr -> do + res <- c_GetCompletion port num_bytes_ptr userdata_ptr infinite + err <- if not res then getWinError else return errorSuccess + + if userdata_ptr == Ptr.nullPtr + then Ex.throwIO err + else do + mvar_stable_ptr <- Storable.peek userdata_ptr + mvar <- StablePtr.deRefStablePtr mvar_stable_ptr + if err /= errorSuccess + then do + success <- MVar.tryPutMVar mvar (Left err) + when (not success) $ fail + "System.Windows.IO.handleCompletions: \ + \MVar is not empty." + else do + num_bytes <- + fmap fromIntegral $! Storable.peek num_bytes_ptr :: IO Int + success <- MVar.tryPutMVar mvar (Right num_bytes) + when (not success) $ fail + "System.Windows.IO.handleCompletions: \ + \MVar is not empty." + handleCompletions port + +-- --------------- +-- Asynchronous I/O + +errorIOPending :: WinError +errorIOPending = WinError 997 + +waitForCompletion :: (StablePtr (MVar (Either WinError Int)) -> IO CInt) + -> IO Int +waitForCompletion async_op = do + wait_var <- MVar.newEmptyMVar + Ex.bracket (StablePtr.newStablePtr wait_var) StablePtr.freeStablePtr $ + \wait_var_ptr -> do + res <- async_op wait_var_ptr + if res == (-1) + then do + err <- getWinError + if err == errorIOPending + then do + -- The operation is initiated asynchronously. + -- We wait for the completion of the operation. + res' <- MVar.takeMVar wait_var + case res' of + Right num_bytes -> return num_bytes + Left e | e == errorHandleEOF -> return 0 + | otherwise -> Ex.throwIO e + else + -- An error occurred. + if err == errorHandleEOF then return 0 else Ex.throwIO err + else + -- The operation is completed synchronously. + return $ fromIntegral res + +-- | Read bytes from a handle into a buffer. The actual number of bytes +-- read depends on the handle and may be less than the number of bytes +-- requested. The function returns zero if the end of input has been +-- reached. +read :: HANDLE -> Int64 -> Ptr Word8 -> Int -> IO Int +read hdl pos buf buf_size = + waitForCompletion $ + c_AsyncRead hdl (fromIntegral pos) buf (fromIntegral buf_size) + +-- | Write bytes from a buffer to a handle. +write :: HANDLE -> Int64 -> Ptr Word8 -> Int -> IO Int +write hdl pos buf buf_size = + waitForCompletion $ + c_AsyncWrite hdl (fromIntegral pos) buf (fromIntegral buf_size) + +-- | Send bytes from a buffer. +send :: Socket -> Ptr Word8 -> Int -> IO Int +send (MkSocket sd _ _ _ _) buf buf_size = + waitForCompletion $ + c_AsyncSend sd buf (fromIntegral buf_size) + +-- | Send bytes from a buffer to a remote address. +sendTo :: Socket -> Ptr Word8 -> Int -> SockAddr -> IO Int +sendTo (MkSocket sd _ _ _ _) buf buf_size addr = + let addr_size = Socket.sizeOfSockAddr addr in + Marshal.allocaBytes addr_size $ \addr_ptr -> do + Socket.pokeSockAddr addr_ptr addr + waitForCompletion $ + c_AsyncSendTo sd buf (fromIntegral buf_size) + addr_ptr (fromIntegral addr_size) + +-- | Receive bytes from a socket into a buffer. The actual number of +-- bytes received may be less than the number of bytes requested. The +-- function returns zero if the end of input has been reached. +recv :: Socket -> Ptr Word8 -> Int -> IO Int +recv (MkSocket sd _ _ _ _) buf buf_size = + waitForCompletion $ + c_AsyncRecv sd buf (fromIntegral buf_size) + +-- | Receive bytes from a socket into a buffer. The actual number of +-- bytes received may be less than the number of bytes requested. The +-- function returns zero if the end of input has been reached. +recvFrom :: Socket -> Ptr a -> Int -> IO (Int, SockAddr) +recvFrom sock@(MkSocket sd family _ _ _) buf buf_size = + let addr_size = Socket.sizeOfSockAddrByFamily family in + Marshal.allocaBytes addr_size $ \addr_ptr -> + Marshal.alloca $ \addr_size_ptr -> do + Storable.poke addr_size_ptr (fromIntegral addr_size) + num <- waitForCompletion $ + c_AsyncRecvFrom sd buf (fromIntegral buf_size) addr_ptr + addr_size_ptr + -- N.B. WSARecvFrom does not provide the source address for + -- connection-oriented sockets. + connected <- Socket.sIsConnected sock + maybe_addr <- if connected + then Socket.getPeerName sock + else Socket.peekSockAddr addr_ptr + return (num, maybe_addr) + +-- -------------------------- +-- strict ByteString versions + +-- | Read bytes from a handle into a strict ByteString. The actual +-- number of bytes read depends on the handle and may be less +-- than the number of bytes requested. The function returns an empty +-- ByteString if the end of input has been reached. +readBS :: HANDLE -> Int64 -> Int -> IO ByteString +readBS hdl pos num_bytes = + B.createAndTrim num_bytes + (\buf -> read hdl pos buf num_bytes) + +-- | Write bytes from a strict ByteString to a handle. +writeBS :: HANDLE -> Int64 -> ByteString -> IO Int +writeBS hdl pos (PS fp off len) = + ForeignPtr.withForeignPtr fp $ \p -> + write hdl pos (p `Ptr.plusPtr` off) len + +-- | Send bytes from a strict ByteString. +sendBS :: Socket -> ByteString -> IO Int +sendBS sock (PS fp off len) = + ForeignPtr.withForeignPtr fp $ \p -> + send sock (p `Ptr.plusPtr` off) len + +-- | Send bytes from a strict ByteString to a remote address. +sendToBS :: Socket -> ByteString -> SockAddr -> IO Int +sendToBS sock (PS fp off len) addr = + ForeignPtr.withForeignPtr fp $ \p -> + sendTo sock (p `Ptr.plusPtr` off) len addr + +-- | Receive bytes into a strict ByteString. The actual number of bytes +-- received may be less than the number of bytes requested. The +-- function returns an empty ByteString if the end of input has been +-- reached. +recvBS :: Socket -> Int -> IO ByteString +recvBS sock num_bytes = + B.createAndTrim num_bytes (\buf -> recv sock buf num_bytes) + +-- | Receive bytes into a strict ByteString. The actual number of bytes +-- received may be less than the number of bytes requested. The +-- function returns an empty ByteString if the end of input has been +-- reached. +recvFromBS :: Socket -> Int -> IO (ByteString, SockAddr) +recvFromBS sock@(MkSocket sd family _ _ _) num_bytes = + B.createAndTrim' num_bytes $ \buf -> do + (num_recvd, addr) <- recvFrom sock buf num_bytes + return (0, num_recvd, addr) + +-- ----------------------- +-- Miscellaneous functions + +-- | Close a Windows handle. +closeHandle :: HANDLE -> IO () +closeHandle hdl = throwWinErrorIfFalse $ c_CloseHandle hdl + +-- ----------------- +-- Foreign functions + +foreign import stdcall unsafe "CloseHandle" + c_CloseHandle :: HANDLE -> IO Bool + +foreign import ccall unsafe "HsNewCompletionPort" + c_NewCompletionPort :: Word32 -> IO HANDLE + +foreign import ccall unsafe "HsAssociateHandleWithPort" + c_AssociateHandleWithPort :: HANDLE -> HANDLE -> IO Bool + +foreign import ccall unsafe "HsAssociateSocketWithPort" + c_AssociateSocketWithPort :: CInt -> HANDLE -> IO Bool + +foreign import ccall safe "HsGetCompletion" + c_GetCompletion :: HANDLE -> Ptr Word32 -> Ptr (StablePtr a) + -> Word32 -> IO Bool + +foreign import ccall unsafe "HsAsyncRead" + c_AsyncRead :: HANDLE -> Word64 -> Ptr a -> CInt -> StablePtr b + -> IO CInt + +foreign import ccall unsafe "HsAsyncWrite" + c_AsyncWrite :: HANDLE -> Word64 -> Ptr a -> CInt -> StablePtr b + -> IO CInt + +foreign import ccall unsafe "HsAsyncRecv" + c_AsyncRecv :: CInt -> Ptr a -> CInt -> StablePtr b -> IO CInt + +foreign import ccall unsafe "HsAsyncRecvFrom" + c_AsyncRecvFrom :: CInt -> Ptr a -> CInt -> Ptr SockAddr + -> Ptr CInt -> StablePtr b -> IO CInt + +foreign import ccall unsafe "HsAsyncSend" + c_AsyncSend :: CInt -> Ptr a -> CInt -> StablePtr b -> IO CInt + +foreign import ccall unsafe "HsAsyncSendTo" + c_AsyncSendTo :: CInt -> Ptr a -> CInt -> Ptr SockAddr + -> CInt -> StablePtr b -> IO CInt + +foreign import stdcall unsafe "CreateFileW" + c_CreateFile :: CWString -> Word32 -> Word32 -> Ptr () + -> Word32 -> Word32 -> HANDLE -> IO HANDLE + +foreign import ccall unsafe "HsGetFileSize" + c_GetFileSize :: HANDLE -> Ptr Int64 -> IO Bool + +foreign import stdcall unsafe "SetEndOfFile" + c_SetEndOfFile :: HANDLE -> IO Bool + +foreign import ccall unsafe "HsGetFilePointer" + c_GetFilePointer :: HANDLE -> Ptr Int64 -> IO Bool + +foreign import ccall unsafe "HsSetFilePointer" + c_SetFilePointer :: HANDLE -> Int64 -> Word32 -> IO Bool + +foreign import stdcall unsafe "GetTempPathW" + c_GetTempPath :: Word32 -> CWString -> IO Word32 + +foreign import stdcall unsafe "GetTempFileNameW" + c_GetTempFileName :: CWString -> CWString -> Word32 -> CWString + -> IO Word32
+ cbits/HsWinIO.c view
@@ -0,0 +1,312 @@+// Copyright 2007-2008 Felix Martini. +// +// See LICENSE for license terms. + +#ifdef _WIN32 + +#define _WIN32_WINNT 0x0500 + +#define DllExport __declspec(dllexport) + +#include <winsock2.h> +#include <windows.h> + +DllExport +BOOL HsGetFileSize(HANDLE fileHandle, INT64 *fileSize) +{ + LARGE_INTEGER size; + BOOL res; + res = GetFileSizeEx(fileHandle, &size); + *fileSize = size.QuadPart; + return res; +} + +DllExport +BOOL HsGetFilePointer(HANDLE fileHandle, INT64 *filePointer) +{ + LARGE_INTEGER zero; + LARGE_INTEGER pointer; + BOOL res; + zero.QuadPart = 0; + res = SetFilePointerEx(fileHandle, zero, &pointer, FILE_CURRENT); + *filePointer = pointer.QuadPart; + return res; +} + +DllExport +BOOL HsSetFilePointer(HANDLE fileHandle, INT64 offset, DWORD moveMethod) +{ + LARGE_INTEGER distToMove; + distToMove.QuadPart = offset; + return SetFilePointerEx(fileHandle, distToMove, NULL, moveMethod); +} + +DllExport +HANDLE HsNewCompletionPort(DWORD numThreads) +{ + return CreateIoCompletionPort(INVALID_HANDLE_VALUE, NULL, 0, + numThreads); +} + +DllExport +BOOL HsAssociateHandleWithPort(HANDLE handle, HANDLE port) +{ + HANDLE h; + h = CreateIoCompletionPort(handle, port, 0, 0); + return (h == port); +} + +DllExport +BOOL HsAssociateSocketWithPort(SOCKET socket, HANDLE port) +{ + HANDLE h; + h = CreateIoCompletionPort((HANDLE)socket, port, 0, 0); + return (h == port); +} + +typedef struct _PER_IO_DATA { + OVERLAPPED Overlapped; + void *UserData; +} PER_IO_DATA; + +DllExport +BOOL HsGetCompletion(HANDLE port, DWORD *numBytes, void **userData, + DWORD timeout) +{ + OVERLAPPED *overlappedPtr = NULL; + ULONG_PTR completionKey; + BOOL res; + + res = GetQueuedCompletionStatus(port, numBytes, &completionKey, + &overlappedPtr, timeout); + if (overlappedPtr != NULL) { + PER_IO_DATA *perIoDataPtr; + perIoDataPtr = + CONTAINING_RECORD(overlappedPtr, PER_IO_DATA, Overlapped); + *userData = perIoDataPtr->UserData; + HeapFree(GetProcessHeap(), 0, perIoDataPtr); + } else { + *userData = NULL; + } + return res; +} + +// HsAsyncRead returns the number of bytes read if the operation is completed +// synchronously or -1 if an error occurs. +// N.B. Operations that are successfully initiated asynchronously will report +// the error ERROR_IO_PENDING and a completion event will be send to the +// completion port when the operation is finished. +DllExport +int HsAsyncRead(HANDLE handle, UINT64 pos, void *buf, int size, + void *userData) +{ + PER_IO_DATA *perIoDataPtr; + DWORD numBytesRead; + BOOL res; + + perIoDataPtr = + HeapAlloc(GetProcessHeap(), HEAP_ZERO_MEMORY, sizeof(PER_IO_DATA)); + if (perIoDataPtr == NULL) { + SetLastError(ERROR_NOT_ENOUGH_MEMORY); + return -1; + } else { + perIoDataPtr->Overlapped.Offset = (DWORD) pos; + perIoDataPtr->Overlapped.OffsetHigh = (DWORD) (pos >> 32); + perIoDataPtr->UserData = userData; + res = ReadFile(handle, buf, size, &numBytesRead, + &(perIoDataPtr->Overlapped)); + if (!res) { + DWORD error; + error = GetLastError(); + if (error != ERROR_IO_PENDING) { + HeapFree(GetProcessHeap(), 0, perIoDataPtr); + } + return -1; + } else { + // We report a pending operation even if it has completed + // synchronously because Windows still posts a completion event + // to the port. TODO: Vista and later operating systems support a + // function named SetFileCompletionNotificationModes which can + // prevent that. + SetLastError(ERROR_IO_PENDING); + return -1; + } + } +} + +DllExport +int HsAsyncWrite(HANDLE handle, UINT64 pos, void *buf, int size, + void *userData) +{ + PER_IO_DATA *perIoDataPtr; + DWORD numBytesWritten; + BOOL res; + + perIoDataPtr = + HeapAlloc(GetProcessHeap(), HEAP_ZERO_MEMORY, sizeof(PER_IO_DATA)); + if (perIoDataPtr == NULL) { + SetLastError(ERROR_NOT_ENOUGH_MEMORY); + return -1; + } else { + perIoDataPtr->Overlapped.Offset = (DWORD) pos; + perIoDataPtr->Overlapped.OffsetHigh = (DWORD) (pos >> 32); + perIoDataPtr->UserData = userData; + res = WriteFile(handle, buf, size, &numBytesWritten, + &(perIoDataPtr->Overlapped)); + if (!res) { + DWORD error; + error = GetLastError(); + if (error != ERROR_IO_PENDING) { + HeapFree(GetProcessHeap(), 0, perIoDataPtr); + } + return -1; + } else { + SetLastError(ERROR_IO_PENDING); + return -1; + } + } +} + +DllExport +int HsAsyncRecv(SOCKET socket, void *buf, int size, void *userData) +{ + WSABUF dataBuf; + DWORD flags; + PER_IO_DATA *perIoDataPtr; + DWORD numBytesRecvd; + int res; + + dataBuf.buf = (char *)buf; + dataBuf.len = size; + flags = 0; + perIoDataPtr = + HeapAlloc(GetProcessHeap(), HEAP_ZERO_MEMORY, sizeof(PER_IO_DATA)); + if (perIoDataPtr == NULL) { + SetLastError(ERROR_NOT_ENOUGH_MEMORY); + return -1; + } else { + perIoDataPtr->UserData = userData; + res = WSARecv(socket, &dataBuf, 1, &numBytesRecvd, &flags, + &(perIoDataPtr->Overlapped), NULL); + if (res != 0) { + DWORD error; + error = WSAGetLastError(); + if (error != WSA_IO_PENDING) { + HeapFree(GetProcessHeap(), 0, perIoDataPtr); + } + return -1; + } else { + SetLastError(ERROR_IO_PENDING); + return -1; + } + } +} + +DllExport +int HsAsyncRecvFrom(SOCKET socket, void *buf, int size, + struct sockaddr *fromPtr, int *fromLenPtr, void *userData) +{ + WSABUF dataBuf; + DWORD flags; + PER_IO_DATA *perIoDataPtr; + DWORD numBytesRecvd; + int res; + + dataBuf.buf = (char *)buf; + dataBuf.len = size; + flags = 0; + perIoDataPtr = + HeapAlloc(GetProcessHeap(), HEAP_ZERO_MEMORY, sizeof(PER_IO_DATA)); + if (perIoDataPtr == NULL) { + SetLastError(ERROR_NOT_ENOUGH_MEMORY); + return -1; + } else { + perIoDataPtr->UserData = userData; + res = WSARecvFrom(socket, &dataBuf, 1, &numBytesRecvd, &flags, + fromPtr, fromLenPtr, &(perIoDataPtr->Overlapped), NULL); + if (res != 0) { + DWORD error; + error = WSAGetLastError(); + if (error != WSA_IO_PENDING) { + HeapFree(GetProcessHeap(), 0, perIoDataPtr); + } + return -1; + } else { + SetLastError(ERROR_IO_PENDING); + return -1; + } + } +} + +DllExport +int HsAsyncSend(SOCKET socket, void *buf, int size, void *userData) +{ + WSABUF dataBuf; + DWORD flags; + PER_IO_DATA *perIoDataPtr; + DWORD numBytesSend; + int res; + + dataBuf.buf = (char *)buf; + dataBuf.len = size; + flags = 0; + perIoDataPtr = + HeapAlloc(GetProcessHeap(), HEAP_ZERO_MEMORY, sizeof(PER_IO_DATA)); + if (perIoDataPtr == NULL) { + SetLastError(ERROR_NOT_ENOUGH_MEMORY); + return -1; + } else { + perIoDataPtr->UserData = userData; + res = WSASend(socket, &dataBuf, 1, &numBytesSend, flags, + &(perIoDataPtr->Overlapped), NULL); + if (res != 0) { + DWORD error; + error = WSAGetLastError(); + if (error != WSA_IO_PENDING) { + HeapFree(GetProcessHeap(), 0, perIoDataPtr); + } + return -1; + } else { + SetLastError(ERROR_IO_PENDING); + return -1; + } + } +} + +DllExport +int HsAsyncSendTo(SOCKET socket, void *buf, int size, + struct sockaddr *toPtr, int toLen, void *userData) +{ + WSABUF dataBuf; + DWORD flags; + PER_IO_DATA *perIoDataPtr; + DWORD numBytesSend; + int res; + + dataBuf.buf = (char *)buf; + dataBuf.len = size; + flags = 0; + perIoDataPtr = + HeapAlloc(GetProcessHeap(), HEAP_ZERO_MEMORY, sizeof(PER_IO_DATA)); + if (perIoDataPtr == NULL) { + SetLastError(ERROR_NOT_ENOUGH_MEMORY); + return -1; + } else { + perIoDataPtr->UserData = userData; + res = WSASendTo(socket, &dataBuf, 1, &numBytesSend, flags, + toPtr, toLen, &(perIoDataPtr->Overlapped), NULL); + if (res != 0) { + DWORD error; + error = WSAGetLastError(); + if (error != WSA_IO_PENDING) { + HeapFree(GetProcessHeap(), 0, perIoDataPtr); + } + return -1; + } else { + SetLastError(ERROR_IO_PENDING); + return -1; + } + } +} + +#endif // _WIN32
+ winio.cabal view
@@ -0,0 +1,22 @@+name: winio +version: 0.1 +copyright: 2007-2009 Felix Martini +license: BSD3 +license-file: LICENSE +maintainer: felix@felixmartini.com +stability: Experimental +synopsis: I/O library for Windows +description: I/O library for Windows with I/O completion port support. +category: System, Network +homepage: http://github.com/felixmar/winio +build-type: Simple +cabal-version: >= 1.2 + +library + build-depends: base >= 3, bytestring, extensible-exceptions, + network >= 2.2.1, winerror + exposed-modules: System.Windows.IO + Network.Socket.Compat + Network.Socket.ByteString.Compat + c-sources: cbits/HsWinIO.c + extra-libraries: kernel32, ws2_32