capnp-0.10.0.0: tests/Module/Capnp/Untyped.hs
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- The tests have a number of cases where we do stuff like:
--
-- let 4 = ...
--
-- Letting pattern-match failure fail the test. GHC warns about this,
-- let's shut off that warning:
{-# OPTIONS_GHC -Wno-unused-pattern-binds #-}
module Module.Capnp.Untyped (untypedTests) where
import Prelude hiding (length)
import Test.Hspec
import Control.Monad (forM_, when)
import Control.Monad.Primitive (RealWorld)
import Data.Foldable (traverse_)
import Data.Text (Text)
import GHC.Float (castDoubleToWord64, castWord64ToDouble)
import Test.QuickCheck (property)
import Test.QuickCheck.IO (propertyIO)
import Text.Heredoc (here)
import qualified Data.ByteString as BS
import qualified Data.Vector as V
import Capnp.Untyped
import Util
import Capnp (cerialize, createPure, def, getRoot, newRoot)
import Capnp.TraversalLimit (LimitT, evalLimitT, execLimitT)
import Data.Mutable (Thaw (..))
import Instances ()
import Capnp.Gen.Capnp.Schema.Pure (Brand, Method (..), Node'Parameter)
import qualified Capnp.Classes as C
import qualified Capnp.Message as M
import qualified Capnp.Gen.Capnp.Schema as Schema
untypedTests :: Spec
untypedTests = describe "low-level untyped API tests" $ do
readTests
modifyTests
farPtrTest
otherMessageTest
readTests :: Spec
readTests = describe "read tests" $
it "Should agree with `capnp decode`" $ do
msg <- encodeValue
aircraftSchemaSrc
"Aircraft"
[here|(f16 = (base = (
name = "bob",
homes = [],
rating = 7,
canFly = true,
capacity = 5173,
maxSpeed = 12.0
)))|]
endQuota <- execLimitT 128 $ do
root <- rootPtr msg
-- Aircraft just has the union tag, nothing else in it's data
-- section.
let 1 = structWordCount root
3 <- getData 0 root -- tag for F16
let 1 = structPtrCount root
Just (PtrStruct f16) <- getPtr 0 root
let 0 = structWordCount f16
let 0 = structByteCount f16
let 1 = structPtrCount f16
Just (PtrStruct base) <- getPtr 0 f16
let 4 = structWordCount base -- Except canFly, each field is 1 word, and
-- canFly is aligned such that it ends up
-- consuming a whole word.
let 32 = structByteCount base -- 32 = 4 * 8
let 2 = structPtrCount base -- name, homes
-- Walk the data section:
7 <- getData 0 base -- rating
1 <- getData 1 base -- canFly
5173 <- getData 2 base -- capacity
12.0 <- castWord64ToDouble <$> getData 3 base
-- ...and the pointer section:
Just (PtrList (List8 name)) <- getPtr 0 base
-- Text values have a NUL terminator, which is included in the
-- length on the wire. The spec says that this shouldn't be
-- included in the length reported to the caller, but that needs
-- to be dealt with by schema-aware code, so this is the length of
-- "bob\0"
let 4 = length name
forM_ (zip [0..3] (BS.unpack "bob\0")) $ \(i, c) -> do
c' <- index i name
when (c /= c') $
error ("index " ++ show i ++ ": " ++ show c ++ " /= " ++ show c')
Just (PtrList (List16 homes)) <- getPtr 1 base
let 0 = length homes
return ()
endQuota `shouldBe` 110
data ModTest s = ModTest
{ testIn :: String
, testMod :: Struct ('M.Mut RealWorld) -> LimitT IO ()
, testOut :: String
, testType :: String
}
modifyTests :: Spec
modifyTests = describe "modification tests" $ traverse_ testCase
-- tests for setIndex
[ ModTest
{ testIn = "(year = 2018, month = 6, day = 20)\n"
, testType = "Zdate"
, testOut = "(year = 0, month = 0, day = 0)\n"
, testMod = setData 0 0
}
, ModTest
{ testIn = "(text = \"Hello, World!\")\n"
, testType = "Z"
, testOut = "(text = \"hEllo, world!\")\n"
, testMod = \struct -> do
Just (PtrList (List8 list)) <- getPtr 0 struct
setIndex (fromIntegral (fromEnum 'h')) 0 list
setIndex (fromIntegral (fromEnum 'E')) 1 list
setIndex (fromIntegral (fromEnum 'w')) 7 list
}
, ModTest
{ testIn = "(boolvec = [true, true, false, true])\n"
, testType = "Z"
, testOut = "( boolvec = [false, true, true, false] )\n"
, testMod = \struct -> do
Just (PtrList (List1 list)) <- getPtr 0 struct
setIndex False 0 list
setIndex True 2 list
setIndex False 3 list
}
, ModTest
{ testIn = "(f64 = 2.0)\n"
, testType = "Z"
, testOut = "(f64 = 7.2)\n"
, testMod = setData (castDoubleToWord64 7.2) 1
}
, ModTest
{ testIn = unlines
[ "( size = 4,"
, " words = \"Hello, World!\","
, " wordlist = [\"apples\", \"oranges\"] )"
]
, testType = "Counter"
, testOut = unlines
[ "( size = 4,"
, " words = \"oranges\","
, " wordlist = [\"apples\", \"Hello, World!\"] )"
]
, testMod = \struct -> do
Just (PtrList (ListPtr list)) <- getPtr 1 struct
helloWorld <- getPtr 0 struct
oranges <- index 1 list
setPtr oranges 0 struct
setIndex helloWorld 1 list
}
, ModTest
{ testIn = unlines
[ "( aircraftvec = ["
, " ( f16 = ("
, " base = ("
, " name = \"alice\","
, " homes = [],"
, " rating = 7,"
, " canFly = true,"
, " capacity = 4,"
, " maxSpeed = 100 ) ) ),"
, " ( b737 = ("
, " base = ("
, " name = \"bob\","
, " homes = [],"
, " rating = 2,"
, " canFly = false,"
, " capacity = 9,"
, " maxSpeed = 50 ) ) ) ] )"
]
, testType = "Z"
, testOut = unlines
[ "( aircraftvec = ["
, " ( f16 = ("
, " base = ("
, " name = \"alice\","
, " homes = [],"
, " rating = 7,"
, " canFly = true,"
, " capacity = 4,"
, " maxSpeed = 100 ) ) ),"
, " ( f16 = ("
, " base = ("
, " name = \"alice\","
, " homes = [],"
, " rating = 7,"
, " canFly = true,"
, " capacity = 4,"
, " maxSpeed = 100 ) ) ) ] )"
]
, testMod = \struct -> do
Just (PtrList (ListStruct list)) <- getPtr 0 struct
src <- index 0 list
setIndex src 1 list
}
-- tests for allocation functions
, ModTest
{ testIn = "()"
, testType = "StackingRoot"
, testOut = "( aWithDefault = (num = 6400),\n a = (num = 65, b = (num = 90000)) )\n"
, testMod = \struct -> do
when (structPtrCount struct /= 2) $
error "struct's pointer section is unexpedly small"
let msg = message struct
a <- allocStruct msg 1 1
aWithDefault <- allocStruct msg 1 1
b <- allocStruct msg 1 0
setPtr (Just (PtrStruct b)) 0 a
setPtr (Just (PtrStruct aWithDefault)) 0 struct
setPtr (Just (PtrStruct a)) 1 struct
setData 65 0 a
setData 6400 0 aWithDefault
setData 90000 0 b
}
, ModTest
{ testIn = "()"
, testType = "HoldsVerTwoTwoList"
, testOut = "( mylist = [(val = 0, duo = 70), (val = 0, duo = 71), (val = 0, duo = 72), (val = 0, duo = 73)] )\n"
, testMod = \struct -> do
mylist <- allocCompositeList (message struct) 2 2 4
forM_ [0..3] $ \i ->
index i mylist >>= setData (70 + fromIntegral i) 1
setPtr (Just $ PtrList $ ListStruct mylist) 0 struct
}
, allocNormalListTest "u64vec" 21 allocList64 List64
, allocNormalListTest "u32vec" 22 allocList32 List32
, allocNormalListTest "u16vec" 23 allocList16 List16
, allocNormalListTest "u8vec" 24 allocList8 List8
, ModTest
{ testIn = "()"
, testType = "Z"
, testOut = "( boolvec = [true, false, true] )\n"
, testMod = \struct -> do
setData 39 0 struct -- Set the union tag.
boolvec <- allocList1 (message struct) 3
forM_ [0..2] $ \i ->
setIndex (even i) i boolvec
setPtr (Just $ PtrList $ List1 boolvec) 0 struct
}
]
where
-- generate a ModTest for a (normal) list allocation function.
--
-- parameters:
--
-- * tagname - the name of the union variant
-- * tagvalue - the numeric value of the tag for this variant
-- * allocList - the allocation function
-- * dataCon - the data constructor for 'List' to use.
allocNormalListTest tagname tagvalue allocList dataCon =
ModTest
{ testIn = "()"
, testType = "Z"
, testOut = "(" ++ tagname ++ " = [0, 1, 2, 3, 4])\n"
, testMod = \struct -> do
setData tagvalue 0 struct
vec <- allocList (message struct) 5
forM_ [0..4] $ \i -> setIndex (fromIntegral i) i vec
setPtr (Just $ PtrList $ dataCon vec) 0 struct
}
testCase ModTest{..} =
it ("Should satisfy: " ++ show testIn ++ " : " ++ testType ++ " == " ++ show testOut) $ do
msg <- thaw =<< encodeValue aircraftSchemaSrc testType testIn
evalLimitT 128 $ rootPtr msg >>= testMod
actualOut <- decodeValue aircraftSchemaSrc testType =<< freeze msg
actualOut `shouldBe` testOut
farPtrTest :: Spec
farPtrTest = describe "Setting cross-segment pointers shouldn't crash" $ do
-- I(zenhack) am disappointed in hindsight that we only check for crashes
-- here; we should make these more thorough, actually checking validity
-- somehow.
it "Should work when setting the root pointer" $ do
pure () :: IO () -- Not sure why ghc needs this hint, but it does.
msg <- M.newMessage Nothing
-- The allocator always allocates new objects in the last segment, so
-- if we create a new segment, the call to allocStruct below should
-- allocate there:
(1, _) <- M.newSegment msg 16
struct <- allocStruct msg 3 4
setRoot struct :: IO ()
it "Should work when setting a field in a struct" $ do
pure () :: IO () -- Not sure why ghc needs this hint, but it does.
evalLimitT maxBound $ do
msg <- M.newMessage Nothing
srcStruct <- allocStruct msg 4 4
(1, _) <- M.newSegment msg 10
dstStruct <- allocStruct msg 2 2
ptr <- C.toPtr msg dstStruct
setPtr ptr 0 srcStruct
otherMessageTest :: Spec
otherMessageTest = describe "Setting pointers in other messages" $
it "Should copy them if needed." $
property $ \(name :: Text) (params :: V.Vector Node'Parameter) (brand :: Brand) ->
propertyIO $ do
let expected = def
{ name = name
, implicitParameters = params
, paramBrand = brand
}
msg :: M.Message 'M.Const <- createPure maxBound $ do
methodMsg <- M.newMessage Nothing
nameMsg <- M.newMessage Nothing
paramsMsg <- M.newMessage Nothing
brandMsg <- M.newMessage Nothing
methodCerial <- newRoot methodMsg
nameCerial <- cerialize nameMsg name
brandCerial <- cerialize brandMsg brand
-- We don't implement Cerialize for Vector, so we can't just
-- inject params directly. TODO: implement Cerialize for Vector.
wrapper <- cerialize paramsMsg expected
paramsCerial <- Schema.get_Method'implicitParameters wrapper
Schema.set_Method'name methodCerial nameCerial
Schema.set_Method'implicitParameters methodCerial paramsCerial
Schema.set_Method'paramBrand methodCerial brandCerial
pure methodMsg
actual <- evalLimitT maxBound $ getRoot msg >>= C.decerialize
actual `shouldBe` expected