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