git.iko.soy/streamly
on e856425 help sign in
streamly/src/Streamly/Internal/FileSystem/FDIO.hs
216 lines 8.2 kB history raw
1#include "inline.hs"
3-- |
4-- Module : Streamly.Internal.FileSystem.FDIO
5-- Copyright : (c) 2019 Composewell Technologies
6-- Copyright : (c) 1994-2008 The University of Glasgow
7--
8-- License : BSD3
9-- Maintainer : streamly@composewell.com
10-- Stability : experimental
11-- Portability : GHC
12--
13-- Low level IO routines interfacing the operating system.
14--
16module Streamly.Internal.FileSystem.FDIO
17 ( write
18 , writeAll
19 , writev
20 , writevAll
21 )
22where
24import Control.Monad (when)
25import Streamly.Internal.System.IOVec.Type (IOVec)
26#if !defined(mingw32_HOST_OS)
27import Control.Concurrent (threadWaitWrite)
28import Data.Int (Int64)
29import Foreign.C.Error (throwErrnoIfMinus1RetryMayBlock)
30import Foreign.C.Types (CBool(..))
31import System.Posix.Internals (c_write, c_safe_write)
32import Streamly.Internal.System.IOVec.Type (c_writev, c_safe_writev)
33#endif
35import Foreign.C.Types (CSize(..), CInt(..))
36import Data.Word (Word8)
37import Foreign.Ptr (plusPtr, Ptr)
39import GHC.IO.FD (FD(..))
41-------------------------------------------------------------------------------
42-- IO Routines
43-------------------------------------------------------------------------------
45-- See System.POSIX.Internals in GHC base package
47-------------------------------------------------------------------------------
48-- Write without blocking the underlying OS thread
49-------------------------------------------------------------------------------
51#if !defined(mingw32_HOST_OS)
53foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool
55isNonBlocking :: FD -> Bool
56isNonBlocking fd = fdIsNonBlocking fd /= 0
58-- "poll"s the fd for data to become available or timeout
59-- See cbits/inputReady.c in base package
60foreign import ccall unsafe "fdReady"
61 unsafe_fdReady :: CInt -> CBool -> Int64 -> CBool -> IO CInt
63writeNonBlocking :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
64writeNonBlocking loc !fd !buf !off !len
65 | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
66 | otherwise = do
67 let isWrite = 1
68 isSocket = 0
69 msecs = 0
70 r <- unsafe_fdReady (fdFD fd) isWrite msecs isSocket
71 when (r == 0) $ threadWaitWrite (fromIntegral (fdFD fd))
72 if threaded then safe_write else unsafe_write
74 where
76 do_write call = fromIntegral `fmap`
77 throwErrnoIfMinus1RetryMayBlock loc call
78 (threadWaitWrite (fromIntegral (fdFD fd)))
79 unsafe_write = do_write (c_write (fdFD fd) (buf `plusPtr` off) len)
80 safe_write = do_write (c_safe_write (fdFD fd) (buf `plusPtr` off) len)
82writevNonBlocking :: String -> FD -> Ptr IOVec -> Int -> IO CInt
83writevNonBlocking loc !fd !iov !cnt
84 | isNonBlocking fd = unsafe_write -- unsafe is ok, it can't block
85 | otherwise = do
86 let isWrite = 1
87 isSocket = 0
88 msecs = 0
89 r <- unsafe_fdReady (fdFD fd) isWrite msecs isSocket
90 when (r == 0) $ threadWaitWrite (fromIntegral (fdFD fd))
91 if threaded then safe_write else unsafe_write
93 where
95 do_write call = fromIntegral `fmap`
96 throwErrnoIfMinus1RetryMayBlock loc call
97 (threadWaitWrite (fromIntegral (fdFD fd)))
98 unsafe_write = do_write (c_writev (fdFD fd) iov (fromIntegral cnt))
99 safe_write = do_write (c_safe_writev (fdFD fd) iov (fromIntegral cnt))
101#else
102writeNonBlocking :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
103writeNonBlocking = undefined
105writevNonBlocking :: String -> FD -> Ptr IOVec -> Int -> IO CInt
106writevNonBlocking = undefined
107#endif
109-- Windows code is disabled for now
110#if 0
112#if defined(mingw32_HOST_OS)
113# if defined(i386_HOST_ARCH)
114# define WINDOWS_CCONV stdcall
115# elif defined(x86_64_HOST_ARCH)
116# define WINDOWS_CCONV ccall
117# else
118# error Unknown mingw32 arch
119# endif
120#endif
122foreign import WINDOWS_CCONV safe "recv"
123 c_safe_recv :: CInt -> Ptr Word8 -> CInt -> CInt{-flags-} -> IO CInt
125foreign import WINDOWS_CCONV safe "send"
126 c_safe_send :: CInt -> Ptr Word8 -> CInt -> CInt{-flags-} -> IO CInt
128blockingWriteRawBufferPtr :: String -> FD -> Ptr Word8-> Int -> CSize -> IO CInt
129blockingWriteRawBufferPtr loc !fd !buf !off !len
130 = throwErrnoIfMinus1Retry loc $ do
131 let start_ptr = buf `plusPtr` off
132 send_ret = c_safe_send (fdFD fd) start_ptr (fromIntegral len) 0
133 write_ret = c_safe_write (fdFD fd) start_ptr (fromIntegral len)
134 r <- bool write_ret send_ret (fdIsSocket fd)
135 when (r == -1) c_maperrno
136 return r
137 -- We don't trust write() to give us the correct errno, and
138 -- instead do the errno conversion from GetLastError()
139 -- ourselves. The main reason is that we treat ERROR_NO_DATA
140 -- (pipe is closing) as EPIPE, whereas write() returns EINVAL
141 -- for this case. We need to detect EPIPE correctly, because it
142 -- shouldn't be reported as an error when it happens on stdout.
143 -- As for send()'s case, Winsock functions don't do errno
144 -- conversion in any case so we have to do it ourselves.
145 -- That means we're doing the errno conversion no matter if the
146 -- fd is from a socket or not.
148-- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
149-- These calls may block, but that's ok.
151asyncWriteRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
152asyncWriteRawBufferPtr loc !fd !buf !off !len = do
153 (l, rc) <- asyncWrite (fromIntegral (fdFD fd)) (fdIsSocket_ fd)
154 (fromIntegral len) (buf `plusPtr` off)
155 if l == (-1)
156 then let sock_errno = c_maperrno_func (fromIntegral rc)
157 non_sock_errno = Errno (fromIntegral rc)
158 errno = bool non_sock_errno sock_errno (fdIsSocket fd)
159 in ioError (errnoToIOError loc errno Nothing Nothing)
160 else return (fromIntegral l)
162writeNonBlocking :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO CInt
163writeNonBlocking loc !fd !buf !off !len
164 | threaded = blockingWriteRawBufferPtr loc fd buf off len
165 | otherwise = asyncWriteRawBufferPtr loc fd buf off len
167#endif
169-- | @write FD buffer offset length@ tries to write data on the given
170-- filesystem fd (cannot be a socket) up to sepcified length starting from the
171-- given offset in the buffer. The write will not block the OS thread, it may
172-- suspend the Haskell thread until write can proceed. Returns the actual
173-- amount of data written.
174write :: FD -> Ptr Word8 -> Int -> CSize -> IO CInt
175write = writeNonBlocking "Streamly.Internal.FileSystem.FDIO"
177-- XXX sendAll for sockets has a similar code, we can deduplicate the two.
178-- XXX we need to check the errno to determine if the loop should continue. For
179-- example, write may return without writing all data if the process file-size
180-- limit has reached, in that case keep writing in a loop is fruitless.
181--
182-- | Keep writing in a loop until all data in the buffer has been written.
183writeAll :: FD -> Ptr Word8 -> Int -> IO ()
184writeAll fd ptr bytes = do
185 res <- write fd ptr 0 (fromIntegral bytes)
186 let res' = fromIntegral res
187 when (res' < bytes) $
188 writeAll fd (ptr `plusPtr` res') (bytes - res')
190-------------------------------------------------------------------------------
191-- Vector IO
192-------------------------------------------------------------------------------
194-- | @write FD iovec count@ tries to write data on the given filesystem fd
195-- (cannot be a socket) from an iovec with specified number of entries. The
196-- write will not block the OS thread, it may suspend the Haskell thread until
197-- write can proceed. Returns the actual amount of data written.
198writev :: FD -> Ptr IOVec -> Int -> IO CInt
199writev = writevNonBlocking "Streamly.Internal.FileSystem.FDIO"
201-- XXX incomplete
202-- | Keep writing an iovec in a loop until all the iovec entries are written.
203writevAll :: FD -> Ptr IOVec -> Int -> IO ()
204writevAll fd iovec count = do
205 _res <- writev fd iovec count
206 {-
207 let res' = fromIntegral res
208 totalBytes = countIOVecBytes
209 if res' < totalBytes
210 then do
211 let iovec' = createModifiedIOVec
212 count' = ...
213 writeAll fd iovec' count'
214 else return ()
215 -}
216 return ()