Parsing using the Storable (Data.Store)

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
 

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

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
+
+