Commit 9746e23a authored by sof's avatar sof
Browse files

[project @ 2001-11-26 20:04:00 by sof]

Make the IO implementation work with WinSock once again.

When creating sockets with WinSock, you don't get back
a file descriptor, but a SOCKET (which just so happens
to map to the same type as a 'normal' file descriptor).
This SOCKET value cannot be used with the CRT ops
read(), write(), close(), but you have to use the
socket-specific operations (recv(), send(), and closesocket(),
respectively) instead.

To keep track of this distinction between file and
socket file descriptors, the following changes were
made:

* a Handle__ has got a new field, haIsStream, which is True
  for sockets / streams.
  (this field is essentially unused in non-Win32 settings,
   but I decided not to conditionalise its presence).
* PrelHandle.openFd now takes an extra (Maybe FDType) argument,
  which lets you force what type of FD we're converting into
  a Handle (this is crucial for WinSock SOCKETs, since we don't
  want to attempt fstat()ing them).

Fixes breakage that was introduced with May 2001 (or earlier)
rewrite of the IO layer. This commit build upon recent IO changes
to HEAD, so merging it to STABLE will require importing those
changes too (I'll let others be the judge whether this should
be done or not).
parent 254849fc
......@@ -4,7 +4,7 @@
#undef DEBUG
-- -----------------------------------------------------------------------------
-- $Id: PrelHandle.hs,v 1.3 2001/11/14 11:39:29 simonmar Exp $
-- $Id: PrelHandle.hs,v 1.4 2001/11/26 20:04:00 sof Exp $
--
-- (c) The University of Glasgow, 1994-2001
--
......@@ -232,7 +232,7 @@ checkReadableHandle act handle_ =
let ref = haBuffer handle_
buf <- readIORef ref
when (bufferIsWritable buf) $ do
new_buf <- flushWriteBuffer (haFD handle_) buf
new_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
writeIORef ref new_buf{ bufState=ReadBuffer }
act handle_
_other -> act handle_
......@@ -308,7 +308,12 @@ handleFinalizer m = do
let fd = fromIntegral (haFD h_)
unlockFile fd
-- ToDo: closesocket() for a WINSOCK socket?
when (fd /= -1) (c_close fd >> return ())
when (fd /= -1)
#ifdef mingw32_TARGET_OS
(c_close fd >> return ())
#else
(closeFd (haIsStream handle_ fd >> return ())
#endif
return ()
-- ---------------------------------------------------------------------------
......@@ -375,7 +380,7 @@ flushWriteBufferOnly h_ = do
ref = haBuffer h_
buf <- readIORef ref
new_buf <- if bufferIsWritable buf
then flushWriteBuffer fd buf
then flushWriteBuffer fd (haIsStream h_) buf
else return buf
writeIORef ref new_buf
......@@ -389,7 +394,7 @@ flushBuffer h_ = do
flushed_buf <-
case bufState buf of
ReadBuffer -> flushReadBuffer (haFD h_) buf
WriteBuffer -> flushWriteBuffer (haFD h_) buf
WriteBuffer -> flushWriteBuffer (haFD h_) (haIsStream h_) buf
writeIORef ref flushed_buf
......@@ -410,8 +415,8 @@ flushReadBuffer fd buf
(c_lseek (fromIntegral fd) (fromIntegral off) sEEK_CUR)
return buf{ bufWPtr=0, bufRPtr=0 }
flushWriteBuffer :: FD -> Buffer -> IO Buffer
flushWriteBuffer fd buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } = do
flushWriteBuffer :: FD -> Bool -> Buffer -> IO Buffer
flushWriteBuffer fd is_stream buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } = do
let bytes = w - r
#ifdef DEBUG_DUMP
puts ("flushWriteBuffer, fd=" ++ show fd ++ ", bytes=" ++ show bytes ++ "\n")
......@@ -420,24 +425,24 @@ flushWriteBuffer fd buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } = do
then return (buf{ bufRPtr=0, bufWPtr=0 })
else do
res <- throwErrnoIfMinus1RetryMayBlock "flushWriteBuffer"
(write_off (fromIntegral fd) b (fromIntegral r)
(write_off (fromIntegral fd) is_stream b (fromIntegral r)
(fromIntegral bytes))
(threadWaitWrite fd)
let res' = fromIntegral res
if res' < bytes
then flushWriteBuffer fd (buf{ bufRPtr = r + res' })
then flushWriteBuffer fd is_stream (buf{ bufRPtr = r + res' })
else return buf{ bufRPtr=0, bufWPtr=0 }
foreign import "prel_PrelHandle_write" unsafe
write_off :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
write_off :: CInt -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
fillReadBuffer :: FD -> Bool -> Buffer -> IO Buffer
fillReadBuffer fd is_line
fillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO Buffer
fillReadBuffer fd is_line is_stream
buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =
-- buffer better be empty:
assert (r == 0 && w == 0) $ do
fillReadBufferLoop fd is_line buf b w size
fillReadBufferLoop fd is_line is_stream buf b w size
-- For a line buffer, we just get the first chunk of data to arrive,
-- and don't wait for the whole buffer to be full (but we *do* wait
......@@ -445,7 +450,7 @@ fillReadBuffer fd is_line
-- appears to be what GHC has done for a long time, and I suspect it
-- is more useful than line buffering in most cases.
fillReadBufferLoop fd is_line buf b w size = do
fillReadBufferLoop fd is_line is_stream buf b w size = do
let bytes = size - w
if bytes == 0 -- buffer full?
then return buf{ bufRPtr=0, bufWPtr=w }
......@@ -454,7 +459,7 @@ fillReadBufferLoop fd is_line buf b w size = do
puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n")
#endif
res <- throwErrnoIfMinus1RetryMayBlock "fillReadBuffer"
(read_off fd b (fromIntegral w) (fromIntegral bytes))
(read_off fd is_stream b (fromIntegral w) (fromIntegral bytes))
(threadWaitRead fd)
let res' = fromIntegral res
#ifdef DEBUG_DUMP
......@@ -465,11 +470,11 @@ fillReadBufferLoop fd is_line buf b w size = do
then ioe_EOF
else return buf{ bufRPtr=0, bufWPtr=w }
else if res' < bytes && not is_line
then fillReadBufferLoop fd is_line buf b (w+res') size
then fillReadBufferLoop fd is_line is_stream buf b (w+res') size
else return buf{ bufRPtr=0, bufWPtr=w+res' }
foreign import "prel_PrelHandle_read" unsafe
read_off :: FD -> RawBuffer -> Int -> CInt -> IO CInt
read_off :: FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
-- ---------------------------------------------------------------------------
-- Standard Handles
......@@ -599,7 +604,7 @@ openFile' filepath ex_mode =
throwErrnoIfMinus1Retry "openFile"
(c_open f (fromIntegral oflags) 0o666)
openFd fd filepath mode binary truncate
openFd fd Nothing filepath mode binary truncate
-- ASSERT: if we just created the file, then openFd won't fail
-- (so we don't need to worry about removing the newly created file
-- in the event of an error).
......@@ -615,8 +620,8 @@ append_flags = write_flags .|. o_APPEND
-- ---------------------------------------------------------------------------
-- openFd
openFd :: FD -> FilePath -> IOMode -> Bool -> Bool -> IO Handle
openFd fd filepath mode binary truncate = do
openFd :: FD -> Maybe FDType -> FilePath -> IOMode -> Bool -> Bool -> IO Handle
openFd fd mb_fd_type filepath mode binary truncate = do
-- turn on non-blocking mode
setNonBlockingFD fd
......@@ -629,15 +634,19 @@ openFd fd filepath mode binary truncate = do
-- open() won't tell us if it was a directory if we only opened for
-- reading, so check again.
fd_type <- fdType fd
fd_type <-
case mb_fd_type of
Just x -> return x
Nothing -> fdType fd
let is_stream = fd_type == Stream
case fd_type of
Directory ->
ioException (IOError Nothing InappropriateType "openFile"
"is a directory" Nothing)
Stream
| ReadWriteHandle <- ha_type -> mkDuplexHandle fd filepath binary
| otherwise -> mkFileHandle fd filepath ha_type binary
| ReadWriteHandle <- ha_type -> mkDuplexHandle fd is_stream filepath binary
| otherwise -> mkFileHandle fd is_stream filepath ha_type binary
-- regular files need to be locked
RegularFile -> do
......@@ -649,7 +658,7 @@ openFd fd filepath mode binary truncate = do
-- truncate the file if necessary
when truncate (fileTruncate filepath)
mkFileHandle fd filepath ha_type binary
mkFileHandle fd is_stream filepath ha_type binary
foreign import "lockFile" unsafe
......@@ -666,6 +675,7 @@ mkStdHandle fd filepath ha_type buf bmode = do
(Handle__ { haFD = fd,
haType = ha_type,
haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
haIsStream = False,
haBufferMode = bmode,
haFilePath = filepath,
haBuffer = buf,
......@@ -673,14 +683,15 @@ mkStdHandle fd filepath ha_type buf bmode = do
haOtherSide = Nothing
})
mkFileHandle :: FD -> FilePath -> HandleType -> Bool -> IO Handle
mkFileHandle fd filepath ha_type binary = do
mkFileHandle :: FD -> Bool -> FilePath -> HandleType -> Bool -> IO Handle
mkFileHandle fd is_stream filepath ha_type binary = do
(buf, bmode) <- getBuffer fd (initBufferState ha_type)
spares <- newIORef BufferListNil
newFileHandle handleFinalizer
(Handle__ { haFD = fd,
haType = ha_type,
haIsBin = binary,
haIsStream = is_stream,
haBufferMode = bmode,
haFilePath = filepath,
haBuffer = buf,
......@@ -688,14 +699,15 @@ mkFileHandle fd filepath ha_type binary = do
haOtherSide = Nothing
})
mkDuplexHandle :: FD -> FilePath -> Bool -> IO Handle
mkDuplexHandle fd filepath binary = do
mkDuplexHandle :: FD -> Bool -> FilePath -> Bool -> IO Handle
mkDuplexHandle fd is_stream filepath binary = do
(w_buf, w_bmode) <- getBuffer fd WriteBuffer
w_spares <- newIORef BufferListNil
let w_handle_ =
Handle__ { haFD = fd,
haType = WriteHandle,
haIsBin = binary,
haIsStream = is_stream,
haBufferMode = w_bmode,
haFilePath = filepath,
haBuffer = w_buf,
......@@ -710,6 +722,7 @@ mkDuplexHandle fd filepath binary = do
Handle__ { haFD = fd,
haType = ReadHandle,
haIsBin = binary,
haIsStream = is_stream,
haBufferMode = r_bmode,
haFilePath = filepath,
haBuffer = r_buf,
......@@ -756,7 +769,7 @@ hClose_help handle_ =
-- close the file descriptor, but not when this is the read side
-- of a duplex handle.
case haOtherSide handle_ of
Nothing -> throwErrnoIfMinus1Retry_ "hClose" (c_close fd)
Nothing -> throwErrnoIfMinus1Retry_ "hClose" (closeFd (haIsStream handle_) fd)
Just _ -> return ()
-- free the spare buffers
......@@ -825,7 +838,7 @@ hLookAhead handle = do
-- fill up the read buffer if necessary
new_buf <- if bufferEmpty buf
then fillReadBuffer fd is_line buf
then fillReadBuffer fd is_line (haIsStream handle_) buf
else return buf
writeIORef ref new_buf
......@@ -914,7 +927,7 @@ hFlush handle =
wantWritableHandle "hFlush" handle $ \ handle_ -> do
buf <- readIORef (haBuffer handle_)
if bufferIsWritable buf && not (bufferEmpty buf)
then do flushed_buf <- flushWriteBuffer (haFD handle_) buf
then do flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
writeIORef (haBuffer handle_) flushed_buf
else return ()
......@@ -1028,7 +1041,7 @@ hSeek handle mode offset =
SeekFromEnd -> sEEK_END
if bufferIsWritable buf
then do new_buf <- flushWriteBuffer fd buf
then do new_buf <- flushWriteBuffer fd (haIsStream handle_) buf
writeIORef ref new_buf
do_seek
else do
......
......@@ -3,7 +3,7 @@
#undef DEBUG_DUMP
-- -----------------------------------------------------------------------------
-- $Id: PrelIO.hs,v 1.3 2001/11/14 11:35:23 simonmar Exp $
-- $Id: PrelIO.hs,v 1.4 2001/11/26 20:04:00 sof Exp $
--
-- (c) The University of Glasgow, 1992-2001
--
......@@ -162,16 +162,16 @@ hGetChar handle =
-- buffer is empty.
case haBufferMode handle_ of
LineBuffering -> do
new_buf <- fillReadBuffer fd True buf
new_buf <- fillReadBuffer fd True (haIsStream handle_) buf
hGetcBuffered fd ref new_buf
BlockBuffering _ -> do
new_buf <- fillReadBuffer fd False buf
new_buf <- fillReadBuffer fd False (haIsStream handle_) buf
hGetcBuffered fd ref new_buf
NoBuffering -> do
-- make use of the minimal buffer we already have
let raw = bufBuf buf
r <- throwErrnoIfMinus1RetryMayBlock "hGetChar"
(read_off (fromIntegral fd) raw 0 1)
(read_off (fromIntegral fd) (haIsStream handle_) raw 0 1)
(threadWaitRead fd)
if r == 0
then ioe_EOF
......@@ -241,7 +241,7 @@ hGetLineBufferedLoop handle_ ref
else writeIORef ref buf{ bufRPtr = off + 1 }
return (concat (reverse (xs:xss)))
else do
maybe_buf <- maybeFillReadBuffer (haFD handle_) True
maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_)
buf{ bufWPtr=0, bufRPtr=0 }
case maybe_buf of
-- Nothing indicates we caught an EOF, and we may have a
......@@ -254,9 +254,9 @@ hGetLineBufferedLoop handle_ ref
hGetLineBufferedLoop handle_ ref new_buf (xs:xss)
maybeFillReadBuffer fd is_line buf
maybeFillReadBuffer fd is_line is_stream buf
= catch
(do buf <- fillReadBuffer fd is_line buf
(do buf <- fillReadBuffer fd is_line is_stream buf
return (Just buf)
)
(\e -> do if isEOFError e
......@@ -351,7 +351,7 @@ lazyRead' h handle_ = do
-- make use of the minimal buffer we already have
let raw = bufBuf buf
r <- throwErrnoIfMinus1RetryMayBlock "lazyRead"
(read_off (fromIntegral fd) raw 0 1)
(read_off (fromIntegral fd) (haIsStream handle_) raw 0 1)
(threadWaitRead fd)
if r == 0
then do handle_ <- hClose_help handle_
......@@ -367,7 +367,7 @@ lazyRead' h handle_ = do
-- is_line==True, which tells it to "just read what there is".
lazyReadBuffered h handle_ fd ref buf = do
catch
(do buf <- fillReadBuffer fd True{-is_line-} buf
(do buf <- fillReadBuffer fd True{-is_line-} (haIsStream handle_) buf
lazyReadHaveBuffer h handle_ fd ref buf
)
-- all I/O errors are discarded. Additionally, we close the handle.
......@@ -422,7 +422,7 @@ hPutcBuffered handle_ is_line c = do
let new_buf = buf{ bufWPtr = w' }
if bufferFull new_buf || is_line && c == '\n'
then do
flushed_buf <- flushWriteBuffer (haFD handle_) new_buf
flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) new_buf
writeIORef ref flushed_buf
else do
writeIORef ref new_buf
......@@ -598,7 +598,7 @@ commitBuffer' hdl raw sz@(I# _) count@(I# _) flush release
return (newEmptyBuffer raw WriteBuffer sz)
-- else, we have to flush
else do flushed_buf <- flushWriteBuffer fd old_buf
else do flushed_buf <- flushWriteBuffer fd (haIsStream handle_) old_buf
let this_buf =
Buffer{ bufBuf=raw, bufState=WriteBuffer,
......@@ -616,7 +616,7 @@ commitBuffer' hdl raw sz@(I# _) count@(I# _) flush release
-- otherwise, we have to flush the new data too,
-- and start with a fresh buffer
else do
flushWriteBuffer fd this_buf
flushWriteBuffer fd (haIsStream handle_) this_buf
writeIORef ref flushed_buf
-- if the sizes were different, then allocate
-- a new buffer of the correct size.
......
% ------------------------------------------------------------------------------
% $Id: PrelIOBase.lhs,v 1.44 2001/11/14 11:39:29 simonmar Exp $
% $Id: PrelIOBase.lhs,v 1.45 2001/11/26 20:04:00 sof Exp $
%
% (c) The University of Glasgow, 1994-2001
%
......@@ -152,6 +152,7 @@ data Handle__
haFD :: !FD, -- file descriptor
haType :: HandleType, -- type (read/write/append etc.)
haIsBin :: Bool, -- binary mode?
haIsStream :: Bool, -- is this a stream handle?
haBufferMode :: BufferMode, -- buffer contains read/write data?
haFilePath :: FilePath, -- file name, possibly
haBuffer :: !(IORef Buffer), -- the current buffer
......
/* -----------------------------------------------------------------------------
* $Id: HsStd.h,v 1.4 2001/08/17 11:06:58 simonmar Exp $
* $Id: HsStd.h,v 1.5 2001/11/26 20:04:00 sof Exp $
*
* Definitions for package `std' which are visible in Haskell land.
*
......@@ -56,6 +56,9 @@
#ifdef HAVE_SYS_TIMES_H
#include <sys/times.h>
#endif
#ifdef HAVE_WINSOCK_H
#include <winsock.h>
#endif
#if !defined(mingw32_TARGET_OS) && !defined(irix_TARGET_OS)
# if defined(HAVE_SYS_RESOURCE_H)
......
......@@ -65,14 +65,25 @@ HsInt prel_setmode(HsInt fd, HsBool toBin)
#endif
}
HsInt prel_PrelHandle_write(HsInt fd, HsAddr ptr, HsInt off, int sz)
HsInt prel_PrelHandle_write(HsInt fd, HsBool isSock, HsAddr ptr, HsInt off, int sz)
{
#ifdef _WIN32
if (isSock) {
return send(fd,ptr + off, sz, 0);
}
#endif
return write(fd,ptr + off, sz);
}
HsInt prel_PrelHandle_read(HsInt fd, HsAddr ptr, HsInt off, int sz)
HsInt prel_PrelHandle_read(HsInt fd, HsBool isSock, HsAddr ptr, HsInt off, int sz)
{
#ifdef _WIN32
if (isSock) {
return recv(fd,ptr + off, sz, 0);
}
#endif
return read(fd,ptr + off, sz);
}
void *prel_PrelIO_memcpy(char *dst, HsInt dst_off, const char *src, size_t sz)
......
......@@ -17,8 +17,8 @@ extern HsInt prel_o_binary();
extern HsInt prel_setmode(HsInt fd, HsBool isBin);
extern HsInt prel_PrelHandle_write(HsInt fd, HsAddr ptr, HsInt off, int sz);
extern HsInt prel_PrelHandle_read(HsInt fd, HsAddr ptr, HsInt off, int sz);
extern HsInt prel_PrelHandle_write(HsInt fd, HsBool isSock, HsAddr ptr, HsInt off, int sz);
extern HsInt prel_PrelHandle_read(HsInt fd, HsBool isSock, HsAddr ptr, HsInt off, int sz);
extern void* prel_PrelIO_memcpy(char *dst, HsInt dst_off, const char *src, size_t sz);
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment