feat: Add random message generator.

.github/docker/Dockerfile

@@ -1,8 +1,8 @@
 FROM toxchat/toktok-stack:haskell AS build
 
-RUN ["rm", "-rf", "/work/hs-msgpack-types"]
-COPY --chown=builder:users . /work/hs-msgpack-types
-RUN ["stack", "install", "msgpack-types"]
+RUN ["rm", "-rf", "/work/hs-msgpack-arbitrary"]
+COPY --chown=builder:users . /work/hs-msgpack-arbitrary
+RUN ["stack", "install", "msgpack-arbitrary"]
 
 FROM scratch
 COPY --from=build /home/builder/.local/ /

BUILD.bazel

@@ -9,15 +9,16 @@ haskell_library(
     name = "hs-msgpack-arbitrary",
     srcs = glob(["src/**/*.*hs"]),
     src_strip_prefix = "src",
-    version = "0.1.0",
+    version = "0.1.1",
     visibility = ["//visibility:public"],
     deps = [
         "//hs-msgpack-types",
         hazel_library("QuickCheck"),
         hazel_library("base"),
         hazel_library("bytestring"),
+        hazel_library("quickcheck-instances"),
         hazel_library("text"),
-        hazel_library("vector"),
+        hazel_library("time"),
     ],
 )
 

msgpack-arbitrary.cabal

@@ -1,5 +1,5 @@
 name:                 msgpack-arbitrary
-version:              0.1.0
+version:              0.1.1
 synopsis:             A Haskell implementation of MessagePack.
 homepage:             http://msgpack.org/
 license:              BSD3
@@ -31,13 +31,16 @@ library
       -fno-warn-unused-imports
   exposed-modules:
       Data.MessagePack.Arbitrary
+      Test.MessagePack.Generate
+      Test.QuickCheck.Instances.MessagePack
   build-depends:
       base                      < 5
     , QuickCheck
     , bytestring
     , msgpack-types             >= 0.3 && < 0.4
+    , quickcheck-instances
     , text
-    , vector
+    , time
 
 test-suite testsuite
   type: exitcode-stdio-1.0

src/Data/MessagePack/Arbitrary.hs

@@ -1,28 +1,3 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# LANGUAGE StrictData  #-}
-{-# LANGUAGE Trustworthy #-}
 module Data.MessagePack.Arbitrary () where
 
-import qualified Data.ByteString           as S
-import           Data.MessagePack.Types    (Object (..))
-import qualified Data.Text                 as T
-import qualified Data.Vector               as V
-import           Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
-import qualified Test.QuickCheck.Gen       as Gen
-
-
-instance Arbitrary Object where
-    arbitrary = Gen.sized $ \n -> Gen.oneof
-        [ pure ObjectNil
-        , ObjectBool   <$> arbitrary
-        , ObjectInt    <$> negatives
-        , ObjectWord   <$> arbitrary
-        , ObjectFloat  <$> arbitrary
-        , ObjectDouble <$> arbitrary
-        , ObjectStr    <$> (T.pack <$> arbitrary)
-        , ObjectBin    <$> (S.pack <$> arbitrary)
-        , ObjectArray  <$> (V.fromList <$> Gen.resize (n `div` 2) arbitrary)
-        , ObjectMap    <$> (V.fromList <$> Gen.resize (n `div` 4) arbitrary)
-        , ObjectExt    <$> arbitrary <*> (S.pack <$> arbitrary)
-        ]
-        where negatives = Gen.choose (minBound, -1)
+import           Test.QuickCheck.Instances.MessagePack ()

src/Test/MessagePack/Generate.hs

@@ -0,0 +1,53 @@
+module Test.MessagePack.Generate (generate) where
+
+import           Control.Monad                    (when)
+import qualified Data.ByteString.Lazy             as L
+import           Data.Int                         (Int64)
+import           Data.MessagePack.Arbitrary       ()
+import           Data.MessagePack.Types           (Object (..))
+import           Data.Time.Clock                  (diffUTCTime, getCurrentTime)
+import           System.Environment               (getArgs)
+import           System.IO                        (hPutStr, hPutStrLn, stderr)
+import           Test.QuickCheck.Arbitrary        (arbitrary)
+import qualified Test.QuickCheck.Gen              as Gen
+import           Test.QuickCheck.Instances.Vector ()
+import           Test.QuickCheck.Random           (mkQCGen)
+
+
+seed :: Int
+seed = 33
+
+
+showBytes :: Int64 -> String
+showBytes size
+  | size > 10 * (1024 * 1024) = show (size `div` (1024 * 1024)) <> " MiB"
+  | size > 10 * 1024 = show (size `div` 1024) <> " KiB"
+  | otherwise = show size <> " B"
+
+
+showSpeed :: Int64 -> Double -> String
+showSpeed size time =
+    show (fromIntegral size / (1024 * 1024) / time) <> " MiB/s"
+
+
+generate :: (Object -> L.ByteString) -> IO ()
+generate pack = do
+    size:_ <- (++[30]) . map read <$> getArgs
+
+    start <- getCurrentTime
+    hPutStrLn stderr "Generating sample..."
+
+    let sample@(ObjectArray array) = ObjectArray $ Gen.unGen (Gen.resize size arbitrary) (mkQCGen 0) seed
+    when (sample == sample) $  -- force deep evaluation of the whole structure (kind of deepseq)
+        hPutStr stderr $ "Generated msgpack array of length " <> show (length array)
+    sampleTime <- getCurrentTime
+    hPutStrLn stderr $ " in " <> show (diffUTCTime sampleTime start)
+
+    let packed = pack sample
+    hPutStr stderr $ "Message packed into " <> showBytes (L.length packed)
+    packTime <- getCurrentTime
+    hPutStrLn stderr $ " in " <> show (diffUTCTime packTime sampleTime)
+
+    hPutStrLn stderr $ "Packing speed: " <> showSpeed (L.length packed) (realToFrac (diffUTCTime packTime sampleTime))
+
+    L.putStr packed

src/Test/QuickCheck/Instances/MessagePack.hs

@@ -0,0 +1,29 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE StrictData  #-}
+{-# LANGUAGE Trustworthy #-}
+module Test.QuickCheck.Instances.MessagePack () where
+
+import qualified Data.ByteString                      as S
+import           Data.MessagePack.Types               (Object (..))
+import qualified Data.Text                            as T
+import           Test.QuickCheck.Arbitrary            (Arbitrary, arbitrary)
+import qualified Test.QuickCheck.Gen                  as Gen
+import           Test.QuickCheck.Instances.ByteString ()
+import           Test.QuickCheck.Instances.Vector     ()
+
+
+instance Arbitrary Object where
+    arbitrary = Gen.sized $ \n -> Gen.oneof
+        [ pure ObjectNil
+        , ObjectBool   <$> arbitrary
+        , ObjectInt    <$> negatives
+        , ObjectWord   <$> arbitrary
+        , ObjectFloat  <$> arbitrary
+        , ObjectDouble <$> arbitrary
+        , ObjectStr    <$> (T.pack <$> arbitrary)
+        , ObjectBin    <$> (S.pack <$> arbitrary)
+        , ObjectArray  <$> Gen.resize (n `div` 2) arbitrary
+        , ObjectMap    <$> Gen.resize (n `div` 4) arbitrary
+        , ObjectExt    <$> arbitrary <*> arbitrary
+        ]
+        where negatives = Gen.choose (minBound, -1)