diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,9 +1,20 @@ # Revision history for haskell-candid +## 0.5 -- 2023-10-17 + +* GHC-9.8 compatibility +* Support spec version 0.1.6: + - `composite_query` + https://github.com/dfinity/candid/pull/420 + - `record {} <: record {null}` + https://github.com/dfinity/candid/pull/462 + - space bomb protection + https://github.com/dfinity/candid/pull/434 + ## 0.4.0.2 -- 2023-06-03 * Bump dependencies -* GHC-9.t +* GHC-9.6 ## 0.4.0.1 -- 2023-01-01 diff --git a/candid.cabal b/candid.cabal --- a/candid.cabal +++ b/candid.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: candid -version: 0.4.0.2 +version: 0.5 license: Apache license-file: LICENSE maintainer: mail@joachim-breitner.de @@ -47,41 +47,41 @@ default-language: Haskell2010 ghc-options: -Wall -Wno-name-shadowing build-depends: - base ^>=4.14.3.0 || ^>=4.15.1.0 || ^>=4.16.3.0 || ^>=4.17.0.0 || ^>=4.18.0.0, - text ^>=1.2.4.1 || ^>=2.0.1, + base ^>=4.14.3 || ^>=4.15.1 || ^>=4.16.3 || ^>=4.17.0 || ^>=4.18.1 || ^>=4.19.0, + text ^>=1.2.4 || ^>=2.0.1 || ^>=2.1, dlist ^>=1.0, - vector ^>=0.12.3.1 || ^>=0.13.0.0, - bytestring ^>=0.10.12.0 || ^>=0.11.3.1, + vector ^>=0.12.3 || ^>=0.13.0, + bytestring ^>=0.10.12 || ^>=0.11.3 || ^>=0.12.0, mtl ^>=2.2.2 || ^>=2.3.1, - transformers ^>=0.5.6.2 || ^>=0.6.1.0, - hex-text ^>=0.1.0.7, - crc ^>=0.1.1.1, - megaparsec ^>=9.2.1 || ^>=9.3.1, + transformers ^>=0.5.6 || ^>=0.6.1, + hex-text ^>=0.1.0, + digest ^>=0.0.1, + megaparsec ^>=9.2.1 || ^>=9.3.1 || ^>=9.4.1 || ^>=9.5.0, parser-combinators ^>=1.3.0, - scientific ^>=0.3.7.0, - cereal ^>=0.5.8.3, + scientific ^>=0.3.7, + cereal ^>=0.5.8, leb128-cereal ^>=1.2, - containers ^>=0.6.4.1, - unordered-containers ^>=0.2.19.1, - row-types ^>=1.0.1.2, - constraints ^>=0.13.4, + containers ^>=0.6.4, + unordered-containers ^>=0.2.19, + row-types ^>=1.0.1, + constraints ^>=0.13.4 || ^>=0.14, prettyprinter ^>=1.7.1, - template-haskell ^>=2.16.0.0 || ^>=2.17.0.0 || ^>=2.18.0.0 || ^>=2.19.0.0 || ^>=2.20.0.0, - base32 ^>=0.2.2.0 || ^>=0.3.1.0, - split ^>=0.2.3.5, - file-embed ^>=0.0.15.0 + template-haskell ^>=2.16.0 || ^>=2.17.0 || ^>=2.18.0 || ^>=2.19.0 || ^>=2.20.0 || ^>=2.21.0, + base32 ^>=0.2.2 || ^>=0.3.1, + split ^>=0.2.3, + file-embed ^>=0.0.15 executable hcandid main-is: hcandid.hs default-language: Haskell2010 ghc-options: -Wall -Wno-name-shadowing build-depends: - base ^>=4.14.3.0 || ^>=4.15.1.0 || ^>=4.16.3.0 || ^>=4.17.0.0 || ^>=4.18.0.0, + base ^>=4.14.3 || ^>=4.15.1 || ^>=4.16.3 || ^>=4.17.0 || ^>=4.18.1 || ^>=4.19.0, candid, - optparse-applicative ^>=0.17.0.0 || ^>=0.18.1.0, - text ^>=1.2.4.1 || ^>=2.0.1, - bytestring ^>=0.10.12.0 || ^>=0.11.3.1, - hex-text ^>=0.1.0.7, + optparse-applicative ^>=0.17.1 || ^>=0.18.1, + text ^>=1.2.4 || ^>=2.0.1 || ^>=2.1, + bytestring ^>=0.10.12 || ^>=0.11.3 || ^>=0.12.0, + hex-text ^>=0.1.0, prettyprinter ^>=1.7.1 test-suite test @@ -96,23 +96,23 @@ default-language: Haskell2010 ghc-options: -Wall -Wno-name-shadowing -rtsopts build-depends: - base ^>=4.14.3.0 || ^>=4.15.1.0 || ^>=4.16.3.0 || ^>=4.17.0.0 || ^>=4.18.0.0, - tasty ^>=1.4.3, - tasty-hunit ^>=0.10.0.3, + base ^>=4.14.3 || ^>=4.15.1 || ^>=4.16.3 || ^>=4.17.0 || ^>=4.18.1 || ^>=4.19.0, + tasty ^>=1.4.3 || ^>=1.5, + tasty-hunit ^>=0.10.0, tasty-smallcheck ^>=0.8.2, tasty-quickcheck ^>=0.10.2, tasty-rerun ^>=1.1.18, smallcheck ^>=1.2.1, candid, - bytestring ^>=0.10.12.0 || ^>=0.11.3.1, - text ^>=1.2.4.1 || ^>=2.0.1, - vector ^>=0.12.3.1 || ^>=0.13.0.0, + bytestring ^>=0.10.12 || ^>=0.11.3 || ^>=0.12.0, + text ^>=1.2.4 || ^>=2.0.1 || ^>=2.1, + vector ^>=0.12.3 || ^>=0.13.0, prettyprinter ^>=1.7.1, - unordered-containers ^>=0.2.19.1, - row-types ^>=1.0.1.2, - directory ^>=1.3.6.0, - filepath ^>=1.4.2.1, - template-haskell ^>=2.16.0.0 || ^>=2.17.0.0 || ^>=2.18.0.0 || ^>=2.19.0.0 || ^>=2.20.0.0 + unordered-containers ^>=0.2.19, + row-types ^>=1.0.1, + directory ^>=1.3.6, + filepath ^>=1.4.2, + template-haskell ^>=2.16.0 || ^>=2.17.0 || ^>=2.18.0 || ^>=2.19.0 || ^>=2.20.0 || ^>=2.21.0 test-suite doctest type: exitcode-stdio-1.0 @@ -120,10 +120,10 @@ default-language: Haskell2010 ghc-options: -threaded build-depends: - base ^>=4.14.3.0 || ^>=4.15.1.0 || ^>=4.16.3.0 || ^>=4.17.0.0 || ^>=4.18.0.0, + base ^>=4.14.3 || ^>=4.15.1 || ^>=4.16.3 || ^>=4.17.0 || ^>=4.18.1 || ^>=4.19.0, candid, - doctest ^>=0.20.1 || ^>=0.21.1, - row-types ^>=1.0.1.2, + doctest ^>=0.20.1 || ^>=0.21.1 || ^>=0.22.2, + row-types ^>=1.0.1, leb128-cereal ^>=1.2, prettyprinter ^>=1.7.1 diff --git a/src/Codec/Candid/Class.hs b/src/Codec/Candid/Class.hs --- a/src/Codec/Candid/Class.hs +++ b/src/Codec/Candid/Class.hs @@ -379,6 +379,7 @@ instance Candid a => CandidVal (Vec.Vector a) where asType = VecT (asType' @a) toCandidVal' = VecV . fmap toCandidVal + fromCandidVal' (RepeatV n x) = Vec.replicate n <$> fromCandidVal'' x fromCandidVal' (VecV x) = traverse fromCandidVal'' x fromCandidVal' (BlobV b) = traverse (fromCandidVal'' . Nat8V) $ Vec.fromList $ BS.unpack b fromCandidVal' v = cannotCoerce "vec" v @@ -416,8 +417,8 @@ class Typeable a => CandidMethodType a where asMethodType :: MethodType (Ref TypeRep Type) -instance (CandidArg a, CandidArg b, KnownAnnotation q, KnownAnnotation o) => CandidMethodType (a, b, q, o) where - asMethodType = MethodType (asTypes @(AsTuple a)) (asTypes @(AsTuple b)) (isTrue @q) (isTrue @o) +instance (CandidArg a, CandidArg b, KnownAnnotation q, KnownAnnotation cq, KnownAnnotation o) => CandidMethodType (a, b, q, cq, o) where + asMethodType = MethodType (asTypes @(AsTuple a)) (asTypes @(AsTuple b)) (isTrue @q) (isTrue @cq) (isTrue @o) methodsOfRow :: forall r. Forall r CandidMethodType => [(T.Text, MethodType (Ref TypeRep Type))] methodsOfRow = getConst $ metamorph @_ @r @CandidMethodType @(,) @(Const ()) @(Const [(T.Text, MethodType (Ref TypeRep Type))]) @Proxy Proxy doNil doUncons doCons (Const ()) diff --git a/src/Codec/Candid/Coerce.hs b/src/Codec/Candid/Coerce.hs --- a/src/Codec/Candid/Coerce.hs +++ b/src/Codec/Candid/Coerce.hs @@ -100,6 +100,7 @@ go v EmptyT _ = throwError $ show $ "Unexpected value" <+> pretty v <+> "while coercing empty" -- vec t1 <: vec t2 +go (RepeatV n v) (VecT t1) (VecT t2) = RepeatV n <$> go v t1 t2 go (VecV vs) (VecT t1) (VecT t2) = VecV <$> mapM (\v -> go v t1 t2) vs -- Option: The normal rule @@ -130,7 +131,8 @@ case (M.lookup fn vm, M.lookup fn m1) of (Just v, Just t1) -> go v t1 t2 _ -> case unRef t2 of - OptT _ -> pure (OptV Nothing) + NullT -> pure NullV + OptT _ -> pure (OptV Nothing) ReservedT -> pure ReservedV t -> throwError $ show $ "Missing record field" <+> pretty fn <+> "of type" <+> pretty t @@ -159,6 +161,7 @@ goSeq _ _ [] = pure [] goSeq vs ts1 (RefT (Ref _ t) : ts) = goSeq vs ts1 (t:ts) +goSeq vs@[] ts1@[] (NullT : ts) = (NullV :) <$> goSeq vs ts1 ts goSeq vs@[] ts1@[] (OptT _ : ts) = (OptV Nothing :) <$> goSeq vs ts1 ts goSeq vs@[] ts1@[] (ReservedT : ts) = (ReservedV :) <$> goSeq vs ts1 ts goSeq [] [] ts = throwError $ show $ "Argument type list too short, expecting types" <+> pretty ts diff --git a/src/Codec/Candid/Data.hs b/src/Codec/Candid/Data.hs --- a/src/Codec/Candid/Data.hs +++ b/src/Codec/Candid/Data.hs @@ -10,7 +10,6 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Row.Internal as R -import Data.Digest.CRC import Data.Digest.CRC32 import Data.ByteString.Base32 import Data.List @@ -29,7 +28,7 @@ prettyPrincipal (Principal blob) = T.pack $ intercalate "-" $ chunksOf 5 $ base32 $ checkbytes <> blob where - CRC32 checksum = digest (BS.toStrict blob) + checksum = crc32 (BS.toStrict blob) checkbytes = BS.toLazyByteString (BS.word32BE checksum) base32 = filter (/='=') . T.unpack . T.toLower . encodeBase32 . BS.toStrict @@ -48,6 +47,6 @@ newtype ServiceRef (r :: R.Row Type) = ServiceRef { rawServiceRef :: Principal } deriving (Eq, Ord, Show) -data FuncRef r = FuncRef { service :: Principal, method :: T.Text } +data FuncRef (r :: Type) = FuncRef { service :: Principal, method :: T.Text } deriving (Eq, Ord, Show) diff --git a/src/Codec/Candid/Decode.hs b/src/Codec/Candid/Decode.hs --- a/src/Codec/Candid/Decode.hs +++ b/src/Codec/Candid/Decode.hs @@ -1,6 +1,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE NumericUnderscores #-} module Codec.Candid.Decode where @@ -31,6 +32,9 @@ decodeMagic arg_tys <- decodeTypTable vs <- mapM decodeVal (tieKnot (voidEmptyTypes arg_tys)) + let n = sum (countZeroSizeVectors <$> vs) + when (n > 2_000_000) $ do + fail $ "Message contains " ++ show n ++ " zero sized values in a vector, exceeding the limit of 2_000_000" G.remaining >>= \case 0 -> return (arg_tys, vs) n -> fail $ "Unexpected " ++ show n ++ " left-over bytes" @@ -62,7 +66,9 @@ decodeVal BlobT = BlobV <$> decodeBytes decodeVal (VecT t) = do n <- getLEB128Int - VecV . V.fromList <$> replicateM n (decodeVal t) + case decodeZeroBytes t of + Just v ->pure $ RepeatV n v + Nothing -> VecV . V.fromList <$> replicateM n (decodeVal t) decodeVal (RecT fs) | isTuple = TupV <$> mapM (\(_,t) -> decodeVal t) fs' | otherwise = RecV <$> mapM (\(fn, t) -> (fn,) <$> decodeVal t) fs' @@ -167,7 +173,7 @@ -22 -> do a <- decodeSeq (decodeTypRef max) r <- decodeSeq (decodeTypRef max) - m <- decodeFoldSeq decodeFuncAnn (MethodType a r False False) + m <- decodeFoldSeq decodeFuncAnn (MethodType a r False False False) return $ Left (FuncT m) -23 -> do m <- decodeSeq ((,) <$> decodeText <*> decodeFuncTypRef max) @@ -220,6 +226,9 @@ 2 -> do when (methOneway m) $ fail "oneway annotation duplicated" return (m { methOneway = True }) + 3 -> do + when (methCompQuery m) $ fail "composite_query annotation duplicated" + return (m { methCompQuery = True }) _ -> fail "invalid function annotation" @@ -240,3 +249,31 @@ h <- getLEB128 t <- decodeTypRef max return (hashedField h, t) + +decodeZeroBytes :: Type a -> Maybe Value +decodeZeroBytes ReservedT = Just ReservedV +decodeZeroBytes NullT = Just NullV +decodeZeroBytes (RecT fs) = RecV <$> mapM (\(fn, t) -> (fn,) <$> decodeZeroBytes t) fs' + where + fs' = sortOn fst fs +decodeZeroBytes _ = Nothing + +{- +isZeroSizedValue :: Value -> Bool +isZeroSizedValue ReservedV = True +isZeroSizedValue NullV = True +isZeroSizedValue (RecV fs) = all (isZeroSizedValue . snd) fs +isZeroSizedValue (TupV vs) = all isZeroSizedValue vs +isZeroSizedValue _ = False +-} + +countZeroSizeVectors :: Value -> Int +countZeroSizeVectors (RepeatV n _) = n +countZeroSizeVectors (VecV vs) = sum (countZeroSizeVectors <$> vs) +countZeroSizeVectors (RecV fs) = sum (countZeroSizeVectors . snd <$> fs) +countZeroSizeVectors (TupV vs) = sum (countZeroSizeVectors <$> vs) +countZeroSizeVectors (VariantV _ v) = countZeroSizeVectors v +countZeroSizeVectors (OptV (Just v)) = countZeroSizeVectors v +countZeroSizeVectors (AnnV v _) = countZeroSizeVectors v +countZeroSizeVectors _ = 0 + diff --git a/src/Codec/Candid/Encode.hs b/src/Codec/Candid/Encode.hs --- a/src/Codec/Candid/Encode.hs +++ b/src/Codec/Candid/Encode.hs @@ -195,7 +195,7 @@ RefT t -> go (m M.! t) - goMethod (MethodType as bs q o) = do + goMethod (MethodType as bs q cq o) = do ais <- mapM go as bis <- mapM go bs return $ mconcat @@ -209,7 +209,8 @@ ] where anns = [buildLEB128 @Natural 1 | q] ++ - [buildLEB128 @Natural 2 | o] + [buildLEB128 @Natural 2 | o] ++ + [buildLEB128 @Natural 3 | cq] goField :: (FieldName, Type k) -> TypTableBuilder k (FieldName, Integer) goField (fn, t) = do diff --git a/src/Codec/Candid/Hash.hs b/src/Codec/Candid/Hash.hs --- a/src/Codec/Candid/Hash.hs +++ b/src/Codec/Candid/Hash.hs @@ -58,7 +58,7 @@ -- Word list obtained from https://github.com/dwyl/english-words wordFile :: T.Text -wordFile = $(embedStringFile "words.txt") +wordFile = $(makeRelativeToProject "words.txt" >>= embedStringFile) m :: M.IntMap T.Text m = M.fromList [ (fromIntegral (candidHash w), w) | w <- word_list ] diff --git a/src/Codec/Candid/Infer.hs b/src/Codec/Candid/Infer.hs --- a/src/Codec/Candid/Infer.hs +++ b/src/Codec/Candid/Infer.hs @@ -33,13 +33,14 @@ inferTyp ReservedV = return ReservedT inferTyp (OptV Nothing) = return $ OptT EmptyT inferTyp (OptV (Just v)) = OptT <$> inferTyp v +inferTyp (RepeatV _ v) = VecT <$> inferTyp v inferTyp (VecV vs) = VecT <$> (mapM inferTyp (V.toList vs) >>= lubs) inferTyp (RecV fs) = RecT <$> sequence [ (fn,) <$> inferTyp t | (fn, t) <- fs ] inferTyp (VariantV f v) = do t <- inferTyp v return $ VariantT [ (f, t) ] inferTyp (TupV vs) = tupT <$> mapM inferTyp vs -inferTyp (FuncV _ _) = return (FuncT (MethodType [] [] False False)) -- no principal type +inferTyp (FuncV _ _) = return (FuncT (MethodType [] [] False False False)) -- no principal type inferTyp (ServiceV _) = return (ServiceT []) -- no principal type inferTyp (PrincipalV _) = return PrincipalT inferTyp FutureV = return FutureT diff --git a/src/Codec/Candid/Parse.hs b/src/Codec/Candid/Parse.hs --- a/src/Codec/Candid/Parse.hs +++ b/src/Codec/Candid/Parse.hs @@ -91,10 +91,11 @@ ts1 <- seqP s "->" ts2 <- seqP - (q,o) <- runPermutation $ - (,) <$> toPermutationWithDefault False (True <$ s "query") - <*> toPermutationWithDefault False (True <$ s "oneway") - return $ MethodType ts1 ts2 q o + (q,cq,o) <- runPermutation $ + (,,) <$> toPermutationWithDefault False (True <$ s "query") + <*> toPermutationWithDefault False (True <$ s "composite_query") + <*> toPermutationWithDefault False (True <$ s "oneway") + return $ MethodType ts1 ts2 q cq o nameP :: Parser T.Text nameP = textP <|> idP "name" diff --git a/src/Codec/Candid/Subtype.hs b/src/Codec/Candid/Subtype.hs --- a/src/Codec/Candid/Subtype.hs +++ b/src/Codec/Candid/Subtype.hs @@ -122,7 +122,8 @@ -- Check missing fields sequence_ [ case unRef t of - OptT _ -> pure () + NullT -> pure () + OptT _ -> pure () ReservedT -> pure () t -> throwError $ show $ "Missing record field" <+> pretty fn <+> "of type" <+> pretty t | (fn, t) <- M.toList $ m2 M.\\ m1 @@ -162,16 +163,18 @@ MethodType (Ref k1 Type) -> MethodType (Ref k2 Type) -> SubTypeM k1 k2 () -goMethodType (MethodType ta1 tr1 q1 o1) (MethodType ta2 tr2 q2 o2) = do +goMethodType (MethodType ta1 tr1 q1 cq1 o1) (MethodType ta2 tr2 q2 cq2 o2) = do unless (q1 == q2) $ throwError "Methods differ in query annotation" unless (o1 == o2) $ throwError "Methods differ in oneway annotation" + unless (cq1 == cq2) $ throwError "Methods differ in oneway annotation" flipM $ goSeq ta2 ta1 goSeq tr1 tr2 goSeq _ [] = pure () goSeq ts1 (RefT (Ref _ t) : ts) = goSeq ts1 (t:ts) -- Missing optional arguments are ok -goSeq ts1@[] (OptT _ : ts) = goSeq ts1 ts +goSeq ts1@[] (NullT : ts) = goSeq ts1 ts +goSeq ts1@[] (OptT _ : ts) = goSeq ts1 ts goSeq ts1@[] (ReservedT : ts) = goSeq ts1 ts goSeq [] ts = throwError $ show $ "Argument type list too short, expecting types" <+> pretty ts goSeq (t1:ts1) (t2:ts2) = memo t1 t2 >> goSeq ts1 ts2 diff --git a/src/Codec/Candid/TH.hs b/src/Codec/Candid/TH.hs --- a/src/Codec/Candid/TH.hs +++ b/src/Codec/Candid/TH.hs @@ -195,8 +195,8 @@ methodName f = litT (strTyLit (T.unpack f)) methodType :: MethodType TH.Name -> TypeQ -methodType (MethodType a b q o) = - [t| ($(candidTypeQ a), $(candidTypeQ b), $(ann q), $(ann o)) |] +methodType (MethodType a b q cq o) = + [t| ($(candidTypeQ a), $(candidTypeQ b), $(ann q), $(ann cq), $(ann o)) |] where ann True = [t|AnnTrue|] ann False = [t|AnnFalse|] diff --git a/src/Codec/Candid/Types.hs b/src/Codec/Candid/Types.hs --- a/src/Codec/Candid/Types.hs +++ b/src/Codec/Candid/Types.hs @@ -86,8 +86,8 @@ RefT x >>= f = f x bindMethodType :: (a -> Type b) -> MethodType a -> MethodType b -bindMethodType f (MethodType as bs q ow) = - MethodType (map (>>= f) as) (map (>>= f) bs) q ow +bindMethodType f (MethodType as bs q cq ow) = + MethodType (map (>>= f) as) (map (>>= f) bs) q cq ow type Fields a = [(FieldName, Type a)] @@ -155,6 +155,7 @@ | NullV | ReservedV | OptV (Maybe Value) + | RepeatV Int Value -- for space bomb protection | VecV (V.Vector Value) | RecV [(FieldName, Value)] | TupV [Value] @@ -193,6 +194,9 @@ pretty (BlobV b) = "blob" <+> prettyBlob b pretty (OptV Nothing) = pretty NullV pretty (OptV (Just v)) = "opt" <+> pretty v + pretty (RepeatV n v) + | n < 20 = pretty (VecV (V.replicate n v)) + | otherwise = "vec" <+> prettyBraceSemi [pretty v, "…"] pretty (VecV vs) = "vec" <+> prettyBraceSemi (map pretty (V.toList vs)) pretty (TupV vs) = "record" <+> prettyBraceSemi (map pretty vs) pretty (RecV vs) = "record" <+> prettyBraceSemi (map go vs) @@ -263,6 +267,7 @@ { methParams :: [Type a] , methResults :: [Type a] , methQuery :: Bool + , methCompQuery :: Bool , methOneway :: Bool } deriving (Eq, Ord, Show, Functor, Foldable, Traversable) @@ -276,12 +281,13 @@ deriving (Eq, Show) instance Pretty a => Pretty (MethodType a) where - pretty (MethodType params results q o) = sep $ + pretty (MethodType params results q cq o) = sep $ [ pretty params , "->" , pretty results ] <> [ "query" | q ] <> + [ "composite_query" | cq ] <> [ "oneway" | o ] prettyDef :: Pretty a => DidDef a -> Doc ann diff --git a/test/Tests.hs b/test/Tests.hs --- a/test/Tests.hs +++ b/test/Tests.hs @@ -200,9 +200,9 @@ , mkTest (Proxy @SimpleRecord) , mkTest (Proxy @(Rec ("a" .== Bool .+ "b" .== Bool .+ "c" .== Bool))) , mkTest (Proxy @(V.Var ("upgrade" .== () .+ "reinstall" .== () .+ "install" .== ()))) - , mkTest (Proxy @(FuncRef (Bool, T.Text, AnnFalse, AnnFalse))) - , mkTest (Proxy @(FuncRef (Bool, T.Text, AnnTrue, AnnFalse))) - , mkTest (Proxy @(FuncRef (Bool, T.Text, AnnFalse, AnnTrue))) + , mkTest (Proxy @(FuncRef (Bool, T.Text, AnnFalse, AnnFalse, AnnFalse))) + , mkTest (Proxy @(FuncRef (Bool, T.Text, AnnTrue, AnnFalse, AnnFalse))) + , mkTest (Proxy @(FuncRef (Bool, T.Text, AnnFalse, AnnFalse, AnnTrue))) , mkTest (Proxy @(ServiceRef Empty)) ] @@ -286,10 +286,11 @@ , printTestType @Word8 "nat8" , printTestType @SimpleRecord "record {bar : nat8; foo : bool}" , printTestType @(JustRight T.Text) "variant {Right : text}" - , printTestType @(FuncRef (Bool, Unary (), AnnTrue, AnnFalse)) "func (bool) -> (null) query" - , printTestType @(FuncRef (Bool, T.Text, AnnFalse, AnnTrue)) "func (bool) -> (text) oneway" + , printTestType @(FuncRef (Bool, Unary (), AnnTrue, AnnFalse, AnnFalse)) "func (bool) -> (null) query" + , printTestType @(FuncRef (Bool, T.Text, AnnFalse, AnnFalse, AnnTrue)) "func (bool) -> (text) oneway" + , printTestType @(FuncRef (Bool, T.Text, AnnFalse, AnnTrue, AnnFalse)) "func (bool) -> (text) composite_query" , printTestType @(ServiceRef Empty) "service : {}" - , printTestType @(ServiceRef ("foo" .== (Bool, T.Text, AnnFalse, AnnTrue) .+ "bar" .== ((),(),AnnFalse, AnnFalse))) + , printTestType @(ServiceRef ("foo" .== (Bool, T.Text, AnnFalse, AnnFalse, AnnTrue) .+ "bar" .== ((),(),AnnFalse, AnnFalse, AnnFalse))) "service : {bar : () -> (); foo : (bool) -> (text) oneway;}" , printTestSeq @() "()" , printTestSeq @(Unary ()) "(null)" @@ -364,11 +365,11 @@ , t "blob \"hello\"" ("hello" :: BS.ByteString) , t "blob \"\\00\\ff\"" ("\x00\xff" :: BS.ByteString) , t "func \"psokg-ww6vw-7o6\".\"foo\"" - (FuncRef @((), (), AnnFalse, AnnFalse) (Principal "\xde\xad\xbe\xef") "foo") + (FuncRef @((), (), AnnFalse, AnnFalse, AnnFalse) (Principal "\xde\xad\xbe\xef") "foo") , t "func \"psokg-ww6vw-7o6\".foo" - (FuncRef @((), (), AnnFalse, AnnFalse) (Principal "\xde\xad\xbe\xef") "foo") + (FuncRef @((), (), AnnFalse, AnnFalse, AnnFalse) (Principal "\xde\xad\xbe\xef") "foo") , t "func \"psokg-ww6vw-7o6\".\"\"" - (FuncRef @((), (), AnnFalse, AnnFalse) (Principal "\xde\xad\xbe\xef") "") + (FuncRef @((), (), AnnFalse, AnnFalse, AnnFalse) (Principal "\xde\xad\xbe\xef") "") , t "service \"psokg-ww6vw-7o6\"" (ServiceRef @Empty (Principal "\xde\xad\xbe\xef")) , t "principal \"psokg-ww6vw-7o6\"" @@ -381,31 +382,35 @@ [ parseTest "service : {}" $ DidFile [] [] , parseTest "service : { foo : (text) -> (text) }" $ - DidFile [] [("foo", MethodType [TextT] [TextT] False False)] + DidFile [] [("foo", MethodType [TextT] [TextT] False False False)] , parseTest "service : { foo : (text,) -> (text,); }" $ - DidFile [] [("foo", MethodType [TextT] [TextT] False False)] + DidFile [] [("foo", MethodType [TextT] [TextT] False False False)] , parseTest "service : { foo : (x : text,) -> (y : text,); }" $ - DidFile [] [("foo", MethodType [TextT] [TextT] False False)] + DidFile [] [("foo", MethodType [TextT] [TextT] False False False)] , parseTest "service : { foo : (opt text) -> () }" $ - DidFile [] [("foo", MethodType [OptT TextT] [] False False) ] + DidFile [] [("foo", MethodType [OptT TextT] [] False False False) ] , parseTest "service : { foo : (record { text; blob }) -> () }" $ - DidFile [] [("foo", MethodType [RecT [(hashedField 0, TextT), (hashedField 1, BlobT)]] [] False False) ] + DidFile [] [("foo", MethodType [RecT [(hashedField 0, TextT), (hashedField 1, BlobT)]] [] False False False) ] , parseTest "service : { foo : (record { x_ : null; 5 : nat8 }) -> () }" $ - DidFile [] [("foo", MethodType [RecT [("x_", NullT), (hashedField 5, Nat8T)]] [] False False) ] + DidFile [] [("foo", MethodType [RecT [("x_", NullT), (hashedField 5, Nat8T)]] [] False False False) ] , parseTest "service : { foo : (record { x : null; 5 : nat8 }) -> () }" $ - DidFile [] [("foo", MethodType [RecT [("x", NullT), (hashedField 5, Nat8T)]] [] False False) ] + DidFile [] [("foo", MethodType [RecT [("x", NullT), (hashedField 5, Nat8T)]] [] False False False) ] , parseTest "service : { foo : (text) -> (text) query }" $ - DidFile [] [("foo", MethodType [TextT] [TextT] True False)] + DidFile [] [("foo", MethodType [TextT] [TextT] True False False)] , parseTest "service : { foo : (text) -> (text) oneway }" $ - DidFile [] [("foo", MethodType [TextT] [TextT] False True)] + DidFile [] [("foo", MethodType [TextT] [TextT] False False True)] + , parseTest "service : { foo : (text) -> (text) composite_query }" $ + DidFile [] [("foo", MethodType [TextT] [TextT] False True False)] , parseTest "service : { foo : (text) -> (text) query oneway }" $ - DidFile [] [("foo", MethodType [TextT] [TextT] True True)] + DidFile [] [("foo", MethodType [TextT] [TextT] True False True)] , parseTest "service : { foo : (text) -> (text) oneway query }" $ - DidFile [] [("foo", MethodType [TextT] [TextT] True True)] + DidFile [] [("foo", MethodType [TextT] [TextT] True False True)] + , parseTest "service : { foo : (text) -> (text) oneway composite_query }" $ + DidFile [] [("foo", MethodType [TextT] [TextT] False True True)] , parseTest "service : (opt SomeInit) -> { foo : (text) -> (text) oneway query }" $ - DidFile [] [("foo", MethodType [TextT] [TextT] True True)] + DidFile [] [("foo", MethodType [TextT] [TextT] True False True)] , parseTest "type t = int; service : { foo : (t) -> (t) }" $ - DidFile [("t", IntT)] [("foo", MethodType [RefT "t"] [RefT "t"] False False)] + DidFile [("t", IntT)] [("foo", MethodType [RefT "t"] [RefT "t"] False False False)] ] , testProperty "field name escaping round-tripping" $ \e -> let f = either labledField hashedField e in