diff --git a/Graphics/Sudbury/CABI/Client.hs b/Graphics/Sudbury/CABI/Client.hs index e54882b..c6bad69 100644 --- a/Graphics/Sudbury/CABI/Client.hs +++ b/Graphics/Sudbury/CABI/Client.hs @@ -26,6 +26,7 @@ import Foreign.Storable import System.Posix.Types (Fd(..)) import Network.Socket (fdSocket) import Data.Attoparsec.ByteString +import qualified Data.Store as S import System.IO.Unsafe import Graphics.Sudbury.Argument @@ -944,11 +945,11 @@ display_read_events proxyP = withStablePtr proxyP $ \proxy -> do fd_queue <- newTQueueIO atomically $ mapM_ (writeTQueue fd_queue) fds - let pkgsParse = parseOnly pkgStream bytes + let pkgsParse = (decodeMany bytes :: Either S.PeekException [WirePackage]) pkgs <- case pkgsParse of Left err -> - error ("Package parse failed: " ++ err) + error ("Package parse failed: " ++ show err) Right x -> return x mapM_ (queue_package dd fd_queue) pkgs diff --git a/Graphics/Sudbury/WireMessages.hs b/Graphics/Sudbury/WireMessages.hs index 3e61e0f..6d5b8fe 100644 --- a/Graphics/Sudbury/WireMessages.hs +++ b/Graphics/Sudbury/WireMessages.hs @@ -6,7 +6,6 @@ License : MIT Maintainer : auke@tulcod.com Stability : experimental -} -{-# LANGUAGE Safe #-} module Graphics.Sudbury.WireMessages where import Data.Fixed diff --git a/Graphics/Sudbury/WirePackages.hs b/Graphics/Sudbury/WirePackages.hs index 4e2ab8d..d3d9635 100644 --- a/Graphics/Sudbury/WirePackages.hs +++ b/Graphics/Sudbury/WirePackages.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-| Module : Graphics.Sudbury.WirePackages Description : Reads ByteStrings into packages containing individual messages @@ -7,56 +8,128 @@ Maintainer : auke@tulcod.com Stability : experimental Portability : POSIX -} -{-# LANGUAGE Safe #-} module Graphics.Sudbury.WirePackages where import Data.Word -import Data.Monoid ((<>)) +import Data.Monoid +import Data.Store +import Data.Foldable +import Data.Store.Core +import Data.Store.Internal import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as B import qualified Data.ByteString.Builder as BB -import qualified Data.ByteString.Builder.Extra as BBE -import qualified Data.Attoparsec.ByteString as A +import System.IO.Unsafe (unsafePerformIO) + + +import Control.Monad +import Foreign.Ptr (minusPtr, plusPtr, Ptr) +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, castForeignPtr) + +import Control.Exception (Exception(..), throwIO, try) + + -import Graphics.Sudbury.Internal data WirePackage = WirePackage { wirePackageSender :: Word32 , wirePackageSize :: Word16 , wirePackageOpcode :: Word16 , wirePackagePayload :: B.ByteString + } deriving (Eq) + +instance Show WirePackage where + show (WirePackage se sz op pl) = "Sender: " ++ show se ++ "\nSize: " ++ show sz ++ "\nOp: " ++ show op + +-- | Storable that writes in the Wayland binary format. +-- Allows us to use the optimized machinery from Data.Store +instance Store WirePackage where + size = VarSize $ \x -> let sz = fromIntegral (wirePackageSize x) in sz + (sz `mod` 4) + poke p = do + poke $ wirePackageSender p + poke $ wirePackageOpcode p + poke $ wirePackageSize p + let (sourceFp, sourceOffset, sourceLength) = B.toForeignPtr $ wirePackagePayload p + pokeFromForeignPtr sourceFp sourceOffset sourceLength + pokeAlign p + where + {-# INLINE pokeAlign #-} + pokeAlign wp = let align = fromIntegral $ wirePackageSize wp `mod` 4 + emptyByte = 0 :: Word8 -- Maybe skipPoke would be better + in replicateM_ align (poke emptyByte) + peek = do + sen <- peek + op <- peek + sz <- peek + let payloadSize = fromIntegral sz - 8 + plraw <- peekToPlainForeignPtr "Data.ByteString.ByteString" payloadSize + let pl = B.PS plraw 0 payloadSize + skip $ fromIntegral sz `mod` 4 + return $ WirePackage + { wirePackageSender = sen + , wirePackageSize = sz + , wirePackageOpcode = op + , wirePackagePayload = pl + } + {-# INLINE size #-} + {-# INLINE peek #-} + {-# INLINE poke #-} + +-- | Newtype wrapper around a list of WirePackages is +-- necessary to write the correct amount of pad bytes +-- and to account for non-prepending of list length +newtype WirePackageStream = WirePackageStream + { unWirePackageStream :: [WirePackage] } deriving (Eq, Show) --- | Construct a wayland wire wirePackage +-- | Storable instance for a number of Wayland wirepackages +-- that accounts for padding and deserializing. +instance Store WirePackageStream where + size = VarSize $ getSum . foldMap (Sum . f) . unWirePackageStream + where + VarSize f = size :: Size WirePackage + + poke = traverse_ poke . unWirePackageStream + + peek = undefined + {-# INLINE size #-} + {-# INLINE peek #-} + {-# INLINE poke #-} + +decodeMany :: Store a => B.ByteString -> Either PeekException [a] +decodeMany = unsafePerformIO . try . decodeIOMany + +decodeIOMany :: Store a => B.ByteString -> IO [a] +decodeIOMany = decodeIOWithMany peek + +decodeIOWithMany :: Peek a -> B.ByteString -> IO [a] +decodeIOWithMany mypeek (B.PS x s len) = + withForeignPtr x $ \ptr0 -> + let ptr = ptr0 `plusPtr` s + in decodeIOWithFromPtrMany mypeek ptr len +{-# INLINE decodeIOWithMany #-} + +decodeIOWithFromPtrMany :: Peek a -> Ptr Word8 -> Int -> IO [a] +decodeIOWithFromPtrMany !mypeek !ptr !len = do + if len == 0 + then return [] + else do + (offset, x) <- decodeIOPortionWithFromPtr mypeek ptr len + liftM2' (:) (return x) $ decodeIOWithFromPtrMany mypeek (ptr `plusPtr` offset) (len - offset) + --throwIO $ PeekException (len - offset) "Didn't consume all input." +{-# INLINE decodeIOWithFromPtrMany #-} + +-- | A version of 'liftM2' that is strict in the result of its first +-- action. +liftM2' :: (Monad m) => (a -> b -> c) -> m a -> m b -> m c +liftM2' f a b = do + !x <- a + y <- b + return (f x y) +{-# INLINE liftM2' #-} + + wirePack :: WirePackage -> BB.Builder -wirePack msg = wirePackBuilder - (wirePackageSender msg) - (wirePackageSize msg) - (wirePackageOpcode msg) - (BB.byteString $ wirePackagePayload msg) - --- | Construct a wayland wire wirePackage with payload given as a 'Builder'. -wirePackBuilder :: Word32 -> Word16 -> Word16 -> BB.Builder -> BB.Builder -wirePackBuilder sender size opcode payload = - BBE.word32Host sender - <> - -- FIXME make byte order portable here - BBE.word16Host opcode - <> - BBE.word16Host size - <> - payload - -parseWirePackage :: A.Parser WirePackage -parseWirePackage = do - sender <- anyWord32he - opcode <- anyWord16he - size <- anyWord16he - payload <- A.take (fromIntegral size - 8) - return WirePackage { wirePackageSender = sender - , wirePackageSize = size - , wirePackageOpcode = opcode - , wirePackagePayload = payload - } - -pkgStream :: A.Parser [WirePackage] -pkgStream = A.many' parseWirePackage +wirePack = BB.byteString . encode + + diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 index 0000000..18d8ce0 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +module Main where + +import Criterion.Main +import GHC.Generics +import Graphics.Sudbury.WirePackages +import qualified Test.QuickCheck as Q +import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as B +import qualified Data.ByteString.Builder as BB +import Data.Store +import Data.Store.Core +import Data.ByteString.Builder (toLazyByteString) +import Data.ByteString.Lazy (toStrict) +import qualified Data.Attoparsec.ByteString as A + + +import Control.DeepSeq +import Debug.Trace +import Control.Monad + +import Data.Fixed +import Data.Word +import Data.Int +import Data.Bits +import qualified Data.ByteString as B +import qualified Data.Attoparsec.ByteString as A +import qualified Data.Attoparsec.Binary as AB +import System.Endian (getSystemEndianness, Endianness(..)) + +data WL23_8 +instance HasResolution WL23_8 where + resolution _ = 256 -- 2^8 +-- Duplicate from tests/Arbitrary.hs. Should think of a better +-- solution in due time + +instance Q.Arbitrary B.ByteString where + arbitrary = do + someBytes <- Q.arbitrary + return . toStrict . toLazyByteString . mconcat $ map BB.word8 someBytes + +instance Q.Arbitrary WirePackage where + arbitrary = Q.sized $ \ n -> do + sender <- Q.arbitrary + opcode <- Q.arbitrary + payload <- Q.arbitrary + let size = fromIntegral $ 8 + B.length payload + return WirePackage + { wirePackageSender = sender + , wirePackageSize = size + , wirePackageOpcode = opcode + , wirePackagePayload = payload + } + +instance Q.Arbitrary WirePackageStream where + arbitrary = Q.sized $ \ n -> + do k <- Q.choose (1000, 1000) + WirePackageStream <$> replicateM k Q.arbitrary + + +-- | Newtype wrapper for the binary format of Wayland. Allows +-- us to construct arbitrary messages from n WirePackages with +-- the required padded bytes. +newtype WirePackageBinary = WirePackageBinary + { unWpBin :: B.ByteString + } deriving (Eq) + +instance Show WirePackageBinary where + show = show . B.unpack . unWpBin + + +instance Q.Arbitrary WirePackageBinary where + arbitrary = Q.sized $ \ n -> + do k <- Q.choose (1000, 1000) + WirePackageBinary . B.concat <$> replicateM k genAlignedWp + where + genAlignedWp :: Q.Gen B.ByteString + genAlignedWp = encode <$> (Q.arbitrary :: Q.Gen WirePackage) +deriving instance Generic WirePackageStream +instance NFData WirePackageStream + +parseWirePackage :: A.Parser WirePackage +parseWirePackage = do + sender <- anyWord32he + opcode <- anyWord16he + size <- anyWord16he + payload <- A.take (fromIntegral size - 8) + let offset = fromIntegral size `mod` 4 + A.take offset + return WirePackage { wirePackageSender = sender + , wirePackageSize = size + , wirePackageOpcode = opcode + , wirePackagePayload = payload + } + +pkgStream' :: A.Parser [WirePackage] +pkgStream' = A.many' parseWirePackage + + +randomWirePackage :: IO [WirePackageStream] +randomWirePackage = Q.generate $ Q.vectorOf 100 (Q.arbitrary :: Q.Gen WirePackageStream) + +randomByteString :: IO [B.ByteString] +randomByteString = Q.generate $ fmap unWpBin <$> Q.vectorOf 100 (Q.arbitrary :: Q.Gen WirePackageBinary) + +decodeAttos :: B.ByteString -> [WirePackage] +decodeAttos = unsafeRight . A.parseOnly (A.many' parseWirePackage) + +unsafeRight (Right a) = a + +encodeBS :: WirePackageStream -> B.ByteString +encodeBS = toStrict . toLazyByteString . foldMap wirePack . unWirePackageStream + + +ensureDecodersEqual = do + rb <- randomByteString + let decode' :: B.ByteString -> [WirePackage] + decode' = fromRight . decodeMany + wp1 = map decode' rb + wp2 = map decodeAttos rb + res = zipWith (\x y -> if x == y then (True, x, y) else (False, x, y)) wp1 wp2 + return $ filter (\(x, _, _) -> x == False) res + + + +fromRight (Right a) = a +fromRight (Left a) = error $ show a + +deriving instance Generic WirePackage +instance NFData WirePackage + +main = do + rb <- randomByteString + rw <- randomWirePackage + rb `deepseq` return () + rw `deepseq` return () + let decode' :: B.ByteString -> [WirePackage] + decode' = fromRight . decodeMany + + defaultMain + [ bgroup "parse_random" + [ bench "id" $ nf (map id) rb + , bench "storeable" $ nf (map decode') rb + , bench "attoParsec1" $ nf (map decodeAttos) rb + ] + , bgroup "encod_random" + [ bench "id" $ nf (map id) rw + , bench "storeable" $ nf (map encode) rw + , bench "BS.Builder" $ nf (map encodeBS) rw + ] + ] + + +-- | Fixed-precision number: 23 bits of integer space, 8 bits precision +type Fixed23_8 = Fixed WL23_8 + +anyWord16he :: A.Parser Word16 +anyWord16he = case getSystemEndianness of + LittleEndian -> AB.anyWord16le + BigEndian -> AB.anyWord16be + +anyWord32he :: A.Parser Word32 +anyWord32he = case getSystemEndianness of + LittleEndian -> AB.anyWord32le + BigEndian -> AB.anyWord32be + + +-- Inspired by `anyWordN` from attoparsec-binary + +packNumBytes :: (FiniteBits a, Num a) => B.ByteString -> a +packNumBytes = B.foldl' (\n h -> (n `shiftL` 8) .|. fromIntegral h) 0 + +anyIntN :: (FiniteBits a, Num a) => (B.ByteString -> a) -> A.Parser a +anyIntN = anyIntN' 0 + where byteSize :: (FiniteBits a) => a -> Int + byteSize = (`div` 8) . finiteBitSize + anyIntN' :: (FiniteBits a) => a -> (B.ByteString -> a) -> A.Parser a + anyIntN' d = flip fmap $ A.take $ byteSize d + +anyInt16be :: A.Parser Int16 +anyInt16be = anyIntN packNumBytes +anyInt16le :: A.Parser Int16 +anyInt16le = anyIntN $ packNumBytes . B.reverse +anyInt32be :: A.Parser Int32 +anyInt32be = anyIntN packNumBytes +anyInt32le :: A.Parser Int32 +anyInt32le = anyIntN $ packNumBytes . B.reverse + +-- End of attoparsec-binary inspiration + +anyInt16he :: A.Parser Int16 +anyInt16he = case getSystemEndianness of + LittleEndian -> anyInt16le + BigEndian -> anyInt16be + +anyInt32he :: A.Parser Int32 +anyInt32he = case getSystemEndianness of + LittleEndian -> anyInt32le + BigEndian -> anyInt32be + +data ServerClient = Server | Client diff --git a/sudbury.cabal b/sudbury.cabal index ebf60b8..9c8a328 100644 --- a/sudbury.cabal +++ b/sudbury.cabal @@ -46,6 +46,8 @@ library , bytestring >=0.9 && <1 , attoparsec >=0.13 && <1 , attoparsec-binary >=0.2 && <1 + , store + , store-core , cpu >=0.1 && <1 , singletons >=2 && <3 , template-haskell >=2.11 && <3 @@ -65,7 +67,7 @@ library ghc-options: -Wall -fwarn-incomplete-record-updates -fwarn-unused-do-bind foreign-library wayland-client - lib-version-info: 3:0:3 + --lib-version-info: 3:0:3 type: native-shared other-modules: Graphics.Sudbury.CABI.Client @@ -85,6 +87,8 @@ foreign-library wayland-client , bytestring >=0.9 && <1 , attoparsec >=0.13 && <1 , attoparsec-binary >=0.2 && <1 + , store + , store-core , cpu >=0.1 && <1 , singletons >=2 && <3 , template-haskell >=2.11 && <3 @@ -108,6 +112,24 @@ foreign-library wayland-client default-language: Haskell2010 ghc-options: -Wall -fwarn-incomplete-record-updates -fwarn-unused-do-bind +benchmark serial-bench-bench + hs-source-dirs: bench + type: exitcode-stdio-1.0 + main-is: Main.hs + ghc-options: -rtsopts -O2 + build-depends: base + , sudbury + , criterion + , QuickCheck + , deepseq + , bytestring + , attoparsec + , attoparsec-binary + , cpu + , store + , store-core + default-language: Haskell2010 + test-suite tests hs-source-dirs: tests main-is: Main.hs @@ -122,6 +144,7 @@ test-suite tests , test-framework , test-framework-quickcheck2 , attoparsec - , bytestring + , bytestring + , store ghc-options: -Wall default-language: Haskell2010 diff --git a/tests/Arbitrary.hs b/tests/Arbitrary.hs index df154ca..5757cbe 100644 --- a/tests/Arbitrary.hs +++ b/tests/Arbitrary.hs @@ -6,13 +6,17 @@ and not force any dependency on QuickCheck. This module should only be used in the test code of this project. -} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Arbitrary where import qualified Data.ByteString as B import qualified Data.ByteString.Builder as BB +import Control.Monad import Data.ByteString.Builder (toLazyByteString) import Data.ByteString.Lazy (toStrict) import Test.QuickCheck +import qualified Data.Store as S +import Data.Word import Graphics.Sudbury.WirePackages @@ -33,3 +37,26 @@ instance Arbitrary WirePackage where , wirePackageOpcode = opcode , wirePackagePayload = payload } + +instance Arbitrary WirePackageStream where + arbitrary = WirePackageStream <$> arbitrary + +-- | Newtype wrapper for the binary format of Wayland. Allows +-- us to construct arbitrary messages from n WirePackages with +-- the required padded bytes. +newtype WirePackageBinary = WirePackageBinary + { unWpBin :: B.ByteString + } deriving (Eq) + +instance Show WirePackageBinary where + show = show . B.unpack . unWpBin + + +instance Arbitrary WirePackageBinary where + arbitrary = sized $ \ n -> + do k <- choose (0, n) + WirePackageBinary . B.concat <$> replicateM k genAlignedWp + where + genAlignedWp :: Gen B.ByteString + genAlignedWp = S.encode <$> (arbitrary :: Gen WirePackage) + diff --git a/tests/Wire.hs b/tests/Wire.hs index 776162c..a87d7d4 100644 --- a/tests/Wire.hs +++ b/tests/Wire.hs @@ -1,24 +1,38 @@ module Wire where -import qualified Data.Attoparsec.ByteString as AB -import qualified Data.ByteString as B -import Data.ByteString.Builder (toLazyByteString) -import Data.ByteString.Lazy (toStrict) - import Test.Framework import Test.Framework.Providers.QuickCheck2 (testProperty) import Test.QuickCheck +import qualified Data.Store as S +import qualified Data.ByteString as B import Graphics.Sudbury.WirePackages -import Arbitrary () +import Arbitrary tests :: Test tests = testGroup "Wire protocol transformations" [ testProperty "wire packages identity" prop_package_id + , testProperty "wire stream encoding identity" prop_package_stream_id + , testProperty "wire stream decoding identity" prop_package_binary_id ] + +unsafeRight :: (Show a) => Either a b -> b +unsafeRight (Right a) = a +unsafeRight (Left a) = error $ show a -- | Test if packing and then parsing a 'WirePackage' yields the original package. prop_package_id :: WirePackage -> Property -prop_package_id pkg = Just True === AB.compareResults (AB.Done B.empty pkg) - (AB.parse parseWirePackage . toStrict . toLazyByteString . wirePack $ pkg) +prop_package_id = (===) <*> (S.decodeEx . S.encode) + +prop_package_stream_id :: WirePackageStream -> Property +prop_package_stream_id = (===) <*> (decode' . S.encode ) + where + decode' :: B.ByteString -> WirePackageStream + decode' = WirePackageStream . unsafeRight . decodeMany + +prop_package_binary_id :: WirePackageBinary -> Property +prop_package_binary_id = (===) <*> (WirePackageBinary . S.encode . decode' . unWpBin) + where + decode' :: B.ByteString -> WirePackageStream + decode' = WirePackageStream . unsafeRight . decodeMany