diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Revision history for Z-IO +## 0.1.3.0 -- 2020-09-28 +* Rename `newBufferedInput/Output` to `newBufferedInput'/Output'`, add default chunk `newBufferedInput/Output`. +* Remove `ghc-pirm` depends. +* Make library works with GHC 8.6 and 8.8 again. + ## 0.1.2.0 -- 2020-09-28 * Add file offset interface back, see `FilePtr` and `FilePtrT`. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -17,7 +17,7 @@ ## Requirements -* A working haskell compiler system, GHC(>=8.10.2), cabal-install(>=3.4). +* A working haskell compiler system, GHC(>=8.6), cabal-install(>=2.4), hsc2hs. * Tests need [hspec-discover](https://hackage.haskell.org/package/hspec-discover). @@ -39,8 +39,8 @@ | let addr = SocketAddrInet 80 (tupleToInetAddr (13,107,21,200)) | -- addr = ipv4 "13.107.21.200" 80 | in withResource (initTCPClient defaultTCPClientConfig{ tcpRemoteAddr = addr}) $ \ tcp -> do -| i <- newBufferedInput defaultChunkSize tcp -| o <- newBufferedOutput defaultChunkSize tcp +| i <- newBufferedInput tcp +| o <- newBufferedOutput tcp | writeBuffer o "GET http://www.bing.com HTTP/1.1\r\nHost: www.bing.com\r\n\r\n" | flushBuffer o | readBuffer i >>= pure . T.validate @@ -52,8 +52,8 @@ | startTCPServer defaultTCPServerConfig{ | tcpListenAddr = SocketAddrInet 8080 inetLoopback, | tcpServerWorker = \ tcp -> do -| i <- newBufferedInput defaultChunkSize tcp -| o <- newBufferedOutput defaultChunkSize tcp +| i <- newBufferedInput tcp +| o <- newBufferedOutput tcp | forever $ readBuffer i >>= writeBuffer o >> flushBuffer o | } | :} diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Z-IO.cabal b/Z-IO.cabal --- a/Z-IO.cabal +++ b/Z-IO.cabal @@ -1,9 +1,10 @@ +cabal-version: 2.4 name: Z-IO -version: 0.1.2.0 +version: 0.1.3.0 synopsis: Simple and high performance IO toolkit for Haskell description: Simple and high performance IO toolkit for Haskell, including file system, network, ipc and more! -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Dong Han, Tao He maintainer: winterland1989@gmail.com @@ -11,7 +12,6 @@ (c) Tao He, 2017-2019 category: Data build-type: Simple -cabal-version: >=1.10 homepage: https://github.com/haskell-Z/Z-IO bug-reports: https://github.com/haskell-Z/Z-IO/issues @@ -103,15 +103,14 @@ Z.Compression.Zlib build-depends: base >= 4.12 && <5.0 - , Z-Data >= 0.1.3.1 && < 0.1.4 + , Z-Data >= 0.1.4 , primitive >= 0.7.1 && < 0.7.2 - , ghc-prim >= 0.6.1 && < 0.6.2 , exceptions == 0.10.* , time >= 1.8 && < 2.0 , stm == 2.5.* default-language: Haskell2010 - build-tools: hsc2hs, hspec-discover + build-tool-depends: hsc2hs:hsc2hs, hspec-discover:hspec-discover ghc-options: -Wall include-dirs: include @@ -192,7 +191,6 @@ third_party/libuv/src -- The C runtime dependencies are imposed by libuv. extra-libraries: psapi, Iphlpapi, userenv, Ws2_32 - else if os(linux) c-sources: third_party/libuv/src/fs-poll.c @@ -206,33 +204,32 @@ third_party/libuv/src/uv-common.c third_party/libuv/src/version.c - - third_party/libuv/src/unix/async.c - third_party/libuv/src/unix/core.c - third_party/libuv/src/unix/dl.c - third_party/libuv/src/unix/fs.c - third_party/libuv/src/unix/getaddrinfo.c - third_party/libuv/src/unix/getnameinfo.c - third_party/libuv/src/unix/loop.c - third_party/libuv/src/unix/loop-watcher.c - third_party/libuv/src/unix/pipe.c - third_party/libuv/src/unix/poll.c - third_party/libuv/src/unix/process.c - third_party/libuv/src/unix/random-devurandom.c - third_party/libuv/src/unix/signal.c - third_party/libuv/src/unix/stream.c - third_party/libuv/src/unix/tcp.c - third_party/libuv/src/unix/thread.c - third_party/libuv/src/unix/tty.c - third_party/libuv/src/unix/udp.c + third_party/libuv/src/unix/async.c + third_party/libuv/src/unix/core.c + third_party/libuv/src/unix/dl.c + third_party/libuv/src/unix/fs.c + third_party/libuv/src/unix/getaddrinfo.c + third_party/libuv/src/unix/getnameinfo.c + third_party/libuv/src/unix/loop.c + third_party/libuv/src/unix/loop-watcher.c + third_party/libuv/src/unix/pipe.c + third_party/libuv/src/unix/poll.c + third_party/libuv/src/unix/process.c + third_party/libuv/src/unix/random-devurandom.c + third_party/libuv/src/unix/signal.c + third_party/libuv/src/unix/stream.c + third_party/libuv/src/unix/tcp.c + third_party/libuv/src/unix/thread.c + third_party/libuv/src/unix/tty.c + third_party/libuv/src/unix/udp.c - third_party/libuv/src/unix/linux-core.c - third_party/libuv/src/unix/linux-inotify.c - third_party/libuv/src/unix/linux-syscalls.c - third_party/libuv/src/unix/procfs-exepath.c - third_party/libuv/src/unix/proctitle.c - third_party/libuv/src/unix/random-getrandom.c - third_party/libuv/src/unix/random-sysctl-linux.c + third_party/libuv/src/unix/linux-core.c + third_party/libuv/src/unix/linux-inotify.c + third_party/libuv/src/unix/linux-syscalls.c + third_party/libuv/src/unix/procfs-exepath.c + third_party/libuv/src/unix/proctitle.c + third_party/libuv/src/unix/random-getrandom.c + third_party/libuv/src/unix/random-sysctl-linux.c include-dirs: third_party/libuv/include third_party/libuv/src/unix @@ -251,33 +248,32 @@ third_party/libuv/src/uv-common.c third_party/libuv/src/version.c - - third_party/libuv/src/unix/async.c - third_party/libuv/src/unix/core.c - third_party/libuv/src/unix/dl.c - third_party/libuv/src/unix/fs.c - third_party/libuv/src/unix/getaddrinfo.c - third_party/libuv/src/unix/getnameinfo.c - third_party/libuv/src/unix/loop.c - third_party/libuv/src/unix/loop-watcher.c - third_party/libuv/src/unix/pipe.c - third_party/libuv/src/unix/poll.c - third_party/libuv/src/unix/process.c - third_party/libuv/src/unix/random-devurandom.c - third_party/libuv/src/unix/signal.c - third_party/libuv/src/unix/stream.c - third_party/libuv/src/unix/tcp.c - third_party/libuv/src/unix/thread.c - third_party/libuv/src/unix/tty.c - third_party/libuv/src/unix/udp.c + third_party/libuv/src/unix/async.c + third_party/libuv/src/unix/core.c + third_party/libuv/src/unix/dl.c + third_party/libuv/src/unix/fs.c + third_party/libuv/src/unix/getaddrinfo.c + third_party/libuv/src/unix/getnameinfo.c + third_party/libuv/src/unix/loop.c + third_party/libuv/src/unix/loop-watcher.c + third_party/libuv/src/unix/pipe.c + third_party/libuv/src/unix/poll.c + third_party/libuv/src/unix/process.c + third_party/libuv/src/unix/random-devurandom.c + third_party/libuv/src/unix/signal.c + third_party/libuv/src/unix/stream.c + third_party/libuv/src/unix/tcp.c + third_party/libuv/src/unix/thread.c + third_party/libuv/src/unix/tty.c + third_party/libuv/src/unix/udp.c - third_party/libuv/src/unix/bsd-ifaddrs.c - third_party/libuv/src/unix/darwin-proctitle.c - third_party/libuv/src/unix/darwin.c - third_party/libuv/src/unix/fsevents.c - third_party/libuv/src/unix/kqueue.c - third_party/libuv/src/unix/proctitle.c - third_party/libuv/src/unix/random-getrandom.c + third_party/libuv/src/unix/bsd-ifaddrs.c + third_party/libuv/src/unix/darwin-proctitle.c + third_party/libuv/src/unix/darwin.c + third_party/libuv/src/unix/fsevents.c + third_party/libuv/src/unix/kqueue.c + third_party/libuv/src/unix/proctitle.c + third_party/libuv/src/unix/random-getrandom.c include-dirs: third_party/libuv/include third_party/libuv/src/unix diff --git a/Z/IO/Buffered.hs b/Z/IO/Buffered.hs --- a/Z/IO/Buffered.hs +++ b/Z/IO/Buffered.hs @@ -24,6 +24,7 @@ -- * Buffered Input , BufferedInput , newBufferedInput + , newBufferedInput' , readBuffer , unReadBuffer , readParser @@ -34,6 +35,7 @@ -- * Buffered Output , BufferedOutput , newBufferedOutput + , newBufferedOutput' , writeBuffer , writeBuilder , flushBuffer @@ -117,24 +119,33 @@ , outputBuffer :: {-# UNPACK #-} !(MutablePrimArray RealWorld Word8) } +-- | Open a new buffered input with 'V.defaultChunkSize' as buffer size. +newBufferedInput :: i -> IO (BufferedInput i) +newBufferedInput = newBufferedInput' V.defaultChunkSize + +-- | Open a new buffered output with 'V.defaultChunkSize' as buffer size. +newBufferedOutput :: o -> IO (BufferedOutput o) +newBufferedOutput = newBufferedOutput' V.defaultChunkSize + +-- | Open a new buffered output with given buffer size, e.g. 'V.defaultChunkSize'. +newBufferedOutput' :: Int -- ^ Output buffer size + -> o + -> IO (BufferedOutput o) +newBufferedOutput' bufSiz o = do + index <- newPrimIORef 0 + buf <- newPinnedPrimArray (max bufSiz 0) + return (BufferedOutput o index buf) + -- | Open a new buffered input with given buffer size, e.g. 'V.defaultChunkSize'. -newBufferedInput :: Int -- ^ Input buffer size - -> i - -> IO (BufferedInput i) -newBufferedInput bufSiz i = do +newBufferedInput' :: Int -- ^ Input buffer size + -> i + -> IO (BufferedInput i) +newBufferedInput' bufSiz i = do pb <- newIORef V.empty buf <- newPinnedPrimArray (max bufSiz 0) inputBuffer <- newIORef buf return (BufferedInput i pb inputBuffer) --- | Open a new buffered output with given buffer size, e.g. 'V.defaultChunkSize'. -newBufferedOutput :: Int -- ^ Output buffer size - -> o - -> IO (BufferedOutput o) -newBufferedOutput bufSiz o = do - index <- newPrimIORef 0 - buf <- newPinnedPrimArray (max bufSiz 0) - return (BufferedOutput o index buf) -- | Request bytes from 'BufferedInput'. -- diff --git a/Z/IO/Network/UDP.hs b/Z/IO/Network/UDP.hs --- a/Z/IO/Network/UDP.hs +++ b/Z/IO/Network/UDP.hs @@ -67,7 +67,6 @@ import Foreign.Storable (peek, poke) import Foreign.Ptr (plusPtr) import Foreign.C -import GHC.Prim (touch#) import Z.Data.Array as A import Z.Data.Vector.Base as V import Z.Data.Vector.Extra as V @@ -391,48 +390,48 @@ -> (A.MutablePrimArray RealWorld Word8, A.MutablePrimArray RealWorld (Ptr Word8)) -> Int32 -> IO [(Maybe SocketAddr, Bool, V.Bytes)] -recvUDPWith udp@(UDP hdl slot uvm _ _) ((MutablePrimArray mba#), rbufArr) bufSiz = mask_ $ do - checkUDPClosed udp +recvUDPWith udp@(UDP hdl slot uvm _ _) (rubf, rbufArr) bufSiz = + -- It's important to keep recv buffer alive, even if we don't directly use it + mask_ . withMutablePrimArrayContents rubf $ \ _ -> do + checkUDPClosed udp - rbufArrSiz <- getSizeofMutablePrimArray rbufArr - -- we have to reset the buffer size, during receiving it'll be overwritten - forM_ [0..rbufArrSiz-1] $ \ i -> do - p <- readPrimArray rbufArr i - poke (castPtr p :: Ptr Int32) bufSiz + rbufArrSiz <- getSizeofMutablePrimArray rbufArr + -- we have to reset the buffer size, during receiving it'll be overwritten + forM_ [0..rbufArrSiz-1] $ \ i -> do + p <- readPrimArray rbufArr i + poke (castPtr p :: Ptr Int32) bufSiz - -- reset buffer table's size with buffer array's length, during receiving it'll be decreased - withMutablePrimArrayContents rbufArr $ \ p -> - pokeBufferTable uvm slot (castPtr p) rbufArrSiz + -- reset buffer table's size with buffer array's length, during receiving it'll be decreased + withMutablePrimArrayContents rbufArr $ \ p -> + pokeBufferTable uvm slot (castPtr p) rbufArrSiz - m <- getBlockMVar uvm slot - -- clean up - _ <- tryTakeMVar m + m <- getBlockMVar uvm slot + -- clean up + _ <- tryTakeMVar m - throwUVIfMinus_ $ withUVManager' uvm (hs_uv_udp_recv_start hdl) + throwUVIfMinus_ $ withUVManager' uvm (hs_uv_udp_recv_start hdl) - -- since we are inside mask, this is the only place - -- async exceptions could possibly kick in, and we should stop reading - r <- takeMVar m `onException` (do - -- normally we call 'uv_udp_recv_stop' in C read callback - -- but when exception raise, here's the place to stop - throwUVIfMinus_ $ withUVManager' uvm (uv_udp_recv_stop hdl) - void (tryTakeMVar m)) + -- since we are inside mask, this is the only place + -- async exceptions could possibly kick in, and we should stop reading + r <- takeMVar m `onException` (do + -- normally we call 'uv_udp_recv_stop' in C read callback + -- but when exception raise, here's the place to stop + throwUVIfMinus_ $ withUVManager' uvm (uv_udp_recv_stop hdl) + void (tryTakeMVar m)) - if r < rbufArrSiz - then forM [rbufArrSiz-1, rbufArrSiz-2 .. r] $ \ i -> do - p <- readPrimArray rbufArr i - -- see the buffer struct diagram above - result <- throwUVIfMinus (fromIntegral <$> peek @Int32 (castPtr p)) - flag <- peek @Int32 (castPtr (p `plusPtr` 4)) - addrFlag <- peek @Int32 (castPtr (p `plusPtr` 8)) - !addr <- if addrFlag == 1 - then Just <$> peekSocketAddr (castPtr (p `plusPtr` 12)) - else return Nothing - let !partial = flag .&. UV_UDP_PARTIAL /= 0 - mba <- A.newPrimArray result - copyPtrToMutablePrimArray mba 0 (p `plusPtr` 140) result - ba <- A.unsafeFreezePrimArray mba - -- It's important to keep recv buffer alive - primitive_ (touch# mba#) - return (addr, partial, V.PrimVector ba 0 result) - else return [] + if r < rbufArrSiz + then forM [rbufArrSiz-1, rbufArrSiz-2 .. r] $ \ i -> do + p <- readPrimArray rbufArr i + -- see the buffer struct diagram above + result <- throwUVIfMinus (fromIntegral <$> peek @Int32 (castPtr p)) + flag <- peek @Int32 (castPtr (p `plusPtr` 4)) + addrFlag <- peek @Int32 (castPtr (p `plusPtr` 8)) + !addr <- if addrFlag == 1 + then Just <$> peekSocketAddr (castPtr (p `plusPtr` 12)) + else return Nothing + let !partial = flag .&. UV_UDP_PARTIAL /= 0 + mba <- A.newPrimArray result + copyPtrToMutablePrimArray mba 0 (p `plusPtr` 140) result + ba <- A.unsafeFreezePrimArray mba + return (addr, partial, V.PrimVector ba 0 result) + else return [] diff --git a/Z/IO/StdStream.hs b/Z/IO/StdStream.hs --- a/Z/IO/StdStream.hs +++ b/Z/IO/StdStream.hs @@ -146,21 +146,21 @@ -- | A global buffered stdin stream protected by 'MVar'. stdinBuf :: MVar (BufferedInput StdStream) {-# NOINLINE stdinBuf #-} -stdinBuf = unsafePerformIO (newBufferedInput defaultChunkSize stdin >>= newMVar) +stdinBuf = unsafePerformIO (newBufferedInput stdin >>= newMVar) -- | A global buffered stdout stream protected by 'MVar'. -- -- | If you want to write logs, don't use 'stdoutBuf' directly, use 'Z.IO.Logger' instead. stdoutBuf :: MVar (BufferedOutput StdStream) {-# NOINLINE stdoutBuf #-} -stdoutBuf = unsafePerformIO (newBufferedOutput defaultChunkSize stdout >>= newMVar) +stdoutBuf = unsafePerformIO (newBufferedOutput stdout >>= newMVar) -- | A global buffered stderr stream protected by 'MVar'. -- -- | If you want to write logs, don't use 'stderrBuf' directly, use 'Z.IO.Logger' instead. stderrBuf :: MVar (BufferedOutput StdStream) {-# NOINLINE stderrBuf #-} -stderrBuf = unsafePerformIO (newBufferedOutput defaultChunkSize stderr >>= newMVar) +stderrBuf = unsafePerformIO (newBufferedOutput stderr >>= newMVar) makeStdStream :: HasCallStack => UVFD -> IO StdStream makeStdStream fd = do diff --git a/Z/IO/UV/Manager.hs b/Z/IO/UV/Manager.hs --- a/Z/IO/UV/Manager.hs +++ b/Z/IO/UV/Manager.hs @@ -17,14 +17,14 @@ The main procedures for doing event IO is: * Allocate uv_handle in C side, get its slot number with 'getUVSlot', or allocate uv_request with 'withUVRequest'. - * Prepare you IO buffer with 'pokeBufferTable'(both read and write). + * Prepare you IO buffer with 'pokeBufferTable'(read or write). * Call C side IO functions with predefined callbacks. * Block your thread with the 'MVar' from 'getBlockMVar'. * Read the result by 'takeMVar' on that 'MVar', it will be the value pushed on C side. * Slot is freed on C side, either via callbacks, or when handle is closed. Usually slots are cache in the IO device so that you don't have to allocate new one before each IO operation. -Check "System.IO.Socket.TCP" as an example. +Check "Z.IO.Network.TCP" as an example. -} diff --git a/test/Z/IO/FileSystem/ThreadedSpec.hs b/test/Z/IO/FileSystem/ThreadedSpec.hs --- a/test/Z/IO/FileSystem/ThreadedSpec.hs +++ b/test/Z/IO/FileSystem/ThreadedSpec.hs @@ -39,17 +39,17 @@ it "Opens and writes a file" $ do withResource (initFileT filename flags mode) $ \ file -> do - o <- newBufferedOutput 4096 file + o <- newBufferedOutput' 4096 file writeBuffer o content flushBuffer o withResource (initFileT filename flags mode) $ \ file -> do - i <- newBufferedInput 4096 file + i <- newBufferedInput' 4096 file written <- readExactly size i written @?= content fr <- newFilePtrT file 0 - i <- newBufferedInput 4096 fr + i <- newBufferedInput' 4096 fr written <- readExactly size i written @=? content @@ -57,22 +57,22 @@ it "Opens and writes a file II" $ do withResource (initFileT filename flags mode) $ \ file -> do - o <- newBufferedOutput 4096 file + o <- newBufferedOutput' 4096 file writeBuffer o content2 flushBuffer o withResource (initFileT filename flags mode) $ \ file -> do - i <- newBufferedInput 4096 file + i <- newBufferedInput' 4096 file written <- readExactly size2 i written @=? content2 withResource (initFileT filename flags mode) $ \ file -> do - i <- newBufferedInput 4096 file + i <- newBufferedInput' 4096 file Just firstLine <- readLine i firstLine @=? fst (V.break (== V.c2w '\n') content2) fr <- newFilePtrT file (fromIntegral $ size2 `div` 2) - i <- newBufferedInput 4096 fr + i <- newBufferedInput' 4096 fr replicateM_ 512 $ do Just firstLine <- readLine i firstLine @=? fst (V.break (== V.c2w '\n') content2) diff --git a/test/Z/IO/FileSystemSpec.hs b/test/Z/IO/FileSystemSpec.hs --- a/test/Z/IO/FileSystemSpec.hs +++ b/test/Z/IO/FileSystemSpec.hs @@ -40,17 +40,17 @@ it "Opens and writes a file" $ do withResource (initFile filename flags mode) $ \ file -> do - o <- newBufferedOutput 4096 file + o <- newBufferedOutput' 4096 file writeBuffer o content flushBuffer o withResource (initFile filename flags mode) $ \ file -> do - i <- newBufferedInput 4096 file + i <- newBufferedInput' 4096 file written <- readExactly size i written @?= content fr <- newFilePtr file 0 - i <- newBufferedInput 4096 fr + i <- newBufferedInput' 4096 fr written <- readExactly size i written @=? content @@ -59,22 +59,22 @@ it "Opens and writes a file II" $ do withResource (initFile filename flags mode) $ \ file -> do - o <- newBufferedOutput 4096 file + o <- newBufferedOutput' 4096 file writeBuffer o content2 flushBuffer o withResource (initFile filename flags mode) $ \ file -> do - i <- newBufferedInput 4096 file + i <- newBufferedInput' 4096 file written <- readExactly size2 i written @?= content2 withResource (initFile filename flags mode) $ \ file -> do - i <- newBufferedInput 4096 file + i <- newBufferedInput' 4096 file Just firstLine <- readLine i firstLine @?= fst (V.break (== V.c2w '\n') content2) fr <- newFilePtr file (fromIntegral $ size2 `div` 2) - i <- newBufferedInput 4096 fr + i <- newBufferedInput' 4096 fr replicateM_ 512 $ do Just firstLine <- readLine i firstLine @=? fst (V.break (== V.c2w '\n') content2) diff --git a/test/Z/IO/LowResTimerSpec.hs b/test/Z/IO/LowResTimerSpec.hs --- a/test/Z/IO/LowResTimerSpec.hs +++ b/test/Z/IO/LowResTimerSpec.hs @@ -21,7 +21,7 @@ running <- isLowResTimerManagerRunning lrtm assertEqual "timer manager should start" True running - threadDelay 1500000 -- make sure all timers are fired + threadDelay 1600000 -- make sure all timers are fired c' <- readPrimIORef c assertEqual "timers registration counter" 100000 c' diff --git a/test/Z/IO/Network/TCPSpec.hs b/test/Z/IO/Network/TCPSpec.hs --- a/test/Z/IO/Network/TCPSpec.hs +++ b/test/Z/IO/Network/TCPSpec.hs @@ -27,8 +27,8 @@ serverThread <- forkIO $ startTCPServer defaultTCPServerConfig{ tcpListenAddr = addr , tcpServerWorker = \ tcp -> do - i <- newBufferedInput defaultChunkSize tcp - o <- newBufferedOutput defaultChunkSize tcp + i <- newBufferedInput tcp + o <- newBufferedOutput tcp forever $ readBuffer i >>= writeBuffer o >> flushBuffer o } @@ -36,8 +36,8 @@ replicateM_ 512 . forkIO $ withResource (initTCPClient defaultTCPClientConfig{tcpRemoteAddr = addr}) $ \ tcp -> do - i <- newBufferedInput defaultChunkSize tcp - o <- newBufferedOutput defaultChunkSize tcp + i <- newBufferedInput tcp + o <- newBufferedOutput tcp writeBuffer o testMsg >> flushBuffer o testMsg' <- readExactly' (V.length testMsg) i