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