@@ -453,7 +453,7 @@ import qualified Data.ByteString.Lazy as BSL
453import Data.Typeable (Typeable)
453import Data.Typeable (Typeable)
454import Data.Foldable (forM_)
454import Data.Foldable (forM_)
455import Control.Applicative ((<$>), (<*>))
455import Control.Applicative ((<$>), (<*>))
456−import Control.Monad (void)
456+import Control.Monad (void, when)
457import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, ask)
457import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, ask)
458import Control.Exception
458import Control.Exception
459 ( Exception
459 ( Exception
@@ -764,12 +764,18 @@ localSend x = LocalProcess $ do
764-- | Wait for a message from the remote process (see 'ProcessPair').
764-- | Wait for a message from the remote process (see 'ProcessPair').
765-- Note that unlike for the standard Cloud Haskell 'expect' it will result in a
765-- Note that unlike for the standard Cloud Haskell 'expect' it will result in a
766-- runtime error if the remote process sends a message of type other than @a@.
766-- runtime error if the remote process sends a message of type other than @a@.
768+-- Since it is relatively easy for the remote process to mess up the
769+-- communication protocol (for instance, by doing a putStr) we ask for the
770+-- length twice, as some sort of sanity check.
767localExpect :: Serializable a => LocalProcess a
771localExpect :: Serializable a => LocalProcess a
768localExpect = LocalProcess $ do
772localExpect = LocalProcess $ do
769 ch <- ask
773 ch <- ask
770 liftIO $ do
774 liftIO $ do
771 isE <- readIntChannel ch
775 isE <- readIntChannel ch
772 len <- readIntChannel ch
776 len <- readIntChannel ch
777+ lenAgain <- readIntChannel ch
778+ when (len /= lenAgain) $ throwIO (userError "Protocol violation")
773 msg <- readSizeChannel ch len
779 msg <- readSizeChannel ch len
774 if isE /= 0
780 if isE /= 0
775 then error (decode msg)
781 then error (decode msg)
@@ -794,6 +800,8 @@ remoteSendFlagged :: Serializable a => Int -> a -> IO ()
794remoteSendFlagged flags x = do
800remoteSendFlagged flags x = do
795 let enc = encode x
801 let enc = encode x
796 BSS.hPut stdout (encodeInt32 flags)
802 BSS.hPut stdout (encodeInt32 flags)
803+ -- See 'localExpect' for why we send the length twice
804+ BSS.hPut stdout (encodeInt32 (BSL.length enc))
797 BSS.hPut stdout (encodeInt32 (BSL.length enc))
805 BSS.hPut stdout (encodeInt32 (BSL.length enc))
798 BSL.hPut stdout enc
806 BSL.hPut stdout enc
799 hFlush stdout
807 hFlush stdout