scale cycle cost of http_request calls based on subnet size (#123)

Co-authored-by: Martin Raszyk <martin.raszyk@dfinity.org>

src/IC/Constants.hs

@@ -14,6 +14,13 @@ import IC.Types
 cDEFAULT_PROVISIONAL_CYCLES_BALANCE :: Natural
 cDEFAULT_PROVISIONAL_CYCLES_BALANCE = 100_000_000_000_000
 
+-- Subnets
+
+-- reference_subnet_size is used for scaling cycle cost
+-- and must never be set to zero!
+reference_subnet_size :: W.Word64
+reference_subnet_size = 13
+
 -- Canister http_request limits
 max_request_bytes_limit :: W.Word64
 max_request_bytes_limit = 2_000_000

src/IC/Ref.hs

@@ -197,6 +197,8 @@ data Message
 
 -- Finally, the full IC state:
 
+type Subnet = (EntityId, SubnetType, W.Word64, SecretKey, [(W.Word64, W.Word64)])
+
 data IC = IC
   { canisters :: CanisterId ↦ CanState
   , requests :: RequestID ↦ (CallRequest, (RequestStatus, CanisterId))
@@ -205,7 +207,7 @@ data IC = IC
   , rng :: StdGen
   , secretRootKey :: SecretKey
   , rootSubnet :: Maybe EntityId
-  , subnets :: [(EntityId, SubnetType, SecretKey, [(W.Word64, W.Word64)])]
+  , subnets :: [Subnet]
   }
   deriving (Show)
 
@@ -219,7 +221,7 @@ initialIC subnets = do
                                  Just conf -> key conf
     IC mempty mempty mempty mempty <$> newStdGen <*> pure sk <*> pure (fmap (sub_id . key) root_subnet) <*> pure (map sub subnets)
   where
-    sub conf = (sub_id (key conf), subnet_type conf, key conf, canister_ranges conf)
+    sub conf = (sub_id (key conf), subnet_type conf, subnet_size conf, key conf, canister_ranges conf)
     sub_id = EntityId . mkSelfAuthenticatingId . toPublicKey
     key = createSecretKeyBLS . BLU.fromString . nonce
 
@@ -597,7 +599,7 @@ stateTree (Timestamp t) ic = node
     val = Value . toCertVal
     str = val @T.Text
     (=:) = M.singleton
-    subnet_tree (EntityId subnet_id, _, _, ranges) = subnet_id =: node (
+    subnet_tree (EntityId subnet_id, _, _, _, ranges) = subnet_id =: node (
         [ "public_key" =: val subnet_id
         , "canister_ranges" =: val (encodeCanisterRangeList $ map (\(a, b) -> (wordToId a, wordToId b)) ranges)
         ]
@@ -620,20 +622,20 @@ delegationTree (Timestamp t) (EntityId subnet_id) subnet_pub_key ranges = node
     val = Value . toCertVal
     (=:) = M.singleton
 
-getSubnetFromCanisterId :: (CanReject m, ICM m) => CanisterId -> m (EntityId, SubnetType, SecretKey, [(W.Word64, W.Word64)])
+getSubnetFromCanisterId :: (CanReject m, ICM m) => CanisterId -> m Subnet
 getSubnetFromCanisterId cid = do
     subnets <- gets subnets
     case subnetOfCid cid subnets of
       Nothing -> reject RC_SYS_FATAL "Canister id does not belong to any subnet." Nothing
       Just x -> return x
     where
-      subnetOfCid cid subnets = find (\(_, _, _, ranges) -> find (\(a, b) -> wordToId a <= cid && cid <= wordToId b) ranges /= Nothing) subnets
+      subnetOfCid cid subnets = find (\(_, _, _, _, ranges) -> find (\(a, b) -> wordToId a <= cid && cid <= wordToId b) ranges /= Nothing) subnets
 
 getPrunedCertificate :: (CanReject m, ICM m) => Timestamp -> CanisterId -> [Path] -> m Certificate
 getPrunedCertificate time ecid paths = do
     root_subnet <- gets rootSubnet
     sk1 <- gets secretRootKey
-    (subnet_id, _, sk2, ranges) <- getSubnetFromCanisterId ecid
+    (subnet_id, _, _, sk2, ranges) <- getSubnetFromCanisterId ecid
     full_tree <- gets (construct . stateTree time)
     let cert_tree = prune full_tree (["time"] : paths)
     return $ signCertificate time sk1 (if root_subnet == Just subnet_id then Nothing else Just (subnet_id, sk2, ranges)) cert_tree
@@ -933,8 +935,8 @@ invokeManagementCanister _ _ GlobalTimer = error "global timer invoked on manage
 icHttpRequest :: (ICM m, CanReject m) => EntityId -> CallId -> ICManagement m .! "http_request"
 icHttpRequest caller ctxt_id r = do
   available <- getCallContextCycles ctxt_id
-  (_, subnet, _, _) <- getSubnetFromCanisterId caller
-  let fee = fromIntegral $ http_request_fee r subnet
+  (_, subnet_type, subnet_size, _, _) <- getSubnetFromCanisterId caller
+  let fee = fromIntegral $ http_request_fee r (subnet_type, subnet_size)
   let url = T.unpack $ r .! #url
   let max_resp_size = max_response_size r
   let transform_principal_check =
@@ -1018,7 +1020,7 @@ icCreateCanister caller ctxt_id r = do
     forM_ (r .! #settings) validateSettings
     available <- getCallContextCycles ctxt_id
     setCallContextCycles ctxt_id 0
-    (_, _, _, ranges) <- getSubnetFromCanisterId caller
+    (_, _, _, _, ranges) <- getSubnetFromCanisterId caller
     cid <- icCreateCanisterCommon ranges caller available
     forM_ (r .! #settings) $ applySettings cid
     return (#canister_id .== entityIdToPrincipal cid)
@@ -1027,7 +1029,7 @@ icCreateCanisterWithCycles :: (ICM m, CanReject m) => EntityId -> CallId -> ICMa
 icCreateCanisterWithCycles caller ctxt_id r = do
     forM_ (r .! #settings) validateSettings
     ecid <- ecidOfCallID ctxt_id
-    (_, _, _, ranges) <- getSubnetFromCanisterId ecid
+    (_, _, _, _, ranges) <- getSubnetFromCanisterId ecid
     cid <- icCreateCanisterCommon ranges caller (fromMaybe cDEFAULT_PROVISIONAL_CYCLES_BALANCE (r .! #amount))
     forM_ (r .! #settings) $ applySettings cid
     return (#canister_id .== entityIdToPrincipal cid)

src/IC/Test/Agent/Calls.hs

@@ -160,7 +160,7 @@ ic_raw_rand ic00 =
 
 ic_http_get_request ::
     forall a b. (a -> IO b) ~ (ICManagement IO .! "http_request") =>
-    HasAgentConfig => IC00WithCycles -> SubnetType -> String -> Maybe W.Word64 -> Maybe (String, Blob) -> Blob -> IO b
+    HasAgentConfig => IC00WithCycles -> (SubnetType, W.Word64) -> String -> Maybe W.Word64 -> Maybe (String, Blob) -> Blob -> IO b
 ic_http_get_request ic00 sub path max_response_bytes transform canister_id =
   callIC (ic00 $ http_request_fee request sub) "" #http_request request
   where
@@ -174,7 +174,7 @@ ic_http_get_request ic00 sub path max_response_bytes transform canister_id =
 
 ic_http_post_request :: HasAgentConfig =>
     (a -> IO b) ~ (ICManagement IO .! "http_request") =>
-    IC00WithCycles -> SubnetType -> String -> Maybe W.Word64 -> Maybe BS.ByteString -> Vec.Vector HttpHeader -> Maybe (String, Blob) -> Blob -> IO b
+    IC00WithCycles -> (SubnetType, W.Word64) -> String -> Maybe W.Word64 -> Maybe BS.ByteString -> Vec.Vector HttpHeader -> Maybe (String, Blob) -> Blob -> IO b
 ic_http_post_request ic00 sub path max_response_bytes body headers transform canister_id =
   callIC (ic00 $ http_request_fee request sub) "" #http_request request
   where
@@ -188,7 +188,7 @@ ic_http_post_request ic00 sub path max_response_bytes body headers transform can
 
 ic_http_head_request :: HasAgentConfig =>
     (a -> IO b) ~ (ICManagement IO .! "http_request") =>
-    IC00WithCycles -> SubnetType -> String -> Maybe W.Word64 -> Maybe BS.ByteString -> Vec.Vector HttpHeader -> Maybe (String, Blob) -> Blob -> IO b
+    IC00WithCycles -> (SubnetType, W.Word64) -> String -> Maybe W.Word64 -> Maybe BS.ByteString -> Vec.Vector HttpHeader -> Maybe (String, Blob) -> Blob -> IO b
 ic_http_head_request ic00 sub path max_response_bytes body headers transform canister_id =
   callIC (ic00 $ http_request_fee request sub) "" #http_request request
   where
@@ -202,7 +202,7 @@ ic_http_head_request ic00 sub path max_response_bytes body headers transform can
 
 ic_long_url_http_request :: HasAgentConfig =>
   forall a b. (a -> IO b) ~ (ICManagement IO .! "http_request") =>
-  IC00WithCycles -> SubnetType -> String -> W.Word64 -> Maybe (String, Blob) -> Blob -> IO b
+  IC00WithCycles -> (SubnetType, W.Word64) -> String -> W.Word64 -> Maybe (String, Blob) -> Blob -> IO b
 ic_long_url_http_request ic00 sub proto len transform canister_id =
   callIC (ic00 $ http_request_fee request sub) "" #http_request request
   where
@@ -299,7 +299,7 @@ ic_ecdsa_public_key' ic00 canister_id path =
        .+ #name .== (T.pack "0")
     )
 
-ic_http_get_request' :: HasAgentConfig => IC00WithCycles -> SubnetType -> String -> String -> Maybe W.Word64 -> Maybe (String, Blob) -> Blob -> IO ReqResponse
+ic_http_get_request' :: HasAgentConfig => IC00WithCycles -> (SubnetType, W.Word64) -> String -> String -> Maybe W.Word64 -> Maybe (String, Blob) -> Blob -> IO ReqResponse
 ic_http_get_request' ic00 sub proto path max_response_bytes transform canister_id =
   callIC' (ic00 $ http_request_fee request sub) "" #http_request request
   where
@@ -311,7 +311,7 @@ ic_http_get_request' ic00 sub proto path max_response_bytes transform canister_i
       .+ #body .== Nothing
       .+ #transform .== (toTransformFn transform canister_id)
 
-ic_http_post_request' :: HasAgentConfig => IC00WithCycles -> SubnetType -> String -> Maybe W.Word64 -> Maybe BS.ByteString -> Vec.Vector HttpHeader -> Maybe (String, Blob) -> Blob -> IO ReqResponse
+ic_http_post_request' :: HasAgentConfig => IC00WithCycles -> (SubnetType, W.Word64) -> String -> Maybe W.Word64 -> Maybe BS.ByteString -> Vec.Vector HttpHeader -> Maybe (String, Blob) -> Blob -> IO ReqResponse
 ic_http_post_request' ic00 sub path max_response_bytes body headers transform canister_id =
   callIC' (ic00 $ http_request_fee request sub) "" #http_request request
   where
@@ -323,7 +323,7 @@ ic_http_post_request' ic00 sub path max_response_bytes body headers transform ca
       .+ #body .== body
       .+ #transform .== (toTransformFn transform canister_id)
 
-ic_http_head_request' :: HasAgentConfig => IC00WithCycles -> SubnetType -> String -> Maybe W.Word64 -> Maybe BS.ByteString -> Vec.Vector HttpHeader -> Maybe (String, Blob) -> Blob -> IO ReqResponse
+ic_http_head_request' :: HasAgentConfig => IC00WithCycles -> (SubnetType, W.Word64) -> String -> Maybe W.Word64 -> Maybe BS.ByteString -> Vec.Vector HttpHeader -> Maybe (String, Blob) -> Blob -> IO ReqResponse
 ic_http_head_request' ic00 sub path max_response_bytes body headers transform canister_id =
   callIC' (ic00 $ http_request_fee request sub) "" #http_request request
   where
@@ -335,7 +335,7 @@ ic_http_head_request' ic00 sub path max_response_bytes body headers transform ca
       .+ #body .== body
       .+ #transform .== (toTransformFn transform canister_id)
 
-ic_long_url_http_request' :: HasAgentConfig => IC00WithCycles -> SubnetType -> String -> W.Word64 -> Maybe (String, Blob) -> Blob -> IO ReqResponse
+ic_long_url_http_request' :: HasAgentConfig => IC00WithCycles -> (SubnetType, W.Word64) -> String -> W.Word64 -> Maybe (String, Blob) -> Blob -> IO ReqResponse
 ic_long_url_http_request' ic00 sub proto len transform canister_id =
   callIC' (ic00 $ http_request_fee request sub) "" #http_request request
   where

src/IC/Test/Options.hs

@@ -2,6 +2,7 @@ module IC.Test.Options where
 
 import Data.Proxy
 import Data.List
+import qualified Data.Word as W
 import Test.Tasty.Options
 import Options.Applicative hiding (str)
 import IC.Id.Fresh(wordToId)
@@ -65,29 +66,21 @@ polltimeoutOption = Option (Proxy :: Proxy PollTimeout)
 
 -- Configuration: Subnet type
 
-newtype TestSubnetType = TestSubnetType SubnetType
-
-instance Read TestSubnetType where
-  readsPrec _ x
-    | x == "application" = return (TestSubnetType Application, "")
-    | x == "verified_application" = return (TestSubnetType VerifiedApplication, "")
-    | x == "system" = return (TestSubnetType System, "")
-    | otherwise = fail "could not read SubnetType"
-
-instance Show TestSubnetType where
-  show (TestSubnetType Application) = "application"
-  show (TestSubnetType VerifiedApplication) = "verified_application"
-  show (TestSubnetType System) = "system"
-
-instance IsOption TestSubnetType where
-  defaultValue = TestSubnetType Application
-  parseValue p
-    | p == "application" = Just $ TestSubnetType Application
-    | p == "verified_application" = Just $ TestSubnetType VerifiedApplication
-    | p == "system" = Just $ TestSubnetType System
-    | otherwise = Nothing
-  optionName = return "subnet-type"
-  optionHelp = return "Subnet type [possible values: application, verified_application, system] (default: application)"
-
-subnettypeOption :: OptionDescription
-subnettypeOption = Option (Proxy :: Proxy TestSubnetType)
+newtype TestSubnet = TestSubnet (SubnetType, W.Word64)
+
+instance Read TestSubnet where
+  readsPrec p x = do
+    (y, z) <- (readsPrec p x :: [((SubnetType, W.Word64), String)])
+    return (TestSubnet y, z)
+
+instance Show TestSubnet where
+  show (TestSubnet sub) = show sub
+
+instance IsOption TestSubnet where
+  defaultValue = TestSubnet (Application, 1)
+  parseValue = Just <$> read
+  optionName = return "test-subnet-config"
+  optionHelp = return $ "Test subnet configuration consisting of subnet type and replication factor (default: " ++ show (TestSubnet (Application, 1)) ++ ")"
+
+testSubnetOption :: OptionDescription
+testSubnetOption = Option (Proxy :: Proxy TestSubnet)

src/IC/Test/Spec.hs

@@ -20,6 +20,7 @@ import qualified Data.HashMap.Lazy as HM
 import qualified Data.Map.Lazy as M
 import qualified Data.Set as S
 import qualified Data.Vector as Vec
+import qualified Data.Word as W
 import qualified Data.ByteString.Lazy.UTF8 as BLU
 import Data.Text.Encoding.Base64(encodeBase64)
 import Data.ByteString.Builder
@@ -150,7 +151,7 @@ check_http_body = aux . fromUtf8
     aux Nothing = False
     aux (Just s) = all ((==) 'x') $ T.unpack s
 
-canister_http_calls :: HasAgentConfig => SubnetType -> [TestTree]
+canister_http_calls :: HasAgentConfig => (SubnetType, W.Word64) -> [TestTree]
 canister_http_calls sub =
   [
     -- "Currently, the GET, HEAD, and POST methods are supported for HTTP requests."
@@ -528,8 +529,8 @@ canister_http_calls sub =
 
 -- * The test suite (see below for helper functions)
 
-icTests :: SubnetType -> AgentConfig -> TestTree
-icTests subnet = withAgentConfig $ testGroup "Interface Spec acceptance tests"
+icTests :: (SubnetType, W.Word64) -> AgentConfig -> TestTree
+icTests sub = withAgentConfig $ testGroup "Interface Spec acceptance tests"
   [ simpleTestCase "create and install" $ \_ ->
       return ()
 
@@ -863,7 +864,7 @@ icTests subnet = withAgentConfig $ testGroup "Interface Spec acceptance tests"
     assertBool "random blobs are different" $ r1 /= r2
 
   , IC.Test.Spec.TECDSA.tests
-  , testGroup "canister http calls" $ canister_http_calls subnet
+  , testGroup "canister http calls" $ canister_http_calls sub
 
   , testGroup "simple calls"
     [ simpleTestCase "Call" $ \cid ->

src/IC/Types.hs

@@ -142,6 +142,7 @@ instance Show SubnetType where
 
 data SubnetConfig = SubnetConfig
     { subnet_type :: SubnetType
+    , subnet_size :: W.Word64
     , nonce :: String
     , canister_ranges :: [(W.Word64, W.Word64)]
     }

src/IC/Utils.hs

@@ -90,11 +90,11 @@ max_response_size r = aux $ fmap fromIntegral $ r .! #max_response_bytes
     aux Nothing = max_response_bytes_limit
     aux (Just w) = w
 
-http_request_fee :: (a -> IO b) ~ (ICManagement IO .! "http_request") => a -> SubnetType -> W.Word64
-http_request_fee r sub = base + per_byte * total_bytes
+http_request_fee :: (a -> IO b) ~ (ICManagement IO .! "http_request") => a -> (SubnetType, W.Word64) -> W.Word64
+http_request_fee r (subnet_type, subnet_size) = (normalized_fee * subnet_size) `div` reference_subnet_size
   where
-    base = getHttpRequestBaseFee sub
-    per_byte = getHttpRequestPerByteFee sub
+    base = getHttpRequestBaseFee subnet_type
+    per_byte = getHttpRequestPerByteFee subnet_type
     response_size_fee Nothing = max_response_bytes_limit
     response_size_fee (Just max_response_size) = max_response_size
     transform_fee Nothing = 0
@@ -107,7 +107,7 @@ http_request_fee r sub = base + per_byte * total_bytes
       + (fromIntegral $ sum $ map (\h -> utf8_length (h .! #name) + utf8_length (h .! #value)) $ Vec.toList $ r .! #headers)
       + (fromIntegral $ body_fee $ r .! #body)
       + (fromIntegral $ transform_fee $ r .! #transform)
-
+    normalized_fee = base + per_byte * total_bytes
 
 http_request_headers_total_size :: (a -> IO b) ~ (ICManagement IO .! "http_request") => Integral c => a -> c
 http_request_headers_total_size r = fromIntegral $ sum $ map (\h -> utf8_length (h .! #name) + utf8_length (h .! #value)) $ Vec.toList $ r .! #headers

src/ic-ref-run.hs

@@ -133,9 +133,9 @@ callManagement store ecid user_id l x =
   submitAndRun store ecid $
     CallRequest (EntityId mempty) user_id (symbolVal l) (Candid.encode x)
 
-work :: [(SubnetType, String, [(W.Word64, W.Word64)])] -> Int -> FilePath -> IO ()
+work :: [(SubnetType, W.Word64, String, [(W.Word64, W.Word64)])] -> Int -> FilePath -> IO ()
 work subnets systemTaskPeriod msg_file = do
-  let subs = map (\(t, n, ranges) -> SubnetConfig t n ranges) subnets
+  let subs = map (\(t, n, nonce, ranges) -> SubnetConfig t n nonce ranges) subnets
   msgs <- parseFile msg_file
 
   let user_id = dummyUserId
@@ -198,8 +198,8 @@ main = join . customExecParser (prefs showHelpOnError) $
     canister_ids_per_subnet = 1_048_576
     range :: W.Word64 -> (W.Word64, W.Word64)
     range n = (n * canister_ids_per_subnet, (n + 1) * canister_ids_per_subnet - 1)
-    defaultSubnetConfig :: [(SubnetType, String, [(W.Word64, W.Word64)])]
-    defaultSubnetConfig = [(System, "sk1", [range 0]), (Application, "sk2", [range 1])]
+    defaultSubnetConfig :: [(SubnetType, W.Word64, String, [(W.Word64, W.Word64)])]
+    defaultSubnetConfig = [(System, 1, "sk1", [range 0]), (Application, 1, "sk2", [range 1])]
     defaultSystemTaskPeriod :: Int
     defaultSystemTaskPeriod = 1
     parser :: Parser (IO ())

src/ic-ref-test.hs

@@ -23,8 +23,8 @@ main = do
     BLS.init
     os <- parseOptions ingredients (testGroup "dummy" [])
     ac <- preFlight os
-    let TestSubnetType subnet = lookupOption os
-    defaultMainWithIngredients ingredients (icTests subnet ac)
+    let TestSubnet sub = lookupOption os
+    defaultMainWithIngredients ingredients (icTests sub ac)
   where
     ingredients =
       [ rerunningTests
@@ -33,7 +33,7 @@ main = do
         , includingOptions [ecidOption]
         , includingOptions [httpbinOption]
         , includingOptions [polltimeoutOption]
-        , includingOptions [subnettypeOption]
+        , includingOptions [testSubnetOption]
         , antXMLRunner `composeReporters` htmlRunner `composeReporters` consoleTestReporter
         ]
       ]

src/ic-ref.hs

@@ -21,9 +21,9 @@ defaultPort :: Port
 defaultPort = 8001
 
 
-work :: [(SubnetType, String, [(W.Word64, W.Word64)])] -> Maybe String -> Int -> Maybe Int -> Maybe FilePath -> Maybe FilePath -> Bool ->  IO ()
+work :: [(SubnetType, W.Word64, String, [(W.Word64, W.Word64)])] -> Maybe String -> Int -> Maybe Int -> Maybe FilePath -> Maybe FilePath -> Bool ->  IO ()
 work subnets maybe_cert_path systemTaskPeriod portToUse writePortTo backingFile log = do
-    let subs = map (\(t, n, ranges) -> SubnetConfig t n ranges) subnets
+    let subs = map (\(t, n, nonce, ranges) -> SubnetConfig t n nonce ranges) subnets
     putStrLn "Starting ic-ref..."
     BLS.init
     certs <- case maybe_cert_path of Nothing -> return []
@@ -73,8 +73,8 @@ main = join . customExecParser (prefs showHelpOnError) $
     canister_ids_per_subnet = 1_048_576
     range :: W.Word64 -> (W.Word64, W.Word64)
     range n = (n * canister_ids_per_subnet, (n + 1) * canister_ids_per_subnet - 1)
-    defaultSubnetConfig :: [(SubnetType, String, [(W.Word64, W.Word64)])]
-    defaultSubnetConfig = [(System, "sk1", [range 0]), (Application, "sk2", [range 1])]
+    defaultSubnetConfig :: [(SubnetType, W.Word64, String, [(W.Word64, W.Word64)])]
+    defaultSubnetConfig = [(System, 1, "sk1", [range 0]), (Application, 1, "sk2", [range 1])]
     defaultSystemTaskPeriod :: Int
     defaultSystemTaskPeriod = 1
     parser :: Parser (IO ())
@@ -84,7 +84,7 @@ main = join . customExecParser (prefs showHelpOnError) $
           (
             option auto
             (  long "subnet-config"
-            <> help ("choose initial subnet configurations (default: " ++ show defaultSubnetConfig ++ ")")
+            <> help ("choose initial subnet configuration consisting of subnet type, replication factor, nonce, and canister ranges for every subnet (default: " ++ show defaultSubnetConfig ++ ")")
             )
           )
         <|> pure defaultSubnetConfig

src/unit-tests.hs

@@ -34,7 +34,7 @@ main = do
     defaultMain $ tests conf
 
 defaultSubnetConfig :: [SubnetConfig]
-defaultSubnetConfig = [SubnetConfig Application "sk" [(0, 0)]]
+defaultSubnetConfig = [SubnetConfig Application 1 "sk" [(0, 0)]]
 
 defaultEcid :: CanisterId
 defaultEcid = wordToId 0