From d38b45f788de8fa8783b1fd5010e7dd9bb28b0fe Mon Sep 17 00:00:00 2001
From: Alexander Vershilov <alexander.vershilov@moduscreate.com>
Date: Thu, 18 Dec 2025 19:22:10 +0100
Subject: [PATCH] Drop assumption that passed bytes are pinned

Apply a fix that in case of unpinned bytes passed in hPutBuffer
we first create a pinned ByteArray and copy bytes there
---
 mempack-scls/mempack-1.0/Data/MemPack/Extra.hs | 12 ++++++++++--
 mempack-scls/mempack-2.0/Data/MemPack/Extra.hs | 15 ++++++++++++---
 2 files changed, 22 insertions(+), 5 deletions(-)

diff --git a/mempack-scls/mempack-1.0/Data/MemPack/Extra.hs b/mempack-scls/mempack-1.0/Data/MemPack/Extra.hs
index 9feaa2d..44b8ad2 100644
--- a/mempack-scls/mempack-1.0/Data/MemPack/Extra.hs
+++ b/mempack-scls/mempack-1.0/Data/MemPack/Extra.hs
@@ -38,6 +38,7 @@ import Data.ByteString.Lazy qualified as BSL
 import Data.MemPack
 import Data.MemPack.Buffer
 import Data.MemPack.Error
+import Data.Primitive.ByteArray
 import Data.Primitive.Ptr
 import Data.String (IsString)
 import Data.Text qualified as T
@@ -240,12 +241,19 @@ hPutBuffer handle u =
   buffer
     u
     ( \bytes -> do
-        withForeignPtr (pinnedByteArrayToForeignPtr bytes) $ \ptr -> do
+        pinnedBytes <- pinIfNeeded (ByteArray bytes)
+        withForeignPtr (byteArrayAsForeignPtr pinnedBytes) $ \ptr -> do
           hPutBuf handle ptr len
     )
-    (\addr -> hPutBuf handle (Ptr addr) len) -- Write Ptr#
+    (\addr -> hPutBuf handle (Ptr addr) len)
  where
   len = bufferByteCount u
+  pinIfNeeded bytes
+    | isByteArrayPinned bytes = return bytes
+    | otherwise = do
+        dest <- newPinnedByteArray len
+        copyByteArray dest 0 bytes 0 len
+        unsafeFreezeByteArray dest
 
 runDecode :: (IsString e) => Fail e a -> Either e a
 runDecode f = runFailLast f
diff --git a/mempack-scls/mempack-2.0/Data/MemPack/Extra.hs b/mempack-scls/mempack-2.0/Data/MemPack/Extra.hs
index a51ae60..0d295b7 100644
--- a/mempack-scls/mempack-2.0/Data/MemPack/Extra.hs
+++ b/mempack-scls/mempack-2.0/Data/MemPack/Extra.hs
@@ -39,6 +39,7 @@ import Data.ByteString.Lazy qualified as BSL
 import Data.MemPack
 import Data.MemPack.Buffer
 import Data.MemPack.Error
+import Data.Primitive.ByteArray
 import Data.Primitive.Ptr
 import Data.Text qualified as T
 import Data.Typeable
@@ -245,12 +246,20 @@ hPutBuffer handle u =
   buffer
     u
     ( \bytes off -> do
-        withForeignPtr (pinnedByteArrayToForeignPtr bytes) $ \ptr -> do
-          hPutBuf handle (ptr `plusPtr` (I# off)) (len - (I# off))
+        (pinnedBytes, offset) <- pinIfNeeded (ByteArray bytes) (I# off)
+        withForeignPtr (byteArrayAsForeignPtr pinnedBytes) $ \ptr -> do
+          hPutBuf handle (ptr `plusPtr` offset) (len - offset)
     )
-    (\addr -> hPutBuf handle (Ptr addr) len) -- Write Ptr#
+    (\addr -> hPutBuf handle (Ptr addr) len)
  where
   len = bufferByteCount u
+  pinIfNeeded bytes off
+    | isByteArrayPinned bytes = return (bytes, off)
+    | otherwise = do
+        let l = len - off
+        dest <- newPinnedByteArray l
+        copyByteArray dest 0 bytes off l
+        (,0) <$> unsafeFreezeByteArray dest
 
 runDecode :: (IsString e) => (forall s. FailT e (ST s) a) -> Either e a
 runDecode f = runST (runFailLastT f)