diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,18 @@ +0.5.0.0 (2023-08-07) +===================== + +- (**Breaking**) Transport: + `cGetSome` no longer takes an int parameter. + Implementations should return all available bytes (blocking if necessary) + or an empty string for EOF. (#54) +- (**Breaking**) Transport: + `cPut` accepts a `Builder `instead of a `ByteString`. + Implementations should use `runBuilder` to turn it into a `ByteString` + if needed. (#55) +- Add a `Pinch.Transport.Builder` module exporting the `Builder` type; + a length-aware `ByteString` builder. (#55) + + 0.4.3.0 (2023-04-27) ===================== diff --git a/pinch.cabal b/pinch.cabal --- a/pinch.cabal +++ b/pinch.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: pinch -version: 0.4.3.0 +version: 0.5.0.0 synopsis: An alternative implementation of Thrift for Haskell. description: This library provides machinery for types to specify how they can be serialized and deserialized into/from Thrift payloads. It makes no @@ -63,6 +63,7 @@ Pinch.Protocol.Compact Pinch.Server Pinch.Transport + Pinch.Transport.Builder other-modules: Pinch.Internal.Bits Pinch.Internal.Pinchable.Parser diff --git a/src/Pinch/Internal/Builder.hs b/src/Pinch/Internal/Builder.hs --- a/src/Pinch/Internal/Builder.hs +++ b/src/Pinch/Internal/Builder.hs @@ -13,6 +13,7 @@ module Pinch.Internal.Builder ( Builder , runBuilder + , unsafeRunBuilder , append , int8 @@ -47,6 +48,12 @@ runBuilder :: Builder -> ByteString runBuilder (B size fill) = BI.unsafeCreate size fill {-# INLINE runBuilder #-} + +-- | Fill a buffer with the bytes of a builder. The buffer is assumed +-- to be big enough to hold the contents of the entire builder. +unsafeRunBuilder :: Builder -> Ptr Word8 -> IO () +unsafeRunBuilder (B _size fill) = fill +{-# INLINE unsafeRunBuilder #-} -- | Append two Builders into one. append :: Builder -> Builder -> Builder diff --git a/src/Pinch/Transport.hs b/src/Pinch/Transport.hs --- a/src/Pinch/Transport.hs +++ b/src/Pinch/Transport.hs @@ -19,18 +19,18 @@ import qualified Pinch.Internal.Builder as B class Connection c where - -- | Gets up to n bytes. Returns an empty bytestring if EOF is reached. - cGetSome :: c -> Int -> IO BS.ByteString - -- | Writes the given bytestring. - cPut :: c -> BS.ByteString -> IO () + -- | Returns available bytes, or an empty bytestring if EOF was reached. + cGetSome :: c -> IO BS.ByteString + -- | Writes the given builder. + cPut :: c -> B.Builder -> IO () instance Connection Handle where - cPut = BS.hPut - cGetSome = BS.hGetSome + cPut c b = BS.hPut c (B.runBuilder b) + cGetSome h = BS.hGetSome h 1024 instance Connection Socket where - cPut = sendAll - cGetSome s n = recv s (min n 4096) + cPut c b = sendAll c (B.runBuilder b) + cGetSome s = recv s 4096 data ReadResult a = RRSuccess a @@ -47,28 +47,21 @@ -- | Creates a thrift framed transport. See also . framedTransport :: Connection c => c -> IO Transport -framedTransport c = pure $ Transport writeMsg readMsg where +framedTransport c = do + readBuffer <- newIORef mempty + pure $ Transport writeMsg (readMsg readBuffer) where writeMsg msg = do - cPut c $ B.runBuilder $ B.int32BE (fromIntegral $ B.getSize msg) - cPut c $ B.runBuilder msg - - readMsg p = do - szBs <- getExactly c 4 - if BS.length szBs < 4 - then - pure $ RREOF - else do - let sz = fromIntegral <$> G.runGet G.getInt32be szBs - case sz of - Right x -> do - msgBs <- getExactly c x - pure $ if BS.length msgBs < x - then - -- less data has been returned than expected. This means we have reached EOF. - RREOF - else - either RRFailure RRSuccess $ G.runGet p msgBs - Left s -> pure $ RRFailure $ "Invalid frame size: " ++ show s + cPut c $ B.int32BE (fromIntegral $ B.getSize msg) <> msg + readMsg readBuffer parser = do + let + frameParser = do + size <- G.getInt32be + G.isolate (fromIntegral size) parser + + initial <- readIORef readBuffer + (leftovers, r) <- runGetWith (cGetSome c) frameParser initial + writeIORef readBuffer $! leftovers + pure r -- | Creates a thrift unframed transport. See also . unframedTransport :: Connection c => c -> IO Transport @@ -80,15 +73,13 @@ readBuffer <- newIORef mempty pure $ Transport writeMsg (readMsg readBuffer) where - writeMsg msg = cPut c $ B.runBuilder msg + writeMsg = cPut c readMsg buf p = do - bs <- readIORef buf - bs' <- if BS.null bs then getSome else pure bs - (leftOvers, r) <- runGetWith getSome p bs' - writeIORef buf leftOvers - pure $ r - getSome = cGetSome c 1024 + initial <- readIORef buf + (leftovers, r) <- runGetWith (cGetSome c) p initial + writeIORef buf $! leftovers + pure r -- | Runs a Get parser incrementally, reading more input as necessary until a successful parse -- has been achieved. @@ -108,17 +99,3 @@ pure (bs, RREOF) else go $ cont bs - --- | Gets exactly n bytes. If EOF is reached, an empty string is returned. -getExactly :: Connection c => c -> Int -> IO BS.ByteString -getExactly c sz = B.runBuilder <$> go sz mempty - where - go :: Int -> B.Builder -> IO B.Builder - go n b = do - bs <- cGetSome c n - let b' = b <> B.byteString bs - case BS.length bs of - -- EOF, return what data we might have gotten so far - 0 -> pure mempty - n' | n' < n -> go (n - n') b' - _ | otherwise -> pure b' diff --git a/src/Pinch/Transport/Builder.hs b/src/Pinch/Transport/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Pinch/Transport/Builder.hs @@ -0,0 +1,17 @@ +-- | +-- Module : Pinch.Transport.Builder +-- Copyright : (c) Abhinav Gupta 2023 +-- License : BSD3 +-- +-- Maintainer : Abhinav Gupta +-- Stability : experimental +-- +-- This module implements a ByteString builder very similar to +-- 'Data.ByteString.Builder' except that it keeps track of its final serialized +-- length. This allows it to allocate the target ByteString in one @malloc@ and +-- simply write the bytes to it. +module Pinch.Transport.Builder + ( module B + ) where + +import Pinch.Internal.Builder as B diff --git a/tests/Pinch/TransportSpec.hs b/tests/Pinch/TransportSpec.hs --- a/tests/Pinch/TransportSpec.hs +++ b/tests/Pinch/TransportSpec.hs @@ -29,13 +29,13 @@ mGetContents = readIORef . contents instance Connection MemoryConnection where - cGetSome (MemoryConnection ref ch) n = do + cGetSome (MemoryConnection ref ch) = do bytes <- readIORef ref - let (left, right) = BS.splitAt (min ch n) bytes + let (left, right) = BS.splitAt ch bytes writeIORef ref right return left - cPut (MemoryConnection ref _) newBytes = do - modifyIORef ref (<> newBytes) + cPut (MemoryConnection ref _) builder = do + modifyIORef ref (<> B.runBuilder builder) transportSpec :: (forall c . Connection c => c -> IO Transport) -> Spec transportSpec t = do @@ -63,8 +63,8 @@ let payload = BS.pack [0x01, 0x05, 0x01, 0x08, 0xFF] buf <- newMemoryConnection 1 transp <- framedTransport buf - cPut buf $ BS.pack [0x00, 0x00, 0x00, 0x05] - cPut buf payload + cPut buf $ B.byteString (BS.pack [0x00, 0x00, 0x00, 0x05]) + cPut buf $ B.byteString payload r <- readMessage transp (G.getBytes $ BS.length payload) r `shouldBe` RRSuccess payload @@ -84,7 +84,7 @@ ioProperty $ do buf <- newMemoryConnection 1 transp <- unframedTransport buf - cPut buf payload + cPut buf $ B.byteString payload r <- readMessage transp (G.getBytes $ BS.length payload) pure $ r === RRSuccess payload