IO.hs

{-# 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