├── universal-canister ├── .gitignore ├── .envrc ├── default.nix ├── shell.nix ├── Cargo.toml └── src │ └── lib.rs ├── example.cbor ├── .gitattributes ├── shell.nix ├── test-data └── universal-canister.wasm ├── nix ├── generated │ ├── README.md │ ├── all.nix │ ├── leb128-cereal.nix │ ├── http-client.nix │ ├── candid.nix │ ├── winter.nix │ └── ic-hs.nix ├── python-cbor2.nix ├── secp256k1 │ └── default.nix ├── default.nix ├── sources.json ├── generate.nix └── gitSource.nix ├── src ├── IC │ ├── Version.hs │ ├── Certificate.hs │ ├── Hash.hs │ ├── CBOR │ │ ├── Utils.hs │ │ ├── Patterns.hs │ │ └── Parser.hs │ ├── HTTP │ │ ├── Status.hs │ │ ├── GenR.hs │ │ ├── RequestId.hs │ │ ├── CBOR.hs │ │ └── GenR │ │ │ └── Parse.hs │ ├── Crypto │ │ ├── DER │ │ │ └── Decode.hs │ │ ├── Ed25519.hs │ │ ├── ECDSA.hs │ │ ├── DER_BLS.hs │ │ ├── Bitcoin.hs │ │ ├── Secp256k1.hs │ │ ├── DER.hs │ │ ├── CanisterSig.hs │ │ └── BLS.hsc │ ├── Certificate │ │ ├── Value.hs │ │ ├── CBOR.hs │ │ └── Validate.hs │ ├── HashTree │ │ └── CBOR.hs │ ├── Id │ │ ├── Fresh.hs │ │ └── Forms.hs │ ├── Test │ │ ├── ECDSA.hs │ │ ├── Secp256k1.hs │ │ ├── Agent │ │ │ ├── Calls.hs │ │ │ └── UserCalls.hs │ │ ├── BLS.hs │ │ ├── Spec │ │ │ └── TECDSA.hs │ │ ├── WebAuthn.hs │ │ ├── StableMemory.hs │ │ ├── Options.hs │ │ └── HashTree.hs │ ├── Canister │ │ ├── Snapshot.hs │ │ └── StableMemory.hs │ ├── Purify.hs │ ├── DRun │ │ └── Parse.hs │ ├── Constants.hs │ ├── Ref │ │ └── IO.hs │ ├── Management.hs │ ├── Wasm │ │ └── Winter │ │ │ └── Persist.hs │ ├── Serialise.hs │ ├── Crypto.hs │ └── HashTree.hs └── SourceId.hs ├── .hlint.yaml ├── .gitignore ├── httpbin-rs └── Cargo.toml ├── .mergify.yml ├── cbits ├── README.md ├── randapi.c ├── config_big_384_58.h ├── randapi.h ├── config_field_BLS12381.h ├── newhope.h ├── bls_BLS12381.h ├── config_curve_BLS12381.h ├── x509.h ├── rom_field_BLS12381.c ├── hpke_BLS12381.h ├── arch.h ├── mpin_BLS12381.h ├── rand.c ├── pair_BLS12381.h └── bls_BLS12381.c ├── bin ├── ic-ref-test.hs ├── ic-request-id.hs └── ic-ref.hs ├── tests └── unit-tests.hs └── ic.did /universal-canister/.gitignore: -------------------------------------------------------------------------------- 1 | target 2 | -------------------------------------------------------------------------------- /universal-canister/.envrc: -------------------------------------------------------------------------------- 1 | eval "$(lorri direnv)" -------------------------------------------------------------------------------- /example.cbor: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dfinity/ic-hs/HEAD/example.cbor -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | nix/generated/* linguist-generated 2 | cabal.project.freeze linguist-generated 3 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | { system ? builtins.currentSystem }: 2 | (import ./default.nix {inherit system;}).ic-hs-shell 3 | -------------------------------------------------------------------------------- /test-data/universal-canister.wasm: -------------------------------------------------------------------------------- 1 | ../universal-canister/target/wasm32-unknown-unknown/release/universal-canister.wasm -------------------------------------------------------------------------------- /nix/generated/README.md: -------------------------------------------------------------------------------- 1 | The contents of this directory are automatically generated. 2 | To update, please run nix-shell generate.nix 3 | -------------------------------------------------------------------------------- /universal-canister/default.nix: -------------------------------------------------------------------------------- 1 | { system ? builtins.currentSystem }: 2 | (import ../default.nix {inherit system;}).universal-canister 3 | -------------------------------------------------------------------------------- /universal-canister/shell.nix: -------------------------------------------------------------------------------- 1 | { system ? builtins.currentSystem }: 2 | (import ../default.nix {inherit system;}).universal-canister 3 | -------------------------------------------------------------------------------- /universal-canister/Cargo.toml: -------------------------------------------------------------------------------- 1 | [package] 2 | name = "universal-canister" 3 | version = "0.8.0" 4 | edition = "2021" 5 | 6 | [dependencies] 7 | candid = "0.8.1" 8 | serde = "1" 9 | wee_alloc = "0.4.3" 10 | lazy_static = "1.4.0" 11 | -------------------------------------------------------------------------------- /src/IC/Version.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module IC.Version where 3 | 4 | import Data.Text 5 | import SourceId 6 | 7 | specVersion, implVersion :: Text 8 | specVersion = "0.18.0" 9 | implVersion = pack SourceId.id 10 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | # Warnings currently triggered by your code 2 | - ignore: {name: "Use uncurry"} 3 | - ignore: {name: "Avoid lambda"} 4 | - ignore: {name: "Use camelCase"} 5 | - ignore: {name: "Eta reduce"} 6 | - ignore: {name: "Use >=>"} 7 | - ignore: {name: "Use const"} 8 | - ignore: {name: "Avoid lambda using `infix`"} 9 | -------------------------------------------------------------------------------- /nix/generated/all.nix: -------------------------------------------------------------------------------- 1 | self: super: { 2 | candid = super.callPackage ./candid.nix { }; 3 | http-client = super.callPackage ./http-client.nix { }; 4 | ic-hs = super.callPackage ./ic-hs.nix { }; 5 | leb128-cereal = super.callPackage ./leb128-cereal.nix { }; 6 | winter = super.callPackage ./winter.nix { }; 7 | } 8 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.hie 7 | *.chi 8 | *.chs.h 9 | *.dyn_o 10 | *.dyn_hi 11 | .hpc 12 | .hsenv 13 | .cabal-sandbox/ 14 | cabal.sandbox.config 15 | *.prof 16 | *.aux 17 | *.hp 18 | *.eventlog 19 | .stack-work/ 20 | cabal.project.local 21 | *~ 22 | .HTF/ 23 | .ghc.environment.* 24 | .tasty-rerun-log 25 | result 26 | result-* 27 | test-data/*.wasm 28 | -------------------------------------------------------------------------------- /src/IC/Certificate.hs: -------------------------------------------------------------------------------- 1 | module IC.Certificate where 2 | 3 | import IC.HashTree 4 | 5 | data Certificate = Certificate 6 | { cert_tree :: HashTree 7 | , cert_sig :: Blob 8 | , cert_delegation :: Maybe Delegation 9 | } 10 | deriving (Show) 11 | 12 | data Delegation = Delegation 13 | { del_subnet_id :: Blob 14 | , del_certificate :: Blob 15 | } 16 | deriving (Show) 17 | 18 | -------------------------------------------------------------------------------- /src/IC/Hash.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | module IC.Hash where 3 | 4 | import qualified Data.ByteString.Lazy as BS 5 | import Crypto.Hash (hashlazy, SHA256, SHA224) 6 | import Data.ByteArray (convert) 7 | 8 | sha256 :: BS.ByteString -> BS.ByteString 9 | sha256 = BS.fromStrict . convert . hashlazy @SHA256 10 | 11 | sha224 :: BS.ByteString -> BS.ByteString 12 | sha224 = BS.fromStrict . convert . hashlazy @SHA224 13 | -------------------------------------------------------------------------------- /httpbin-rs/Cargo.toml: -------------------------------------------------------------------------------- 1 | [package] 2 | name = "httpbin-rs" 3 | version = "0.1.0" 4 | edition = "2021" 5 | 6 | # See more keys and their definitions at https://doc.rust-lang.org/cargo/reference/manifest.html 7 | 8 | [dependencies] 9 | axum = "0.6.18" 10 | axum-server = { version = "0.5.1", features = ["tls-openssl"] } 11 | clap = { version = "4.0", features = ["derive"] } 12 | serde_json = { version = "1.0" } 13 | tokio = { version = "1.0", features = ["rt-multi-thread"] } 14 | -------------------------------------------------------------------------------- /src/IC/CBOR/Utils.hs: -------------------------------------------------------------------------------- 1 | module IC.CBOR.Utils where 2 | 3 | import qualified Data.ByteString.Builder as BS 4 | import IC.HTTP.CBOR 5 | import IC.HTTP.GenR 6 | import IC.Types 7 | 8 | encodePrincipalList :: [EntityId] -> Blob 9 | encodePrincipalList entities = BS.toLazyByteString $ encode $ GList $ map (GBlob . rawEntityId) entities 10 | 11 | encodeCanisterRangeList :: [CanisterRange] -> Blob 12 | encodeCanisterRangeList ranges = BS.toLazyByteString $ encode $ GList $ map (\(l, u) -> GList $ map (GBlob . rawEntityId) [l, u]) ranges -------------------------------------------------------------------------------- /src/IC/HTTP/Status.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | -- | the response to the status request 3 | module IC.HTTP.Status where 4 | 5 | import IC.HTTP.GenR 6 | import IC.Version 7 | import IC.Ref 8 | import IC.Crypto 9 | import Data.HashMap.Lazy 10 | 11 | r :: IC -> GenR 12 | r ic = GRec $ mconcat 13 | [ "ic_api_version" =: GText specVersion 14 | , "impl_version" =: GText implVersion 15 | , "impl_source" =: GText "https://github.com/dfinity-lab/ic-ref" 16 | , "root_key" =: GBlob (toPublicKey (secretRootKey ic)) 17 | ] 18 | where 19 | -- Convenient syntax 20 | (=:) = Data.HashMap.Lazy.singleton 21 | -------------------------------------------------------------------------------- /nix/generated/leb128-cereal.nix: -------------------------------------------------------------------------------- 1 | # THIS IS AN AUTOMATICALLY GENERATED FILE. DO NOT EDIT MANUALLY! 2 | # See ./nix/generate.nix for instructions. 3 | 4 | { mkDerivation 5 | , pkgs 6 | , base 7 | , bytestring 8 | , cereal 9 | , lib 10 | , tasty 11 | , tasty-hunit 12 | , tasty-quickcheck 13 | }: 14 | mkDerivation { 15 | pname = "leb128-cereal"; 16 | version = "1.2"; 17 | src = pkgs.sources.leb128-cereal; 18 | libraryHaskellDepends = [ base bytestring cereal ]; 19 | testHaskellDepends = [ 20 | base 21 | bytestring 22 | tasty 23 | tasty-hunit 24 | tasty-quickcheck 25 | ]; 26 | description = "LEB128 and SLEB128 encoding"; 27 | license = lib.licenses.mit; 28 | } 29 | -------------------------------------------------------------------------------- /nix/python-cbor2.nix: -------------------------------------------------------------------------------- 1 | { lib, buildPythonPackage, fetchPypi, pytest, pytestcov, setuptools_scm }: 2 | 3 | buildPythonPackage rec { 4 | pname = "cbor2"; 5 | version = "5.2.0"; 6 | 7 | src = fetchPypi { 8 | inherit pname version; 9 | sha256 = "1gwlgjl70vlv35cgkcw3cg7b5qsmws36hs4mmh0l9msgagjs4fm3"; 10 | }; 11 | 12 | nativeBuildInputs = [ setuptools_scm ]; 13 | checkInputs = [ pytest pytestcov ]; 14 | 15 | checkPhase = "pytest"; 16 | 17 | meta = with lib; { 18 | description = "Pure Python CBOR (de)serializer with extensive tag support"; 19 | homepage = "https://github.com/agronholm/cbor2"; 20 | license = licenses.mit; 21 | maintainers = with maintainers; [ taneb ]; 22 | }; 23 | } 24 | -------------------------------------------------------------------------------- /src/IC/Crypto/DER/Decode.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | module IC.Crypto.DER.Decode (safeDecode) where 3 | 4 | import qualified Data.ByteString.Lazy as BS 5 | import Data.ASN1.Types 6 | import Data.ASN1.Encoding 7 | import Data.ASN1.BinaryEncoding 8 | import Data.Bifunctor 9 | 10 | import Control.Exception 11 | import System.IO.Unsafe 12 | import Control.Monad 13 | import Control.Seq 14 | 15 | -- Works around https://github.com/vincenthz/hs-asn1/issues/41 16 | safeDecode :: BS.ByteString -> Either String [ASN1] 17 | safeDecode bs = unsafePerformIO $ do 18 | let r = first show $ decodeASN1 DER bs 19 | join . first show <$> 20 | try @SomeException (evaluate (r `using` seqFoldable (seqList rseq))) 21 | -------------------------------------------------------------------------------- /src/IC/Certificate/Value.hs: -------------------------------------------------------------------------------- 1 | -- Encoding and decoding of state tree values 2 | 3 | {-# LANGUAGE TypeSynonymInstances #-} 4 | module IC.Certificate.Value (CertVal(..)) where 5 | 6 | import qualified Data.Text as T 7 | import qualified Data.ByteString.Lazy as BS 8 | import Data.Serialize.LEB128 9 | import Numeric.Natural 10 | 11 | import IC.Types 12 | import IC.Utils 13 | 14 | class CertVal a where 15 | toCertVal :: a -> Blob 16 | fromCertVal :: Blob -> Maybe a 17 | 18 | instance CertVal Blob where 19 | toCertVal = id 20 | fromCertVal = Just 21 | 22 | instance CertVal T.Text where 23 | toCertVal = toUtf8 24 | fromCertVal = fromUtf8 25 | 26 | instance CertVal Natural where 27 | toCertVal = BS.fromStrict . toLEB128 28 | fromCertVal = forgetLeft . fromLEB128 . BS.toStrict 29 | 30 | forgetLeft :: Either a b -> Maybe b 31 | forgetLeft = either (const Nothing) Just 32 | -------------------------------------------------------------------------------- /src/IC/HTTP/GenR.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | This module describe a type for our “generic request (or response)” format. It 3 | can be seen as a simplified (and more abstract) AST for CBOR data. 4 | 5 | The following operations can be done on generic requests 6 | * Parsing from CBOR 7 | * Encoding to CBOR 8 | * Request ID calculation 9 | * Thus: Signing and signature checking 10 | -} 11 | module IC.HTTP.GenR where 12 | 13 | import Numeric.Natural 14 | import Data.Text 15 | import Data.ByteString.Lazy 16 | import Data.HashMap.Lazy 17 | 18 | data GenR 19 | = GBool Bool 20 | | GNat Natural 21 | | GText Text 22 | | GBlob ByteString 23 | | GRec (HashMap Text GenR) 24 | | GList [GenR] 25 | deriving Show 26 | 27 | emptyR :: GenR 28 | emptyR = GRec Data.HashMap.Lazy.empty 29 | 30 | -- For assembling generic records 31 | (=:) :: Text -> v -> HashMap Text v 32 | (=:) = Data.HashMap.Lazy.singleton 33 | rec :: [HashMap Text GenR] -> GenR 34 | rec = GRec . mconcat 35 | 36 | -------------------------------------------------------------------------------- /src/IC/CBOR/Patterns.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE PatternSynonyms #-} 4 | {-# LANGUAGE ViewPatterns #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | 7 | module IC.CBOR.Patterns where 8 | 9 | import qualified Data.ByteString.Lazy as BS 10 | import Numeric.Natural 11 | import Codec.CBOR.Term 12 | 13 | pattern TMap_ :: [(Term, Term)] -> Term 14 | pattern TMap_ m <- (\case {TMapI m -> Just m; TMap m -> Just m; _ -> Nothing} -> Just m) 15 | 16 | pattern TList_ :: [Term] -> Term 17 | pattern TList_ m <- (\case {TListI m -> Just m; TList m -> Just m; _ -> Nothing} -> Just m) 18 | 19 | pattern TNat :: Natural -> Term 20 | pattern TNat m <- (\case 21 | TInt m | m >= 0 -> Just (fromIntegral m) 22 | TInteger m | m >= 0 -> Just (fromIntegral m) 23 | _ -> Nothing 24 | -> Just m) 25 | 26 | pattern TBlob :: BS.ByteString -> Term 27 | pattern TBlob m <- TBytes (BS.fromStrict -> m) 28 | where TBlob m = TBytes (BS.toStrict m) 29 | 30 | 31 | 32 | 33 | -------------------------------------------------------------------------------- /.mergify.yml: -------------------------------------------------------------------------------- 1 | queue_rules: 2 | - name: default 3 | conditions: 4 | - "#approved-reviews-by>=1" 5 | - "#changes-requested-reviews-by=0" 6 | - status-success=test (ubuntu-latest) 7 | - status-success=test (macos-latest) 8 | - base=master 9 | - label=automerge-squash 10 | 11 | pull_request_rules: 12 | - name: Automatic merge (squash) 13 | conditions: 14 | - "#approved-reviews-by>=1" 15 | - "#changes-requested-reviews-by=0" 16 | - status-success=test (ubuntu-latest) 17 | - status-success=test (macos-latest) 18 | - base=master 19 | - label=automerge-squash 20 | actions: 21 | queue: 22 | method: squash 23 | name: default 24 | commit_message_template: | 25 | {{title}} 26 | 27 | {{body}} 28 | delete_head_branch: {} 29 | - name: Clean up automerge tags 30 | conditions: 31 | - closed 32 | actions: 33 | label: 34 | remove: 35 | - automerge-squash 36 | - autoclose 37 | -------------------------------------------------------------------------------- /cbits/README.md: -------------------------------------------------------------------------------- 1 | This is a convenience copy of the code in https://github.com/miracl/core 2 | produced from revision fc6aca93238824fe84d649181773cba29b4fcb1e with these steps: 3 | 4 | * `cd c/` 5 | * `python config64.py` 6 | * Select BLS12381 (enter 31, then enter 0) 7 | * Copy the files listed in ic-ref.cabal to this directory 8 | * … and then re-do the patches required to use ZCash-style compressed encoding 9 | of curve points, unless mircal has implemented 10 | https://github.com/miracl/core/issues/21 in the meantime :-( 11 | * … and make sure the domain separator is `BLS_SIG_BLS12381G1_XMD:SHA-256_SSWU_RO_NUL_` 12 | * … and do not use the “new multi-pairing mechanism”, but the alternative in `bls_BLS12381.c` 13 | 14 | Yes, this is not the “right” way of doing it, but keeps `ic-ref` self-contained, which is useful especially when building it without nix (local development with cabal; the agent-rust CI integration). 15 | 16 | If you get linking errors with `cabal repl ic-ref-test`, try tweaking the order of the `c-sources` in `ic-ref.cabal`. 17 | -------------------------------------------------------------------------------- /src/IC/HTTP/RequestId.hs: -------------------------------------------------------------------------------- 1 | module IC.HTTP.RequestId (requestId) where 2 | 3 | import Numeric.Natural 4 | import qualified Data.ByteString.Lazy as BS 5 | import qualified Data.HashMap.Lazy as HM 6 | import qualified Data.Text as T 7 | import Data.List (sort) 8 | import Data.Serialize.LEB128 9 | 10 | import IC.HTTP.GenR 11 | import IC.Hash 12 | import IC.Utils 13 | 14 | type RequestId = BS.ByteString 15 | 16 | requestId :: GenR -> RequestId 17 | requestId (GRec hm) = sha256 $ BS.concat $ sort $ map encodeKV $ HM.toList hm 18 | requestId _ = error "requestID: expected a record" 19 | 20 | encodeKV :: (T.Text, GenR) -> BS.ByteString 21 | encodeKV (k,v) = sha256 (toUtf8 k) <> sha256 (encodeVal v) 22 | 23 | encodeVal :: GenR -> BS.ByteString 24 | encodeVal (GBlob b) = b 25 | encodeVal (GText t) = toUtf8 t 26 | encodeVal (GNat n) = encodeNat n 27 | encodeVal (GRec _) = error "requestID: Nested record" 28 | encodeVal (GList vs) = BS.concat $ map (sha256 . encodeVal) vs 29 | 30 | encodeNat :: Natural -> BS.ByteString 31 | encodeNat = BS.fromStrict . toLEB128 32 | -------------------------------------------------------------------------------- /src/IC/HashTree/CBOR.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module IC.HashTree.CBOR where 3 | 4 | import Codec.CBOR.Term 5 | import qualified Data.Text as T 6 | 7 | import IC.CBOR.Patterns 8 | import IC.HashTree 9 | 10 | encodeHashTree :: HashTree -> Term 11 | encodeHashTree = go 12 | where 13 | go EmptyTree = TList [ TInteger 0 ] 14 | go (Fork t1 t2) = TList [ TInteger 1, go t1, go t2 ] 15 | go (Labeled l t) = TList [ TInteger 2, TBlob l, go t ] 16 | go (Leaf v) = TList [ TInteger 3, TBlob v ] 17 | go (Pruned h) = TList [ TInteger 4, TBlob h ] 18 | 19 | parseHashTree :: Term -> Either T.Text HashTree 20 | parseHashTree = go 21 | where 22 | go (TList_ [ TNat 0 ]) = return EmptyTree 23 | go (TList_ [ TNat 1, t1, t2 ]) = Fork <$> parseHashTree t1 <*> parseHashTree t2 24 | go (TList_ [ TNat 2, TBlob l, t ]) = Labeled l <$> parseHashTree t 25 | go (TList_ [ TNat 3, TBlob v ]) = return $ Leaf v 26 | go (TList_ [ TNat 4, TBlob h ]) = return $ Pruned h 27 | go t = Left $ "Cannot parse as a Hash Tree: " <> T.pack (show t) 28 | -------------------------------------------------------------------------------- /cbits/randapi.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2012-2020 MIRACL UK Ltd. 3 | * 4 | * This file is part of MIRACL Core 5 | * (see https://github.com/miracl/core). 6 | * 7 | * Licensed under the Apache License, Version 2.0 (the "License"); 8 | * you may not use this file except in compliance with the License. 9 | * You may obtain a copy of the License at 10 | * 11 | * http://www.apache.org/licenses/LICENSE-2.0 12 | * 13 | * Unless required by applicable law or agreed to in writing, software 14 | * distributed under the License is distributed on an "AS IS" BASIS, 15 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 16 | * See the License for the specific language governing permissions and 17 | * limitations under the License. 18 | */ 19 | 20 | #include "randapi.h" 21 | 22 | /* Initialise a Cryptographically Strong Random Number Generator from 23 | an octet of raw random data */ 24 | 25 | void CREATE_CSPRNG(csprng *RNG, octet *RAW) 26 | { 27 | RAND_seed(RNG, RAW->len, RAW->val); 28 | } 29 | 30 | void KILL_CSPRNG(csprng *RNG) 31 | { 32 | RAND_clean(RNG); 33 | } 34 | 35 | -------------------------------------------------------------------------------- /src/IC/Crypto/Ed25519.hs: -------------------------------------------------------------------------------- 1 | module IC.Crypto.Ed25519 2 | ( SecretKey 3 | , createKey 4 | , toPublicKey 5 | , sign 6 | , verify 7 | ) where 8 | 9 | import qualified Data.ByteString.Lazy as BS 10 | import qualified Crypto.Sign.Ed25519 as Ed25519 11 | 12 | type SecretKey = Ed25519.SecretKey 13 | 14 | createKey :: BS.ByteString -> SecretKey 15 | createKey seed | BS.length seed > 32 = error "Seed too long" 16 | createKey seed = sk 17 | where 18 | seed' = seed <> BS.replicate (32 - BS.length seed) 0x00 19 | Just (_, sk) = Ed25519.createKeypairFromSeed_ (BS.toStrict seed') 20 | 21 | toPublicKey :: SecretKey -> BS.ByteString 22 | toPublicKey = BS.fromStrict . Ed25519.unPublicKey . Ed25519.toPublicKey 23 | 24 | sign :: SecretKey -> BS.ByteString -> BS.ByteString 25 | sign sk msg = BS.fromStrict $ Ed25519.unSignature $ Ed25519.dsign sk $ BS.toStrict msg 26 | 27 | verify :: BS.ByteString -> BS.ByteString -> BS.ByteString -> Bool 28 | verify pk msg sig = Ed25519.dverify pk' msg' sig' 29 | where 30 | sig' = Ed25519.Signature (BS.toStrict sig) 31 | pk' = Ed25519.PublicKey (BS.toStrict pk) 32 | msg' = BS.toStrict msg 33 | -------------------------------------------------------------------------------- /cbits/config_big_384_58.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2012-2020 MIRACL UK Ltd. 3 | * 4 | * This file is part of MIRACL Core 5 | * (see https://github.com/miracl/core). 6 | * 7 | * Licensed under the Apache License, Version 2.0 (the "License"); 8 | * you may not use this file except in compliance with the License. 9 | * You may obtain a copy of the License at 10 | * 11 | * http://www.apache.org/licenses/LICENSE-2.0 12 | * 13 | * Unless required by applicable law or agreed to in writing, software 14 | * distributed under the License is distributed on an "AS IS" BASIS, 15 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 16 | * See the License for the specific language governing permissions and 17 | * limitations under the License. 18 | */ 19 | 20 | /** 21 | * @file config_big.h 22 | * @author Mike Scott 23 | * @brief Config BIG Header File 24 | * 25 | */ 26 | 27 | #ifndef CONFIG_BIG_384_58_H 28 | #define CONFIG_BIG_384_58_H 29 | 30 | #include "core.h" 31 | 32 | // BIG stuff 33 | 34 | #define MODBYTES_384_58 48 /**< Number of bytes in Modulus */ 35 | #define BASEBITS_384_58 58 /**< Numbers represented to base 2*BASEBITS */ 36 | 37 | 38 | #endif 39 | -------------------------------------------------------------------------------- /src/IC/Id/Fresh.hs: -------------------------------------------------------------------------------- 1 | module IC.Id.Fresh where 2 | 3 | import IC.Types 4 | import IC.Id.Forms hiding (Blob) 5 | 6 | import Data.ByteString.Builder 7 | import Data.Word 8 | 9 | -- Not particulary efficent, but this is a reference implementation, right? 10 | freshId :: [(Word64, Word64)] -> [EntityId] -> Maybe EntityId 11 | freshId ranges ids = 12 | case filter (`notElem` ids) $ map wordToId $ concatMap (\(a, b) -> [a..b]) ranges of 13 | [] -> Nothing 14 | (x:_) -> Just x 15 | 16 | wordToId' :: Word64 -> Blob 17 | wordToId' = mkOpaqueId . toLazyByteString . word64BE 18 | 19 | wordToId :: Word64 -> EntityId 20 | wordToId = EntityId . wordToId' 21 | 22 | checkCanisterIdInRanges' :: [(Blob, Blob)] -> Blob -> Bool 23 | checkCanisterIdInRanges' ranges cid = any (\(a, b) -> a <= cid && cid <= b) ranges 24 | 25 | checkCanisterIdInRanges :: [(Word64, Word64)] -> CanisterId -> Bool 26 | checkCanisterIdInRanges ranges cid = checkCanisterIdInRanges' (map (\(a, b) -> (wordToId' a, wordToId' b)) ranges) (rawEntityId cid) 27 | 28 | isRootTestSubnet :: TestSubnetConfig -> Bool 29 | isRootTestSubnet (_, _, _, ranges, _) = checkCanisterIdInRanges ranges nns_canister_id 30 | where 31 | nns_canister_id = wordToId 0 32 | -------------------------------------------------------------------------------- /src/IC/Test/ECDSA.hs: -------------------------------------------------------------------------------- 1 | -- Unit test for IC.Test.Crypto.ECDSA 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE BinaryLiterals #-} 4 | {-# LANGUAGE ViewPatterns #-} 5 | module IC.Test.ECDSA (ecdsaTests) where 6 | 7 | import qualified Data.ByteString.Lazy as BS 8 | 9 | import Test.Tasty 10 | import Test.Tasty.QuickCheck 11 | import Test.Tasty.HUnit 12 | import Test.QuickCheck.IO () 13 | 14 | import qualified IC.Crypto.ECDSA as ECDSA 15 | 16 | ecdsaTests :: TestTree 17 | ecdsaTests = testGroup "ECDSA crypto tests" 18 | [ testProperty "create-sign-verify" $ 19 | \(BS.pack -> seed) (BS.pack -> msg) -> do 20 | let sk = ECDSA.createKey seed 21 | sig <- ECDSA.sign sk msg 22 | assertBool "verifies" $ ECDSA.verify (ECDSA.toPublicKey sk) msg sig 23 | , testProperty "invalid sig" $ 24 | \(BS.pack -> seed) (BS.pack -> msg) (BS.pack -> sig) -> 25 | let sk = ECDSA.createKey seed in 26 | assertBool "does not verify" $ not $ ECDSA.verify (ECDSA.toPublicKey sk) msg sig 27 | , testProperty "wrong message" $ 28 | \(BS.pack -> seed) (BS.pack -> msg1) (BS.pack -> msg2) -> 29 | msg1 /= msg2 ==> do 30 | let sk = ECDSA.createKey seed 31 | sig <- ECDSA.sign sk msg2 32 | assertBool "does not verify" $ not $ ECDSA.verify (ECDSA.toPublicKey sk) msg1 sig 33 | ] 34 | 35 | -------------------------------------------------------------------------------- /src/IC/Canister/Snapshot.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | {-# LANGUAGE DerivingVia #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | 6 | {-# OPTIONS_GHC -Wno-orphans #-} 7 | module IC.Canister.Snapshot ( CanisterSnapshot(..) ) where 8 | 9 | import IC.Types 10 | import IC.Wasm.Winter (Module) 11 | import IC.Wasm.Winter.Persist 12 | import IC.Canister.Imp 13 | import IC.Canister.StableMemory as Stable 14 | import IC.Purify 15 | 16 | data CanisterSnapshot = CanisterSnapshot 17 | { wsModule :: Module 18 | , wsInstances :: PInstance 19 | , wsStableMem :: Stable.Repr 20 | } deriving Show 21 | 22 | instance SnapshotAble ImpState where 23 | type SnapshotOf ImpState = CanisterSnapshot 24 | persist (ImpState _ inst sm mod) = do 25 | CanisterSnapshot mod <$> persistInstance inst <*> (Stable.export sm) 26 | recreate (CanisterSnapshot wasm_mod pinst pmem) = do 27 | rs <- rawInstantiate wasm_mod >>= trapToFail 28 | resumeInstance (isInstance rs) pinst 29 | Stable.imp (isStableMem rs) pmem 30 | return rs 31 | where 32 | trapToFail (Trap err) = fail $ "replay failed: " ++ show err 33 | trapToFail (Return x) = return x 34 | 35 | deriving 36 | via (Snapshot CanisterSnapshot) 37 | instance Purify ImpState CanisterSnapshot 38 | -------------------------------------------------------------------------------- /nix/secp256k1/default.nix: -------------------------------------------------------------------------------- 1 | { lib 2 | , stdenv 3 | , fetchFromGitHub 4 | , autoreconfHook 5 | }: 6 | 7 | stdenv.mkDerivation { 8 | pname = "secp256k1"; 9 | 10 | version = "unstable-2022-05-19"; 11 | 12 | src = fetchFromGitHub { 13 | owner = "bitcoin-core"; 14 | repo = "secp256k1"; 15 | rev = "44c2452fd387f7ca604ab42d73746e7d3a44d8a2"; 16 | sha256 = "sha256-VXs4hwErka+E29r2d4DwJ4Fdtmrpy0vM3mShfNxxgEM"; 17 | }; 18 | 19 | nativeBuildInputs = [ autoreconfHook ]; 20 | 21 | configureFlags = [ 22 | "--enable-benchmark=no" 23 | "--enable-exhaustive-tests=no" 24 | "--enable-experimental" 25 | "--enable-module-ecdh" 26 | "--enable-module-recovery" 27 | "--enable-module-schnorrsig" 28 | "--enable-tests=yes" 29 | ]; 30 | 31 | doCheck = true; 32 | 33 | checkPhase = "./tests"; 34 | 35 | meta = with lib; { 36 | description = "Optimized C library for EC operations on curve secp256k1"; 37 | longDescription = '' 38 | Optimized C library for EC operations on curve secp256k1. Part of 39 | Bitcoin Core. This library is a work in progress and is being used 40 | to research best practices. Use at your own risk. 41 | ''; 42 | homepage = "https://github.com/bitcoin-core/secp256k1"; 43 | license = with licenses; [ mit ]; 44 | maintainers = with maintainers; [ ]; 45 | platforms = with platforms; all; 46 | }; 47 | } 48 | -------------------------------------------------------------------------------- /src/IC/Id/Forms.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Implements the special forms of ids (https://sdk.dfinity.org/docs/interface-spec/index.html#id-classes) 3 | -} 4 | {-# LANGUAGE TypeApplications #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | module IC.Id.Forms where 7 | 8 | import qualified Data.ByteString.Lazy as BS 9 | import IC.Hash 10 | 11 | type Blob = BS.ByteString 12 | 13 | mkOpaqueId :: Blob -> Blob 14 | mkOpaqueId b = 15 | b <> BS.singleton 1 <> BS.singleton 1 16 | 17 | isOpaqueId :: Blob -> Bool 18 | isOpaqueId b = BS.drop (BS.length b - 2) b == BS.singleton 1 <> BS.singleton 1 19 | 20 | mkSelfAuthenticatingId :: Blob -> Blob 21 | mkSelfAuthenticatingId pubkey = 22 | sha224 pubkey <> BS.singleton 2 23 | 24 | isSelfAuthenticatingId :: Blob -> Blob -> Bool 25 | isSelfAuthenticatingId pubkey id = 26 | mkSelfAuthenticatingId pubkey == id 27 | 28 | mkDerivedId :: Blob -> Blob -> Blob 29 | mkDerivedId registering bytes = 30 | sha224 (len_prefixed registering <> bytes) <> BS.singleton 3 31 | 32 | isDerivedId :: Blob -> Blob -> Bool 33 | isDerivedId registering blob = 34 | BS.length blob == 256`div`8 + 8 + 1 && 35 | BS.last blob == 3 && 36 | BS.take (256`div`8) blob == sha224 registering 37 | 38 | isAnonymousId :: Blob -> Bool 39 | isAnonymousId blob = blob == "\x04" 40 | 41 | len_prefixed :: BS.ByteString -> BS.ByteString 42 | len_prefixed s = BS.singleton (fromIntegral (BS.length s)) <> s 43 | -------------------------------------------------------------------------------- /bin/ic-ref-test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# OPTIONS_GHC -Wno-orphans #-} 5 | module Main (main) where 6 | 7 | import Test.Tasty 8 | import Test.Tasty.Options (lookupOption) 9 | import Test.Tasty.Ingredients 10 | import Test.Tasty.Ingredients.Basic 11 | import Test.Tasty.Ingredients.Rerun 12 | import Test.Tasty.Runners.AntXML 13 | import Test.Tasty.Runners.Html 14 | import Test.Tasty.Runners 15 | 16 | import IC.Test.Options 17 | import IC.Test.Agent (preFlight) 18 | import IC.Test.Spec 19 | import qualified IC.Crypto.BLS as BLS 20 | 21 | main :: IO () 22 | main = do 23 | BLS.init 24 | os <- parseOptions ingredients (testGroup "dummy" []) 25 | ac <- preFlight os 26 | let TestSubnet my_sub = lookupOption os 27 | let PeerSubnet other_sub = lookupOption os 28 | defaultMainWithIngredients ingredients (icTests my_sub other_sub ac) 29 | where 30 | ingredients = 31 | [ rerunningTests 32 | [ listingTests 33 | , includingOptions [endpointOption] 34 | , includingOptions [httpbinOption] 35 | , includingOptions [polltimeoutOption] 36 | , includingOptions [testSubnetOption] 37 | , includingOptions [peerSubnetOption] 38 | , includingOptions [allowSelfSignedCertsOption] 39 | , antXMLRunner `composeReporters` htmlRunner `composeReporters` consoleTestReporter 40 | ] 41 | ] 42 | -------------------------------------------------------------------------------- /cbits/randapi.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2012-2020 MIRACL UK Ltd. 3 | * 4 | * This file is part of MIRACL Core 5 | * (see https://github.com/miracl/core). 6 | * 7 | * Licensed under the Apache License, Version 2.0 (the "License"); 8 | * you may not use this file except in compliance with the License. 9 | * You may obtain a copy of the License at 10 | * 11 | * http://www.apache.org/licenses/LICENSE-2.0 12 | * 13 | * Unless required by applicable law or agreed to in writing, software 14 | * distributed under the License is distributed on an "AS IS" BASIS, 15 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 16 | * See the License for the specific language governing permissions and 17 | * limitations under the License. 18 | */ 19 | 20 | /** 21 | * @file randapi.h 22 | * @author Mike Scott 23 | * @brief PRNG API File 24 | * 25 | */ 26 | 27 | #ifndef RANDOM_H 28 | #define RANDOM_H 29 | 30 | #include "core.h" 31 | 32 | /** @brief Initialise a random number generator 33 | * 34 | @param R is a pointer to a cryptographically secure random number generator 35 | @param S is an input truly random seed value 36 | */ 37 | extern void CREATE_CSPRNG(csprng *R, octet *S); 38 | /** @brief Kill a random number generator 39 | * 40 | Deletes all internal state 41 | @param R is a pointer to a cryptographically secure random number generator 42 | */ 43 | extern void KILL_CSPRNG(csprng *R); 44 | 45 | #endif 46 | 47 | -------------------------------------------------------------------------------- /bin/ic-request-id.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main where 3 | 4 | import Options.Applicative 5 | import Control.Monad (join) 6 | import qualified Data.ByteString.Lazy as BS 7 | import qualified Data.Text as T 8 | import qualified Data.Text.IO as T 9 | import qualified Text.Hex as H 10 | import qualified Data.HashMap.Lazy as HM 11 | import System.IO 12 | 13 | 14 | import IC.HTTP.CBOR 15 | import IC.HTTP.GenR 16 | import IC.HTTP.RequestId 17 | 18 | work :: Maybe FilePath -> IO () 19 | work input = do 20 | request <- maybe BS.getContents BS.readFile input 21 | case decode request of 22 | Left err -> do 23 | T.hPutStrLn stderr "Failed to decode CBOR:" 24 | T.hPutStrLn stderr err 25 | Right (GRec m) | Just content <- HM.lookup "content" m -> 26 | T.putStrLn $ H.encodeHex $ BS.toStrict $ requestId content 27 | Right gr -> do 28 | T.hPutStrLn stderr "Request does not look like an envelop (could not find field \"content\"):" 29 | T.hPutStrLn stderr (T.pack (show gr)) 30 | 31 | main :: IO () 32 | main = join . customExecParser (prefs showHelpOnError) $ 33 | info (helper <*> parser) 34 | ( fullDesc 35 | <> header "Internet Computer request id" 36 | <> progDesc "Given a CBOR-encoded request with envelope, calculate the request id" 37 | ) 38 | where 39 | parser :: Parser (IO ()) 40 | parser = 41 | work 42 | <$> optional (strArgument 43 | ( metavar "FILE" 44 | <> help "file to read (default: stdin)" 45 | )) 46 | -------------------------------------------------------------------------------- /src/IC/Certificate/CBOR.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE PatternSynonyms #-} 4 | {-# LANGUAGE ViewPatterns #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | 7 | module IC.Certificate.CBOR (encodeCert, decodeCert) where 8 | 9 | import qualified Data.Text as T 10 | import Codec.CBOR.Term 11 | import Codec.CBOR.Write 12 | 13 | import IC.Certificate 14 | import IC.CBOR.Parser 15 | import IC.CBOR.Patterns 16 | import IC.HashTree 17 | import IC.HashTree.CBOR 18 | 19 | encodeCert :: Certificate -> Blob 20 | encodeCert Certificate{..} = toLazyByteString $ encodeTerm $ TTagged 55799 $ TMap $ 21 | [ (TString "tree", encodeHashTree cert_tree) 22 | , (TString "signature", TBlob cert_sig) 23 | ] ++ 24 | [ (TString "delegation", TMap 25 | [ (TString "subnet_id", TBlob del_subnet_id) 26 | , (TString "certificate", TBlob del_certificate) 27 | ]) 28 | | Just Delegation{..} <- pure cert_delegation 29 | ] 30 | 31 | decodeCert :: Blob -> Either T.Text Certificate 32 | decodeCert s = do 33 | kv <- decodeWithTag s >>= parseMap "certificate" 34 | cert_tree <- parseField "tree" kv >>= parseHashTree 35 | cert_sig <- parseField "signature" kv >>= parseBlob "signature" 36 | cert_delegation <- optionalField "delegation" kv >>= mapM parseDelegation 37 | return $ Certificate{..} 38 | 39 | parseDelegation :: Term -> Either T.Text Delegation 40 | parseDelegation t = do 41 | kv <- parseMap "delegation" t 42 | del_subnet_id <- parseField "subnet_id" kv >>= parseBlob "subnet_id" 43 | del_certificate <- parseField "certificate" kv >>= parseBlob "certificate" 44 | return $ Delegation{..} 45 | -------------------------------------------------------------------------------- /src/IC/Test/Secp256k1.hs: -------------------------------------------------------------------------------- 1 | -- Unit test for IC.Test.Crypto.Secp256k1 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE BinaryLiterals #-} 4 | {-# LANGUAGE ViewPatterns #-} 5 | module IC.Test.Secp256k1 (secp256k1Tests) where 6 | 7 | import qualified Data.ByteString.Lazy as BS 8 | import qualified Data.Text as T 9 | 10 | import Test.Tasty 11 | import Test.Tasty.QuickCheck 12 | import Test.Tasty.HUnit 13 | import Test.QuickCheck.IO () 14 | 15 | import qualified IC.Crypto.Secp256k1 as Secp256k1 16 | 17 | assertRight :: Either T.Text () -> Assertion 18 | assertRight (Right ()) = return () 19 | assertRight (Left err) = assertFailure (T.unpack err) 20 | 21 | assertLeft :: Either T.Text () -> Assertion 22 | assertLeft (Left _) = return () 23 | assertLeft (Right _) = assertFailure "Unexpected success" 24 | 25 | secp256k1Tests :: TestTree 26 | secp256k1Tests = testGroup "Secp256k1 crypto tests" 27 | [ testProperty "create-sign-verify" $ 28 | \(BS.pack -> seed) (BS.pack -> msg) -> do 29 | let sk = Secp256k1.createKey seed 30 | sig <- Secp256k1.sign sk msg 31 | assertRight $ Secp256k1.verify (Secp256k1.toPublicKey sk) msg sig 32 | , testProperty "invalid sig" $ 33 | \(BS.pack -> seed) (BS.pack -> msg) (BS.pack -> sig) -> 34 | let sk = Secp256k1.createKey seed in 35 | assertLeft $ Secp256k1.verify (Secp256k1.toPublicKey sk) msg sig 36 | , testProperty "wrong message" $ 37 | \(BS.pack -> seed) (BS.pack -> msg1) (BS.pack -> msg2) -> 38 | msg1 /= msg2 ==> do 39 | let sk = Secp256k1.createKey seed 40 | sig <- Secp256k1.sign sk msg2 41 | assertLeft $ Secp256k1.verify (Secp256k1.toPublicKey sk) msg1 sig 42 | ] 43 | 44 | -------------------------------------------------------------------------------- /cbits/config_field_BLS12381.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2012-2020 MIRACL UK Ltd. 3 | * 4 | * This file is part of MIRACL Core 5 | * (see https://github.com/miracl/core). 6 | * 7 | * Licensed under the Apache License, Version 2.0 (the "License"); 8 | * you may not use this file except in compliance with the License. 9 | * You may obtain a copy of the License at 10 | * 11 | * http://www.apache.org/licenses/LICENSE-2.0 12 | * 13 | * Unless required by applicable law or agreed to in writing, software 14 | * distributed under the License is distributed on an "AS IS" BASIS, 15 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 16 | * See the License for the specific language governing permissions and 17 | * limitations under the License. 18 | */ 19 | 20 | /** 21 | * @file config_field.h 22 | * @author Mike Scott 23 | * @brief Config Curve Header File 24 | * 25 | */ 26 | 27 | #ifndef CONFIG_FIELD_BLS12381_H 28 | #define CONFIG_FIELD_BLS12381_H 29 | 30 | #include"core.h" 31 | #include "config_big_384_58.h" 32 | 33 | // FP stuff 34 | 35 | #define MBITS_BLS12381 381 /**< Modulus bits */ 36 | #define PM1D2_BLS12381 1 /**< Largest m such that 2^m|(p-1) */ 37 | #define MODTYPE_BLS12381 NOT_SPECIAL /**< Modulus type */ 38 | #define MAXXES_BLS12381 25 /**< Maximum excess for lazy reduction */ 39 | #define QNRI_BLS12381 0 /**< Small Quadratic Non-Residue */ 40 | #define RIADZ_BLS12381 11 /**< Z for hash to Curve */ 41 | #define RIADZG2A_BLS12381 -2 /**< real part of Z in G2 for Hash to Curve */ 42 | #define RIADZG2B_BLS12381 -1 /**< imaginary part of Z in G2 for Hash to Curve */ 43 | #define TOWER_BLS12381 NEGATOWER /**< Postive or Negative towering */ 44 | 45 | #endif 46 | -------------------------------------------------------------------------------- /nix/generated/http-client.nix: -------------------------------------------------------------------------------- 1 | # THIS IS AN AUTOMATICALLY GENERATED FILE. DO NOT EDIT MANUALLY! 2 | # See ./nix/generate.nix for instructions. 3 | 4 | { mkDerivation 5 | , pkgs 6 | , array 7 | , async 8 | , base 9 | , base64-bytestring 10 | , blaze-builder 11 | , bytestring 12 | , case-insensitive 13 | , containers 14 | , cookie 15 | , deepseq 16 | , directory 17 | , exceptions 18 | , filepath 19 | , ghc-prim 20 | , hspec 21 | , hspec-discover 22 | , http-types 23 | , iproute 24 | , lib 25 | , mime-types 26 | , monad-control 27 | , network 28 | , network-uri 29 | , random 30 | , stm 31 | , streaming-commons 32 | , text 33 | , time 34 | , transformers 35 | , zlib 36 | }: 37 | mkDerivation { 38 | pname = "http-client"; 39 | version = "0.7.13.1"; 40 | src = pkgs.sources.http-client; 41 | libraryHaskellDepends = [ 42 | array 43 | async 44 | base 45 | base64-bytestring 46 | blaze-builder 47 | bytestring 48 | case-insensitive 49 | containers 50 | cookie 51 | deepseq 52 | exceptions 53 | filepath 54 | ghc-prim 55 | http-types 56 | iproute 57 | mime-types 58 | network 59 | network-uri 60 | random 61 | stm 62 | streaming-commons 63 | text 64 | time 65 | transformers 66 | ]; 67 | testHaskellDepends = [ 68 | async 69 | base 70 | blaze-builder 71 | bytestring 72 | case-insensitive 73 | containers 74 | cookie 75 | deepseq 76 | directory 77 | hspec 78 | http-types 79 | monad-control 80 | network 81 | network-uri 82 | streaming-commons 83 | text 84 | time 85 | transformers 86 | zlib 87 | ]; 88 | testToolDepends = [ hspec-discover ]; 89 | doCheck = false; 90 | homepage = "https://github.com/snoyberg/http-client"; 91 | description = "An HTTP client engine"; 92 | license = lib.licenses.mit; 93 | } 94 | -------------------------------------------------------------------------------- /cbits/newhope.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2012-2020 MIRACL UK Ltd. 3 | * 4 | * This file is part of MIRACL Core 5 | * (see https://github.com/miracl/core). 6 | * 7 | * Licensed under the Apache License, Version 2.0 (the "License"); 8 | * you may not use this file except in compliance with the License. 9 | * You may obtain a copy of the License at 10 | * 11 | * http://www.apache.org/licenses/LICENSE-2.0 12 | * 13 | * Unless required by applicable law or agreed to in writing, software 14 | * distributed under the License is distributed on an "AS IS" BASIS, 15 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 16 | * See the License for the specific language governing permissions and 17 | * limitations under the License. 18 | */ 19 | 20 | /** 21 | * @file newhope.h 22 | * @author Mike Scott 23 | * @brief Newhope Header File 24 | * 25 | */ 26 | 27 | /* NewHope Simple API */ 28 | 29 | #ifndef NHS_H 30 | #define NHS_H 31 | 32 | #include "core.h" 33 | 34 | /** @brief NHS server first pass 35 | * 36 | @param RNG Random Number Generator handle 37 | @param SB seed and polynomial B concatenated - output 38 | @param S server secret - output 39 | 40 | */ 41 | extern void NHS_SERVER_1(csprng *RNG, octet *SB, octet *S); 42 | /** @brief NHS client pass 43 | * 44 | @param RNG Random Number Generator handle 45 | @param SB seed and polynomial B concatenated - input 46 | @param UC polynomial U and compressed polynomial c - output 47 | @param KEY client key 48 | */ 49 | extern void NHS_CLIENT(csprng *RNG, octet *SB, octet *UC, octet *KEY); 50 | /** @brief NHS server second pass 51 | * 52 | @param S server secret - input 53 | @param UC polynomial U and compressed polynomial c - input 54 | @param KEY server key 55 | */ 56 | extern void NHS_SERVER_2(octet *S, octet *UC, octet *KEY); 57 | 58 | #endif 59 | -------------------------------------------------------------------------------- /src/IC/Purify.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | module IC.Purify where 7 | 8 | import Control.Monad.ST 9 | import Data.Functor 10 | import Data.Kind (Type) 11 | import Data.Either 12 | import Data.Bifunctor 13 | 14 | class SnapshotAble i where 15 | type SnapshotOf i :: Type 16 | persist :: i s -> ST s (SnapshotOf i) 17 | recreate :: SnapshotOf i -> ST s (i s) 18 | 19 | class Purify i a where 20 | create :: (forall s. ST s (i s)) -> a 21 | createMaybe :: (forall s. ST s (b, Either c (i s))) -> (b, Either c a) 22 | perform :: (forall s. i s -> ST s b) -> a -> (a, b) 23 | 24 | newtype Snapshot a = Snapshot a 25 | deriving (Show) 26 | 27 | instance (SnapshotAble i, SnapshotOf i ~ a) => Purify i (Snapshot a) where 28 | create act = Snapshot $ runST $ act >>= persist 29 | 30 | createMaybe act = runST $ do 31 | act >>= \case 32 | (x, Left e) -> return (x, Left e) 33 | (x, Right i) -> do 34 | s' <- persist i 35 | return (x, Right (Snapshot s')) 36 | 37 | perform act (Snapshot s) = runST $ do 38 | i <- recreate s 39 | x <- act i 40 | s' <- persist i 41 | return (Snapshot s', x) 42 | 43 | 44 | newtype Replay i = Replay (forall s. ST s (i s)) 45 | 46 | instance Show (Replay i) where show _ = "Replay ..." 47 | 48 | instance Purify a (Replay a) where 49 | create = Replay 50 | 51 | createMaybe act = runST $ second ($> replay') <$> act 52 | where 53 | replay' = Replay $ fromRight err . snd <$> act 54 | err = error "createMaybe: ST action was not deterministic?" 55 | 56 | perform act (Replay replay) = runST $ do 57 | x <- replay >>= act 58 | return (replay', x) 59 | where 60 | replay' = Replay $ do x <- replay; void (act x); return x 61 | 62 | -------------------------------------------------------------------------------- /src/IC/CBOR/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module IC.CBOR.Parser where 3 | 4 | import Data.Text (Text) 5 | import qualified Data.Text as T 6 | import qualified Data.ByteString.Lazy as BS 7 | import Data.Bifunctor 8 | import Codec.CBOR.Term 9 | import Codec.CBOR.Read 10 | 11 | import IC.CBOR.Patterns 12 | 13 | decodeWithoutTag :: BS.ByteString -> Either Text Term 14 | decodeWithoutTag s = 15 | first (\(DeserialiseFailure _ s) -> "CBOR decoding failure: " <> T.pack s) 16 | (deserialiseFromBytes decodeTerm s) >>= begin 17 | where 18 | begin (leftOver, _) | not (BS.null leftOver) = Left "Left-over bytes" 19 | begin (_, TTagged 55799 _) = Left "Did not expect semantic tag 55799 here" 20 | begin (_, t) = return t 21 | 22 | decodeWithTag :: BS.ByteString -> Either Text Term 23 | decodeWithTag s = 24 | first (\(DeserialiseFailure _ s) -> "CBOR decoding failure: " <> T.pack s) 25 | (deserialiseFromBytes decodeTerm s) >>= begin 26 | where 27 | begin (leftOver, _) | not (BS.null leftOver) = Left "Left-over bytes" 28 | begin (_, TTagged 55799 t) = return t 29 | begin (_, t) = Left $ "Expected certificate to begin with tag 55799, got " <> T.pack (show t) <> " in " <> T.pack (show s) 30 | 31 | parseMap :: Text -> Term -> Either Text [(Term, Term)] 32 | parseMap _ (TMap_ kv) = return kv 33 | parseMap what t = Left $ "expected " <> what <> ", found " <> T.pack (show t) 34 | 35 | parseBlob :: Text -> Term -> Either Text BS.ByteString 36 | parseBlob _ (TBlob s) = return s 37 | parseBlob what t = Left $ "expected " <> what <> ", found " <> T.pack (show t) 38 | 39 | parseField :: Text -> [(Term, a)] -> Either Text a 40 | parseField f kv = case lookup (TString f) kv of 41 | Just t -> return t 42 | Nothing -> Left $ "Missing expected field " <> f 43 | 44 | optionalField :: Text -> [(Term, a)] -> Either Text (Maybe a) 45 | optionalField f kv = return $ lookup (TString f) kv 46 | -------------------------------------------------------------------------------- /src/IC/Test/Agent/Calls.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ImplicitParams #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | {-# LANGUAGE ConstraintKinds #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE BlockArguments #-} 9 | {-# LANGUAGE OverloadedLabels #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# LANGUAGE FlexibleContexts #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE NumericUnderscores #-} 14 | {-# LANGUAGE DataKinds #-} 15 | 16 | module IC.Test.Agent.Calls 17 | where 18 | 19 | import qualified Data.Text as T 20 | import Codec.Candid (Principal(..)) 21 | import qualified Codec.Candid as Candid 22 | import Data.Row 23 | import qualified Data.Row.Records as R 24 | import qualified Data.Row.Internal as R 25 | import qualified Data.Row.Dictionaries as R 26 | 27 | import IC.Management 28 | import IC.Id.Forms 29 | import IC.Test.Agent 30 | 31 | httpbin :: HasAgentConfig => String 32 | httpbin = tc_httpbin agentConfig 33 | 34 | toTransformFn :: Maybe (String, a) -> Blob -> Maybe (Rec ('R.R '[ "context" 'R.:-> a, "function" 'R.:-> Candid.FuncRef r])) 35 | toTransformFn arg cid = fmap (\(n, c) -> empty .+ #function .== (Candid.FuncRef (Principal cid) (T.pack n)) .+ #context .== c) arg 36 | 37 | -- The following line noise is me getting out of my way 38 | -- to be able to use `ic_create` etc. by passing a record that contains 39 | -- a subset of settings, without Maybe 40 | type family UnRec r where UnRec (R.Rec r) = r 41 | type PartialSettings r = (R.Forall r R.Unconstrained1, R.Map Maybe r .// UnRec Settings ≈ UnRec Settings) 42 | fromPartialSettings :: PartialSettings r => R.Rec r -> Settings 43 | fromPartialSettings r = 44 | R.map' Just r .// 45 | R.default' @(R.IsA R.Unconstrained1 Maybe) @(UnRec Settings) d 46 | where 47 | d :: forall a. R.IsA R.Unconstrained1 Maybe a => a 48 | d = case R.as @R.Unconstrained1 @Maybe @a of R.As -> Nothing 49 | -------------------------------------------------------------------------------- /src/SourceId.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | This module exports a source id in a way that works well within a nix build (no 3 | .git available) and outside nix, according to this logic: 4 | 5 | * If `git` works, use `git describe` 6 | * Else, if $out is set (so this is a nix build), extract an identifer from the out hash 7 | * Else, it says something like unidentified build. 8 | 9 | This is an early experiment. If successful, this logic ought to move into a 10 | library, and maybe also implemented for rust artifacts. (see RPL-101) 11 | 12 | Note that cabal build will not recompile this module if it does not have to, so in local development, this is less reliable than it should. See 13 | https://www.joachim-breitner.de/blog/772-Template_Haskell_recompilation 14 | for more details. 15 | 16 | -} 17 | {-# LANGUAGE TemplateHaskell #-} 18 | {-# LANGUAGE LambdaCase #-} 19 | {-# LANGUAGE ScopedTypeVariables #-} 20 | module SourceId where 21 | 22 | import Language.Haskell.TH 23 | import Control.Monad 24 | import Data.List 25 | import Data.List.Split 26 | import System.Process 27 | import System.Environment 28 | import Control.Exception 29 | 30 | id :: String 31 | id = $(stringE <=< runIO $ do 32 | -- Leniently calls git, and removes final newline from git’s output 33 | let readGit args = intercalate "\n" . lines <$> catch 34 | (readCreateProcess ((proc "git" args) {std_err = CreatePipe}) "") 35 | (\(_ :: IOException) -> return "") 36 | 37 | inGit <- readGit ["rev-parse", "--is-inside-work-tree"] 38 | if inGit == "true" 39 | then readGit ["describe", "--tags", "--match=v*", "--dirty"] 40 | else lookupEnv "out" >>= \case 41 | Just path 42 | | ["","nix","store",base] <- splitOn "/" path 43 | , let hash = takeWhile (/= '-') base 44 | -> return $ intercalate "-" (chunksOf 8 hash) 45 | Just path -> fail $ "SouceId: unparsable $out=" ++ path 46 | Nothing -> return "unidentified" 47 | ) 48 | -------------------------------------------------------------------------------- /src/IC/Crypto/ECDSA.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# OPTIONS_GHC -Wno-orphans #-} 5 | module IC.Crypto.ECDSA 6 | ( SecretKey 7 | , createKey 8 | , toPublicKey 9 | , IC.Crypto.ECDSA.sign 10 | , IC.Crypto.ECDSA.verify 11 | ) where 12 | 13 | import qualified Data.ByteString.Lazy as BS 14 | import Crypto.ECC 15 | import Crypto.Error 16 | import Crypto.Random 17 | import Crypto.PubKey.ECDSA 18 | import Crypto.Hash.Algorithms 19 | import Crypto.Number.Serialize 20 | import Data.Proxy 21 | import Data.Hashable 22 | 23 | newtype SecretKey = SecretKey (KeyPair Curve_P256R1) 24 | deriving Show 25 | 26 | deriving instance Show (KeyPair Curve_P256R1) 27 | 28 | 29 | createKey :: BS.ByteString -> SecretKey 30 | createKey seed = 31 | SecretKey $ fst $ withDRG drg (curveGenerateKeyPair Proxy) 32 | where 33 | drg = drgNewSeed $ seedFromInteger $ fromIntegral $ hash seed 34 | 35 | toPublicKey :: SecretKey -> BS.ByteString 36 | toPublicKey (SecretKey kp) = 37 | BS.fromStrict $ encodePublic (Proxy @Curve_P256R1) $ keypairGetPublic kp 38 | 39 | sign :: SecretKey -> BS.ByteString -> IO BS.ByteString 40 | sign (SecretKey kp) msg = do 41 | (r,s) <- signatureToIntegers Proxy <$> 42 | Crypto.PubKey.ECDSA.sign (Proxy @Curve_P256R1) (keypairGetPrivate kp) SHA256 (BS.toStrict msg) 43 | return $ BS.fromStrict $ i2ospOf_ 32 r <> i2ospOf_ 32 s 44 | 45 | verify :: BS.ByteString -> BS.ByteString -> BS.ByteString -> Bool 46 | verify pk msg sig 47 | | CryptoPassed pk <- decodePublic (Proxy @Curve_P256R1) (BS.toStrict pk) 48 | , BS.length sig == 64 49 | , (rb,sb) <- BS.splitAt 32 sig 50 | , let r = os2ip $ BS.toStrict rb 51 | , let s = os2ip $ BS.toStrict sb 52 | , CryptoPassed sig <- signatureFromIntegers (Proxy @Curve_P256R1) (r, s) 53 | = Crypto.PubKey.ECDSA.verify 54 | (Proxy @Curve_P256R1) 55 | SHA256 56 | pk 57 | sig 58 | (BS.toStrict msg) 59 | | otherwise = False 60 | 61 | -------------------------------------------------------------------------------- /src/IC/Test/BLS.hs: -------------------------------------------------------------------------------- 1 | -- Unit test for IC.Test.Crypto.BLS 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE BinaryLiterals #-} 4 | {-# LANGUAGE ViewPatterns #-} 5 | module IC.Test.BLS (blsTests) where 6 | 7 | import Test.Tasty 8 | import Test.Tasty.QuickCheck 9 | import qualified Data.ByteString.Lazy as BS 10 | import Data.Bits 11 | 12 | import qualified IC.Crypto.BLS as BLS 13 | 14 | blsTests :: TestTree 15 | blsTests = testGroup "BLS crypto tests" 16 | [ testProperty "public key is 96 bytes" $ 17 | \(BS.pack -> seed) -> 18 | let sk = BLS.createKey seed in 19 | let pk = BLS.toPublicKey sk in 20 | BS.length pk === 96 21 | , testProperty "public key high bits are either 0b100 or 0b100" $ 22 | \(BS.pack -> seed) -> 23 | let sk = BLS.createKey seed in 24 | let pk = BLS.toPublicKey sk in 25 | BS.head pk `shiftR` 5 === 0b100 .||. BS.head pk `shiftR` 5 === 0b101 26 | , testProperty "signature is 48 bytes" $ 27 | \(BS.pack -> seed) (BS.pack -> msg) -> 28 | let sk = BLS.createKey seed in 29 | let sig = BLS.sign sk msg in 30 | BS.length sig === 48 31 | , testProperty "signature high bits are either 0b100 or 0b100" $ 32 | \(BS.pack -> seed) (BS.pack -> msg) -> 33 | let sk = BLS.createKey seed in 34 | let sig = BLS.sign sk msg in 35 | BS.head sig `shiftR` 5 === 0b100 .||. BS.head sig `shiftR` 5 === 0b101 36 | , testProperty "create-sign-verify" $ 37 | \(BS.pack -> seed) (BS.pack -> msg) -> 38 | let sk = BLS.createKey seed in 39 | let sig = BLS.sign sk msg in 40 | BLS.verify (BLS.toPublicKey sk) msg sig 41 | , testProperty "invalid sig" $ 42 | \(BS.pack -> seed) (BS.pack -> msg) (BS.pack -> sig) -> 43 | let sk = BLS.createKey seed in 44 | not (BLS.verify (BLS.toPublicKey sk) msg sig) 45 | , testProperty "wrong message" $ 46 | \(BS.pack -> seed) (BS.pack -> msg1) (BS.pack -> msg2) -> 47 | let sk = BLS.createKey seed in 48 | let sig = BLS.sign sk msg2 in 49 | msg1 /= msg2 ==> not (BLS.verify (BLS.toPublicKey sk) msg1 sig) 50 | ] 51 | 52 | -------------------------------------------------------------------------------- /src/IC/Test/Spec/TECDSA.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE OverloadedLabels #-} 5 | {-# LANGUAGE NumericUnderscores #-} 6 | {-# LANGUAGE TupleSections #-} 7 | {-# LANGUAGE NamedFieldPuns #-} 8 | 9 | module IC.Test.Spec.TECDSA (tests) where 10 | 11 | import Test.Tasty 12 | import qualified Data.Vector as Vec 13 | import IC.Test.Spec.Utils 14 | import IC.Test.Agent 15 | import IC.Test.Agent.UnsafeCalls 16 | import IC.Test.Agent.SafeCalls 17 | import Data.Row as R 18 | import Test.Tasty.HUnit 19 | import IC.Test.Universal (noop) 20 | import IC.Hash (sha256) 21 | 22 | tests :: HasAgentConfig => Blob -> TestTree 23 | tests ecid = testGroup "tECDSA" 24 | [ testCase "sign and verify" $ do 25 | cid <- install ecid noop 26 | cid2 <- install ecid noop 27 | sig1 <- ic_sign_with_ecdsa (ic00via cid) cid (sha256 "internet computer") 28 | sig2 <- ic_sign_with_ecdsa (ic00via cid2) cid2 (sha256 "internet computer") 29 | -- if canister id is unset, default to a caller id 30 | pk1 <- ic_ecdsa_public_key (ic00via cid) cid Nothing Vec.empty 31 | pk2 <- ic_ecdsa_public_key (ic00via cid) cid (Just cid2) Vec.empty 32 | 33 | assertBool "incorrect signature" $ verifySignature (sha256 "internet computer") (sig1 .! #signature) (pk1 .! #public_key) 34 | assertBool "correct signature, should be incorrect" $ not $ verifySignature (sha256 "internet computer") (sig1 .! #signature) (pk2 .! #public_key) 35 | assertBool "incorrect signature" $ not $ verifySignature (sha256 "internet computer") (sig2 .! #signature) (pk1 .! #public_key) 36 | assertBool "correct signature, should be incorrect" $ verifySignature (sha256 "internet computer") (sig2 .! #signature) (pk2 .! #public_key) 37 | 38 | , simpleTestCase "invalid derivation path" ecid $ \cid -> do 39 | ic_ecdsa_public_key' (ic00via cid) cid Nothing (Vec.singleton "clearly not Word32") >>= isReject [5] 40 | 41 | , simpleTestCase "id of non-existent canister" ecid $ \cid -> do 42 | ic_ecdsa_public_key' (ic00via cid) cid (Just "Clearly not a valid EntityId") Vec.empty >>= isReject [3] 43 | ] 44 | -------------------------------------------------------------------------------- /nix/generated/candid.nix: -------------------------------------------------------------------------------- 1 | # THIS IS AN AUTOMATICALLY GENERATED FILE. DO NOT EDIT MANUALLY! 2 | # See ./nix/generate.nix for instructions. 3 | 4 | { mkDerivation 5 | , pkgs 6 | , base 7 | , base32 8 | , bytestring 9 | , cereal 10 | , constraints 11 | , containers 12 | , crc 13 | , directory 14 | , dlist 15 | , doctest 16 | , file-embed 17 | , filepath 18 | , hex-text 19 | , leb128-cereal 20 | , lib 21 | , megaparsec 22 | , mtl 23 | , optparse-applicative 24 | , parser-combinators 25 | , prettyprinter 26 | , row-types 27 | , scientific 28 | , smallcheck 29 | , split 30 | , tasty 31 | , tasty-hunit 32 | , tasty-quickcheck 33 | , tasty-rerun 34 | , tasty-smallcheck 35 | , template-haskell 36 | , text 37 | , transformers 38 | , unordered-containers 39 | , vector 40 | }: 41 | mkDerivation { 42 | pname = "candid"; 43 | version = "0.4"; 44 | src = pkgs.sources.haskell-candid; 45 | isLibrary = true; 46 | isExecutable = true; 47 | libraryHaskellDepends = [ 48 | base 49 | base32 50 | bytestring 51 | cereal 52 | constraints 53 | containers 54 | crc 55 | dlist 56 | file-embed 57 | hex-text 58 | leb128-cereal 59 | megaparsec 60 | mtl 61 | parser-combinators 62 | prettyprinter 63 | row-types 64 | scientific 65 | split 66 | template-haskell 67 | text 68 | transformers 69 | unordered-containers 70 | vector 71 | ]; 72 | executableHaskellDepends = [ 73 | base 74 | bytestring 75 | hex-text 76 | optparse-applicative 77 | prettyprinter 78 | text 79 | ]; 80 | testHaskellDepends = [ 81 | base 82 | bytestring 83 | directory 84 | doctest 85 | filepath 86 | leb128-cereal 87 | prettyprinter 88 | row-types 89 | smallcheck 90 | tasty 91 | tasty-hunit 92 | tasty-quickcheck 93 | tasty-rerun 94 | tasty-smallcheck 95 | template-haskell 96 | text 97 | unordered-containers 98 | vector 99 | ]; 100 | homepage = "https://github.com/nomeata/haskell-candid"; 101 | description = "Candid integration"; 102 | license = lib.licenses.asl20; 103 | mainProgram = "hcandid"; 104 | } 105 | -------------------------------------------------------------------------------- /src/IC/Certificate/Validate.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module IC.Certificate.Validate (validateCertificate) where 3 | 4 | import qualified Data.Text as T 5 | import qualified Data.ByteString.Lazy as BS 6 | import qualified Text.Hex as H 7 | import Control.Monad.Error.Class 8 | 9 | import IC.Crypto.DER_BLS 10 | import IC.Types 11 | import IC.Certificate 12 | import IC.Certificate.CBOR 13 | import IC.HashTree hiding (Blob) 14 | 15 | validateCertificate :: Blob -> Certificate -> Either T.Text () 16 | validateCertificate = validate' "certificate" 17 | 18 | validate' :: T.Text -> Blob -> Certificate -> Either T.Text () 19 | validate' what root_key cert = do 20 | pk <- validateDelegation root_key (cert_delegation cert) 21 | verboseVerify what "ic-state-root" pk (reconstruct (cert_tree cert)) (cert_sig cert) 22 | 23 | validateDelegation :: Blob -> Maybe Delegation -> Either T.Text Blob 24 | validateDelegation root_key Nothing = return root_key 25 | validateDelegation root_key (Just del) = do 26 | cert <- decodeCert (del_certificate del) 27 | case wellFormed (cert_tree cert) of 28 | Left err -> throwError $ "Hash tree not well formed: " <> T.pack err 29 | Right () -> return () 30 | validate' "certificate delegation" root_key cert 31 | 32 | case lookupPath (cert_tree cert) ["subnet", del_subnet_id del, "public_key"] of 33 | Found b -> return b 34 | x -> throwError $ "Expected to find subnet public key in certificate, " <> 35 | "but got " <> T.pack (show x) 36 | 37 | verboseVerify :: T.Text -> Blob -> Blob -> Blob -> Blob -> Either T.Text () 38 | verboseVerify what domain_sep pk msg sig = 39 | case verify domain_sep pk msg sig of 40 | Left err -> throwError $ T.unlines 41 | [ "Signature verification failed on " <> what 42 | , err 43 | , "Domain separator: " <> T.pack (prettyBlob domain_sep) 44 | , "Public key (DER): " <> T.pack (asHex pk) 45 | , "Signature: " <> T.pack (asHex sig) 46 | , "Checked message: " <> T.pack (prettyBlob msg) 47 | ] 48 | Right () -> return () 49 | 50 | asHex :: Blob -> String 51 | asHex = T.unpack . H.encodeHex . BS.toStrict 52 | 53 | -------------------------------------------------------------------------------- /src/IC/DRun/Parse.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | module IC.DRun.Parse where 3 | 4 | import qualified Data.ByteString.Lazy.Char8 as B 5 | import qualified Text.Hex as H 6 | import qualified Data.Text as T 7 | import Data.ByteString.Base32 8 | import Control.Exception 9 | 10 | type MethodName = String 11 | type Payload = B.ByteString 12 | type Id = B.ByteString 13 | 14 | data Ingress 15 | = Create Id 16 | | Install Id FilePath Payload 17 | | Reinstall Id FilePath Payload 18 | | Upgrade Id FilePath Payload 19 | | Update Id MethodName Payload 20 | | Query Id MethodName Payload 21 | deriving Show 22 | 23 | parseFile :: FilePath -> IO [Ingress] 24 | parseFile input = do 25 | x <- parse <$> readFile input 26 | _ <- evaluate (show x) -- hack to evaluate until we have a proper parser 27 | return x 28 | 29 | parse :: String -> [Ingress] 30 | parse = map parseLine . lines 31 | 32 | parseLine :: String -> Ingress 33 | parseLine l = case words l of 34 | ["create", i] -> Create (parseId i) 35 | ["install", i, f, a] -> Install (parseId i) f (parseArg a) 36 | ["reinstall", i, f, a] -> Reinstall (parseId i) f (parseArg a) 37 | ["upgrade", i, f, a] -> Upgrade (parseId i) f (parseArg a) 38 | ["ingress", i, m, a] -> Update (parseId i) m (parseArg a) 39 | ["query", i, m, a] -> Query (parseId i) m (parseArg a) 40 | _ -> error $ "Cannot parse: " ++ show l 41 | 42 | -- TODO: Implement proper and extract in own module 43 | parseId :: String -> Id 44 | parseId s = case B.fromStrict <$> decodeBase32Unpadded (B.toStrict (B.pack (filter (/= '-') s))) of 45 | Right bytes -> 46 | if B.length bytes >= 4 47 | then B.drop 4 bytes 48 | else error "Too short id" 49 | Left err -> error $ "Invalid canister id: " ++ T.unpack err 50 | 51 | parseArg :: String -> Payload 52 | parseArg ('0':'x':xs) 53 | | Just x <- B.fromStrict <$> H.decodeHex (T.pack xs) = x 54 | parseArg ('"':xs) 55 | = B.pack $ go xs 56 | where 57 | go "" = error "Missing terminating \"" 58 | go "\"" = [] 59 | go ('\\':'x':a:b:ys) 60 | | Just h <- H.decodeHex (T.pack [a,b]) 61 | = B.unpack (B.fromStrict h) ++ go ys 62 | go (c:ys) = c : go ys 63 | parseArg x = error $ "Invalid argument " ++ x 64 | 65 | 66 | -------------------------------------------------------------------------------- /nix/generated/winter.nix: -------------------------------------------------------------------------------- 1 | # THIS IS AN AUTOMATICALLY GENERATED FILE. DO NOT EDIT MANUALLY! 2 | # See ./nix/generate.nix for instructions. 3 | 4 | { mkDerivation 5 | , pkgs 6 | , array 7 | , base 8 | , binary 9 | , byte-order 10 | , bytestring 11 | , cmdargs 12 | , containers 13 | , data-default-class 14 | , data-fix 15 | , deepseq 16 | , directory 17 | , filepath 18 | , FloatingHex 19 | , lib 20 | , lifted-base 21 | , microlens-platform 22 | , monad-control 23 | , mtl 24 | , nats 25 | , parsec 26 | , primitive 27 | , primitive-unaligned 28 | , process 29 | , tasty 30 | , tasty-hunit 31 | , tasty-quickcheck 32 | , temporary 33 | , text 34 | , transformers 35 | , vector 36 | }: 37 | mkDerivation { 38 | pname = "winter"; 39 | version = "1.0.0"; 40 | src = pkgs.sources.winter; 41 | isLibrary = true; 42 | isExecutable = true; 43 | libraryHaskellDepends = [ 44 | array 45 | base 46 | binary 47 | byte-order 48 | bytestring 49 | containers 50 | data-default-class 51 | data-fix 52 | deepseq 53 | FloatingHex 54 | lifted-base 55 | microlens-platform 56 | monad-control 57 | mtl 58 | nats 59 | parsec 60 | primitive 61 | primitive-unaligned 62 | text 63 | transformers 64 | vector 65 | ]; 66 | executableHaskellDepends = [ 67 | base 68 | binary 69 | bytestring 70 | cmdargs 71 | containers 72 | data-default-class 73 | mtl 74 | parsec 75 | text 76 | vector 77 | ]; 78 | testHaskellDepends = [ 79 | array 80 | base 81 | binary 82 | bytestring 83 | containers 84 | data-default-class 85 | data-fix 86 | deepseq 87 | directory 88 | filepath 89 | FloatingHex 90 | lifted-base 91 | microlens-platform 92 | monad-control 93 | mtl 94 | parsec 95 | primitive 96 | process 97 | tasty 98 | tasty-hunit 99 | tasty-quickcheck 100 | temporary 101 | text 102 | transformers 103 | vector 104 | ]; 105 | doCheck = false; 106 | homepage = "https://github.com/dfinity/winter"; 107 | description = "Haskell port of the WebAssembly OCaml reference interpreter"; 108 | license = lib.licenses.mit; 109 | mainProgram = "wasm-invoke"; 110 | } 111 | -------------------------------------------------------------------------------- /src/IC/Constants.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NumericUnderscores #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE OverloadedLabels #-} 5 | {-# LANGUAGE DataKinds #-} 6 | 7 | module IC.Constants where 8 | 9 | import qualified Data.Word as W 10 | import Numeric.Natural 11 | 12 | import IC.Types 13 | 14 | cDEFAULT_PROVISIONAL_CYCLES_BALANCE :: Natural 15 | cDEFAULT_PROVISIONAL_CYCLES_BALANCE = 100_000_000_000_000 16 | 17 | -- Subnets 18 | 19 | canister_ids_per_subnet :: W.Word64 20 | canister_ids_per_subnet = 1_048_576 21 | 22 | nth_canister_range :: W.Word64 -> (W.Word64, W.Word64) 23 | nth_canister_range n = (n * canister_ids_per_subnet, (n + 1) * canister_ids_per_subnet - 1) 24 | 25 | -- reference_subnet_size is used for scaling cycle cost 26 | -- and must never be set to zero! 27 | reference_subnet_size :: W.Word64 28 | reference_subnet_size = 13 29 | 30 | -- Canister http_request limits 31 | max_request_bytes_limit :: W.Word64 32 | max_request_bytes_limit = 2_000_000 33 | 34 | max_response_bytes_limit :: W.Word64 35 | max_response_bytes_limit = 2_000_000 36 | 37 | max_http_request_url_length :: W.Word64 38 | max_http_request_url_length = 8192 39 | 40 | http_headers_max_number :: Int 41 | http_headers_max_number = 64 42 | 43 | http_headers_max_name_value_length :: W.Word64 44 | http_headers_max_name_value_length = 8 * 1024 -- 8 KiB 45 | 46 | http_headers_max_total_size :: W.Word64 47 | http_headers_max_total_size = 48 * 1024 -- 48 KiB 48 | 49 | getHttpRequestBaseFee :: SubnetType -> W.Word64 50 | getHttpRequestBaseFee Application = 3000000 51 | getHttpRequestBaseFee VerifiedApplication = 3000000 52 | getHttpRequestBaseFee System = 0 53 | 54 | getHttpRequestPerSubnetSizeFee :: SubnetType -> W.Word64 55 | getHttpRequestPerSubnetSizeFee Application = 60000 56 | getHttpRequestPerSubnetSizeFee VerifiedApplication = 60000 57 | getHttpRequestPerSubnetSizeFee System = 0 58 | 59 | getHttpRequestPerRequestByteFee :: SubnetType -> W.Word64 60 | getHttpRequestPerRequestByteFee Application = 400 61 | getHttpRequestPerRequestByteFee VerifiedApplication = 400 62 | getHttpRequestPerRequestByteFee System = 0 63 | 64 | getHttpRequestPerResponseByteFee :: SubnetType -> W.Word64 65 | getHttpRequestPerResponseByteFee Application = 800 66 | getHttpRequestPerResponseByteFee VerifiedApplication = 800 67 | getHttpRequestPerResponseByteFee System = 0 68 | -------------------------------------------------------------------------------- /src/IC/Crypto/DER_BLS.hs: -------------------------------------------------------------------------------- 1 | -- This module is a bit like IC.Crypto.DER, but only handles BLS signature 2 | -- checking 3 | -- 4 | -- This is used in IC.Crypto.CanisterSig to check signatures (which are only 5 | -- BLS), and breaks the module cycle 6 | 7 | {-# LANGUAGE OverloadedStrings #-} 8 | module IC.Crypto.DER_BLS (verify) where 9 | 10 | import qualified Data.Text as T 11 | import qualified Data.ByteString.Lazy as BS 12 | import Data.ASN1.Types 13 | import Data.ASN1.BitArray 14 | import Data.Int 15 | import Control.Monad 16 | import Control.Monad.Error.Class 17 | 18 | import IC.Crypto.DER.Decode 19 | import qualified IC.Crypto.BLS as BLS 20 | 21 | blsAlgoOID :: OID 22 | blsAlgoOID = [1,3,6,1,4,1,44668,5,3,1,2,1] 23 | blsCurveOID :: OID 24 | blsCurveOID = [1,3,6,1,4,1,44668,5,3,2,1] 25 | 26 | decode :: BS.ByteString -> Either T.Text BS.ByteString 27 | decode bs = case safeDecode bs of 28 | Left err -> Left $ "Could not decode DER: " <> T.pack err 29 | Right asn -> case asn of 30 | [ Start Sequence 31 | , Start Sequence 32 | , OID algo 33 | , OID curve 34 | , End Sequence 35 | , BitString ba 36 | , End Sequence 37 | ] 38 | | algo == blsAlgoOID && curve == blsCurveOID 39 | -> Right (BS.fromStrict (bitArrayGetData ba)) 40 | | otherwise 41 | -> Left $ "Unexpected cipher: algo = " <> T.pack (show algo) <> " curve = " <> T.pack (show curve) 42 | _ -> Left $ "Unexpected DER shape: " <> T.pack (show asn) 43 | 44 | verify :: BS.ByteString -> BS.ByteString -> BS.ByteString -> BS.ByteString -> Either T.Text () 45 | verify domain_sep der_pk payload sig = do 46 | pk <- decode der_pk 47 | assertLen "BLS public key" 96 pk 48 | assertLen "BLS signature" 48 sig 49 | 50 | unless (BLS.verify pk msg sig) $ do 51 | when (BLS.verify pk payload sig) $ 52 | throwError $ "domain separator " <> T.pack (show domain_sep) <> " missing" 53 | throwError "signature verification failed" 54 | where 55 | msg = BS.singleton (fromIntegral (BS.length domain_sep)) <> domain_sep <> payload 56 | 57 | 58 | assertLen :: T.Text -> Int64 -> BS.ByteString -> Either T.Text () 59 | assertLen what len bs 60 | | BS.length bs == len = return () 61 | | otherwise = throwError $ what <> " has wrong length " <> T.pack (show (BS.length bs)) <> ", expected " <> T.pack (show len) 62 | -------------------------------------------------------------------------------- /src/IC/HTTP/CBOR.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TupleSections #-} 3 | {- | 4 | Encoding from generic requests/responses to/from CBOR 5 | -} 6 | module IC.HTTP.CBOR where 7 | 8 | import IC.HTTP.GenR 9 | import qualified Data.HashMap.Lazy as HM 10 | import Codec.CBOR.Term 11 | import Codec.CBOR.Write 12 | import Codec.CBOR.Read 13 | import Data.ByteString.Builder (Builder) 14 | import qualified Data.ByteString.Lazy as BS 15 | import Data.ByteString.Lazy (ByteString) 16 | import Data.Bifunctor 17 | import qualified Data.Text as T 18 | import Control.Monad 19 | 20 | encode :: GenR -> Builder 21 | encode r = toBuilder $ encodeTerm $ TTagged 55799 $ go r 22 | where 23 | go (GNat n) = TInteger (fromIntegral n) 24 | go (GText t) = TString t 25 | go (GBlob b) = TBytes (BS.toStrict b) 26 | go (GRec m) = TMap [ (TString k, go v) | (k,v) <- HM.toList m ] 27 | go (GList xs) = TList (map go xs) 28 | 29 | decode :: ByteString -> Either T.Text GenR 30 | decode s = 31 | first (\(DeserialiseFailure _ s) -> "CBOR decoding failure: " <> T.pack s) 32 | (deserialiseFromBytes decodeTerm s) 33 | >>= begin 34 | where 35 | begin (leftOver, _) 36 | | not (BS.null leftOver) = Left $ "Left-over bytes: " <> shorten 20 (T.pack (show leftOver)) 37 | begin (_, TTagged 55799 t) = go t 38 | begin _ = Left "Expected CBOR request to begin with tag 55799" 39 | 40 | shorten :: Int -> T.Text -> T.Text 41 | shorten n s = a <> (if T.null b then "" else "...") 42 | where (a,b) = T.splitAt n s 43 | 44 | go (TBool b) = return $ GBool b 45 | go (TInt n) | n < 0 = Left "Negative integer" 46 | go (TInt n) = return $ GNat (fromIntegral n) 47 | go (TInteger n) | n < 0 = Left "Negative integer" 48 | go (TInteger n) = return $ GNat (fromIntegral n) 49 | go (TBytes b) = return $ GBlob $ BS.fromStrict b 50 | go (TString t) = return $ GText t 51 | go (TMap kv) = goMap kv 52 | go (TMapI kv) = goMap kv 53 | go (TList vs) = GList <$> mapM go vs 54 | go (TListI vs) = GList <$> mapM go vs 55 | go t = Left $ "Unexpected term: " <> T.pack (show t) 56 | 57 | goMap kv = do 58 | tv <- mapM keyVal kv 59 | let hm = HM.fromList tv 60 | when (HM.size hm < length tv) $ Left "Duplicate keys in CBOR map" 61 | return (GRec hm) 62 | 63 | keyVal (TString k,v) = (k,) <$> go v 64 | keyVal _ = Left "Non-string key in CBOR map" 65 | -------------------------------------------------------------------------------- /src/IC/Test/WebAuthn.hs: -------------------------------------------------------------------------------- 1 | -- Unit test for IC.Test.Crypto.WebAuthn 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE BinaryLiterals #-} 4 | {-# LANGUAGE ViewPatterns #-} 5 | module IC.Test.WebAuthn (webAuthnTests) where 6 | 7 | import qualified Data.ByteString.Lazy as BS 8 | import qualified Data.Text as T 9 | 10 | import Test.Tasty 11 | import Test.Tasty.QuickCheck 12 | import Test.Tasty.HUnit 13 | import Test.QuickCheck.IO () 14 | 15 | import qualified IC.Crypto.WebAuthn as WebAuthn 16 | 17 | assertRight :: Either T.Text () -> Assertion 18 | assertRight (Right ()) = return () 19 | assertRight (Left err) = assertFailure (T.unpack err) 20 | 21 | assertLeft :: Either T.Text () -> Assertion 22 | assertLeft (Left _) = return () 23 | assertLeft (Right _) = assertFailure "Unexpected success" 24 | 25 | webAuthnTests :: TestTree 26 | webAuthnTests = testGroup "WebAuthn crypto tests" 27 | [ testProperty "ECDSA: create-sign-verify" $ 28 | \(BS.pack -> seed) (BS.pack -> msg) -> do 29 | let sk = WebAuthn.createECDSAKey seed 30 | sig <- WebAuthn.sign sk msg 31 | assertRight $ WebAuthn.verify (WebAuthn.toPublicKey sk) msg sig 32 | , testProperty "ECDSA: invalid sig" $ 33 | \(BS.pack -> seed) (BS.pack -> msg) (BS.pack -> sig) -> 34 | let sk = WebAuthn.createECDSAKey seed in 35 | assertLeft $ WebAuthn.verify (WebAuthn.toPublicKey sk) msg sig 36 | , testProperty "ECDSA: wrong message" $ 37 | \(BS.pack -> seed) (BS.pack -> msg1) (BS.pack -> msg2) -> 38 | msg1 /= msg2 ==> do 39 | let sk = WebAuthn.createECDSAKey seed 40 | sig <- WebAuthn.sign sk msg2 41 | assertLeft $ WebAuthn.verify (WebAuthn.toPublicKey sk) msg1 sig 42 | , testProperty "RSA: create-sign-verify" $ 43 | \(BS.pack -> seed) (BS.pack -> msg) -> do 44 | let sk = WebAuthn.createRSAKey seed 45 | sig <- WebAuthn.sign sk msg 46 | assertRight $ WebAuthn.verify (WebAuthn.toPublicKey sk) msg sig 47 | , testProperty "RSA: invalid sig" $ 48 | \(BS.pack -> seed) (BS.pack -> msg) (BS.pack -> sig) -> 49 | let sk = WebAuthn.createRSAKey seed in 50 | assertLeft $ WebAuthn.verify (WebAuthn.toPublicKey sk) msg sig 51 | , testProperty "RSA: wrong message" $ 52 | \(BS.pack -> seed) (BS.pack -> msg1) (BS.pack -> msg2) -> 53 | msg1 /= msg2 ==> do 54 | let sk = WebAuthn.createRSAKey seed 55 | sig <- WebAuthn.sign sk msg2 56 | assertLeft $ WebAuthn.verify (WebAuthn.toPublicKey sk) msg1 sig 57 | ] 58 | 59 | -------------------------------------------------------------------------------- /src/IC/Ref/IO.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLabels #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module IC.Ref.IO (sendHttpRequest) where 5 | 6 | import qualified Data.ByteString as BS 7 | import qualified Data.ByteString.Lazy as LBS 8 | import qualified Data.CaseInsensitive as CI 9 | import qualified Data.Row as R 10 | import qualified Data.Text as T 11 | import qualified Data.Text.Encoding as T 12 | import qualified Data.Vector as Vec 13 | import qualified Data.X509 as C 14 | import qualified Data.X509.CertificateStore as C 15 | import qualified Data.X509.Validation as C 16 | import qualified Network.Connection as C 17 | import qualified Network.TLS as C 18 | import qualified Network.TLS.Extra.Cipher as C 19 | import qualified Network.HTTP.Client as C 20 | import qualified Network.HTTP.Client.TLS as C 21 | import Network.HTTP.Types.Status (statusCode) 22 | import Control.Exception 23 | import Data.CaseInsensitive (original) 24 | import Data.Default.Class (def) 25 | import Data.Row ((.==), (.+)) 26 | 27 | import IC.Management (HttpResponse) 28 | 29 | sendHttpRequest :: [C.SignedCertificate] -> T.Text -> BS.ByteString -> [(CI.CI BS.ByteString, BS.ByteString)] -> LBS.ByteString -> IO (Either String HttpResponse) 30 | sendHttpRequest certs url method headers body = do 31 | let validate = \ca_store -> C.validateDefault (C.makeCertificateStore $ certs ++ (C.listCertificates ca_store)) 32 | let client_params = (C.defaultParamsClient "" BS.empty) { 33 | C.clientHooks = def {C.onServerCertificate = validate} 34 | , C.clientSupported = def { C.supportedCiphers = C.ciphersuite_default } 35 | } 36 | let manager_settings = C.mkManagerSettings (C.TLSSettings client_params) Nothing 37 | m <- C.newTlsManagerWith manager_settings 38 | initReq <- C.parseRequest (T.unpack url) 39 | let req = initReq { 40 | C.method = method, 41 | C.requestHeaders = headers, 42 | C.requestBody = C.RequestBodyLBS body 43 | } 44 | resp <- try (C.httpLbs req m) :: IO (Either SomeException (C.Response LBS.ByteString)) 45 | case resp of 46 | Left e -> return $ Left $ show e 47 | Right r -> return $ Right $ toHttpResponse r 48 | where 49 | toHeaderEntry (n, v) = R.empty 50 | .+ #name .== (T.decodeUtf8 (original n)) 51 | .+ #value .== (T.decodeUtf8 v) 52 | toHttpResponse r = R.empty 53 | .+ #status .== (fromIntegral (statusCode $ C.responseStatus r)) 54 | .+ #headers .== (Vec.fromList $ map toHeaderEntry (C.responseHeaders r)) 55 | .+ #body .== (C.responseBody r) 56 | -------------------------------------------------------------------------------- /nix/default.nix: -------------------------------------------------------------------------------- 1 | { system ? builtins.currentSystem }: 2 | let 3 | sourcesnix = builtins.fetchurl { 4 | url = https://raw.githubusercontent.com/nmattia/niv/v0.2.21/nix/sources.nix; 5 | sha256 = "129xhkih5sjdifcdfgfy36vj0a9qlli3cgxlrpqq8qfz42avn93v"; 6 | }; 7 | nixpkgs_src = (import sourcesnix { sourcesFile = ./sources.json; inherit pkgs; }).nixpkgs; 8 | 9 | # dump nixpkgs patches here 10 | nixpkgs-patches = []; 11 | 12 | nixpkgs-patched = if nixpkgs-patches == [] then nixpkgs_src else 13 | let 14 | bootstrap-pkgs = import nixpkgs_src { 15 | system = builtins.currentSystem; 16 | }; 17 | in bootstrap-pkgs.applyPatches { 18 | name = "nixpkgs-patched"; 19 | src = nixpkgs_src; 20 | patches = nixpkgs-patches; 21 | }; 22 | 23 | pkgs = 24 | import nixpkgs-patched { 25 | inherit system; 26 | overlays = [ 27 | (self: super: { 28 | sources = import sourcesnix { sourcesFile = ./sources.json; pkgs = super; }; 29 | 30 | subpath = import ./gitSource.nix; 31 | 32 | rustPackages = super.rustPackages // { 33 | # nixpkgs's rustc does not include the wasm32-unknown-unknown target, so 34 | # let's add it here. With this we can build the universal canister with stock 35 | # nixpkgs + naersk, in particular no dependency on internal repositories. 36 | # But rename this so that we do not rebuild unrelated tools written in rust. 37 | rustc = super.rustPackages.rustc.overrideAttrs (old: { 38 | configureFlags = self.lib.lists.forEach old.configureFlags (flag: 39 | if self.lib.strings.hasPrefix "--target=" flag 40 | then flag + ",wasm32-unknown-unknown" 41 | else flag) ++ [ 42 | # https://github.com/rust-lang/rust/issues/76526 43 | # fixed in Rust 1.69.0 44 | "--set=build.docs=false" 45 | ]; 46 | }); 47 | }; 48 | 49 | all-cabal-hashes = self.fetchurl { 50 | url = "https://github.com/commercialhaskell/all-cabal-hashes/archive/35f4996e28c5ba20a3a633346f21abe2072afeb6.tar.gz"; 51 | sha256 = "sha256-L/PmFUGlBOOd5rAx4NFxv+s2USI9q0YgOsfpdeRDyds="; 52 | }; 53 | 54 | # We override secp256k1 since the version in nixpkgs doesn't provide a 55 | # .a library needed for a static build of ic-hs. 56 | secp256k1 = super.callPackage ./secp256k1 {}; 57 | }) 58 | ]; 59 | }; 60 | in 61 | pkgs 62 | -------------------------------------------------------------------------------- /cbits/bls_BLS12381.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2012-2020 MIRACL UK Ltd. 3 | * 4 | * This file is part of MIRACL Core 5 | * (see https://github.com/miracl/core). 6 | * 7 | * Licensed under the Apache License, Version 2.0 (the "License"); 8 | * you may not use this file except in compliance with the License. 9 | * You may obtain a copy of the License at 10 | * 11 | * http://www.apache.org/licenses/LICENSE-2.0 12 | * 13 | * Unless required by applicable law or agreed to in writing, software 14 | * distributed under the License is distributed on an "AS IS" BASIS, 15 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 16 | * See the License for the specific language governing permissions and 17 | * limitations under the License. 18 | */ 19 | 20 | /** 21 | * @file bls.h 22 | * @author Mike Scott 23 | * @date 28th Novemebr 2018 24 | * @brief BLS Header file 25 | * 26 | * Allows some user configuration 27 | * defines structures 28 | * declares functions 29 | * 30 | */ 31 | 32 | #ifndef BLS_BLS12381_H 33 | #define BLS_BLS12381_H 34 | 35 | #include "pair_BLS12381.h" 36 | 37 | /* Field size is assumed to be greater than or equal to group size */ 38 | 39 | #define BGS_BLS12381 MODBYTES_384_58 /**< BLS Group Size */ 40 | #define BFS_BLS12381 MODBYTES_384_58 /**< BLS Field Size */ 41 | 42 | #define BLS_OK 0 /**< Function completed without error */ 43 | #define BLS_FAIL -1 /**< Point is NOT on the curve */ 44 | 45 | /* BLS API functions */ 46 | 47 | /** @brief Initialise BLS 48 | * 49 | @return BLS_OK if worked, otherwise BLS_FAIL 50 | */ 51 | int BLS_BLS12381_INIT(); 52 | 53 | /** @brief Generate Key Pair 54 | * 55 | @param IKM is an octet containing random Initial Keying Material 56 | @param S on output a private key 57 | @param W on output a public key = S*G, where G is fixed generator 58 | @return BLS_OK 59 | */ 60 | int BLS_BLS12381_KEY_PAIR_GENERATE(octet *IKM, octet* S, octet *W); 61 | 62 | /** @brief Calculate a signature 63 | * 64 | @param SIG the ouput signature 65 | @param M is the message to be signed 66 | @param S an input private key 67 | @return BLS_OK 68 | */ 69 | int BLS_BLS12381_CORE_SIGN(octet *SIG, octet *M, octet *S); 70 | 71 | /** @brief Verify a signature 72 | * 73 | @param SIG an input signature 74 | @param M is the message whose signature is to be verified. 75 | @param W an public key 76 | @return BLS_OK if verified, otherwise BLS_FAIL 77 | */ 78 | int BLS_BLS12381_CORE_VERIFY(octet *SIG, octet *M, octet *W); 79 | 80 | #endif 81 | 82 | -------------------------------------------------------------------------------- /cbits/config_curve_BLS12381.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2012-2020 MIRACL UK Ltd. 3 | * 4 | * This file is part of MIRACL Core 5 | * (see https://github.com/miracl/core). 6 | * 7 | * Licensed under the Apache License, Version 2.0 (the "License"); 8 | * you may not use this file except in compliance with the License. 9 | * You may obtain a copy of the License at 10 | * 11 | * http://www.apache.org/licenses/LICENSE-2.0 12 | * 13 | * Unless required by applicable law or agreed to in writing, software 14 | * distributed under the License is distributed on an "AS IS" BASIS, 15 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 16 | * See the License for the specific language governing permissions and 17 | * limitations under the License. 18 | */ 19 | 20 | /** 21 | * @file config_curve.h 22 | * @author Mike Scott 23 | * @brief Config Curve Header File 24 | * 25 | */ 26 | 27 | #ifndef CONFIG_CURVE_BLS12381_H 28 | #define CONFIG_CURVE_BLS12381_H 29 | 30 | #include"core.h" 31 | #include"config_field_BLS12381.h" 32 | 33 | // ECP stuff 34 | 35 | #define CURVETYPE_BLS12381 WEIERSTRASS /**< Define Curve Type */ 36 | #define CURVE_A_BLS12381 0 /**< Curve A parameter */ 37 | #define PAIRING_FRIENDLY_BLS12381 BLS12_CURVE /**< Is curve pairing-friendly */ 38 | #define CURVE_SECURITY_BLS12381 128 /**< Curve security level in AES bits */ 39 | #define HTC_ISO_BLS12381 11 /**< Use Isogenies for Hash to Curve */ 40 | 41 | #if PAIRING_FRIENDLY_BLS12381 != NOT_PF 42 | 43 | #define HTC_ISO_G2_BLS12381 3 /**< Use Isogenies for G2 Hash to Curve */ 44 | //#define USE_GLV_BLS12381 /**< Note this method is patented (GLV), so maybe you want to comment this out */ 45 | //#define USE_GS_G2_BLS12381 /**< Well we didn't patent it :) But may be covered by GLV patent :( */ 46 | #define USE_GS_GT_BLS12381 /**< Not patented, so probably OK to always use this */ 47 | 48 | #define POSITIVEX 0 49 | #define NEGATIVEX 1 50 | 51 | #define SEXTIC_TWIST_BLS12381 M_TYPE /**< Sextic Twist M or D type */ 52 | #define SIGN_OF_X_BLS12381 NEGATIVEX /**< Sign of curve parameter */ 53 | 54 | #define ATE_BITS_BLS12381 65 /**< Number of Bits in curve parameter */ 55 | #define G2_TABLE_BLS12381 69 /**< Size of table for pairing precomputation for fixed G2 */ 56 | 57 | #endif 58 | 59 | #if CURVE_SECURITY_BLS12381 == 128 60 | #define AESKEY_BLS12381 16 /**< Symmetric Key size - 128 bits */ 61 | #define HASH_TYPE_BLS12381 SHA256 /**< Hash type */ 62 | #endif 63 | 64 | #if CURVE_SECURITY_BLS12381 == 192 65 | #define AESKEY_BLS12381 24 /**< Symmetric Key size - 192 bits */ 66 | #define HASH_TYPE_BLS12381 SHA384 /**< Hash type */ 67 | #endif 68 | 69 | #if CURVE_SECURITY_BLS12381 == 256 70 | #define AESKEY_BLS12381 32 /**< Symmetric Key size - 256 bits */ 71 | #define HASH_TYPE_BLS12381 SHA512 /**< Hash type */ 72 | #endif 73 | 74 | 75 | 76 | #endif 77 | -------------------------------------------------------------------------------- /src/IC/Crypto/Bitcoin.hs: -------------------------------------------------------------------------------- 1 | module IC.Crypto.Bitcoin 2 | ( ExtendedSecretKey(..) 3 | , createExtendedKey 4 | , derivePrivateKey 5 | , derivePublicKey 6 | , extractChainCode 7 | , publicKeyToDER 8 | , sign 9 | , toHash256 10 | , toWord32 11 | ) where 12 | 13 | import qualified Data.ByteString.Lazy as BS 14 | import qualified Data.ByteString.Short as BSS 15 | import qualified Data.Binary as Get 16 | import qualified Data.Binary.Get as Get 17 | import qualified Data.Vector as Vec 18 | import qualified Haskoin.Keys.Common as Haskoin 19 | import qualified Haskoin.Keys.Extended as Haskoin 20 | import qualified Haskoin.Crypto.Signature as Haskoin 21 | import qualified Haskoin.Crypto.Hash as Haskoin 22 | import Data.Either.Combinators 23 | import Data.Word 24 | 25 | newtype ExtendedSecretKey = ExtendedSecretKey Haskoin.XPrvKey 26 | deriving Show 27 | 28 | createExtendedKey :: BS.ByteString -> ExtendedSecretKey 29 | createExtendedKey seed = ExtendedSecretKey $ Haskoin.makeXPrvKey $ BS.toStrict seed 30 | 31 | derivePrivateKey :: ExtendedSecretKey -> Vec.Vector BS.ByteString -> Either String Haskoin.XPrvKey 32 | derivePrivateKey (ExtendedSecretKey sk) path = mapRight (\p -> Haskoin.derivePath p sk) $ parseSoftDerivationPath $ Vec.toList path 33 | 34 | derivePublicKey :: ExtendedSecretKey -> Vec.Vector BS.ByteString -> Either String Haskoin.XPubKey 35 | derivePublicKey (ExtendedSecretKey sk) path = mapRight (\p -> Haskoin.derivePubPath p (Haskoin.deriveXPubKey sk)) $ parseSoftDerivationPath $ Vec.toList path 36 | 37 | sign :: Haskoin.XPrvKey -> Haskoin.Hash256 -> BS.ByteString 38 | sign key msg = BS.fromStrict $ Haskoin.exportSig $ Haskoin.signHash (Haskoin.xPrvKey key) msg 39 | 40 | parseSoftDerivationPath :: [BS.ByteString] -> Either String Haskoin.SoftPath 41 | parseSoftDerivationPath l = 42 | case raw_path of 43 | Left err -> Left $ "Could not parse derivation path: " ++ err 44 | Right rp -> case Haskoin.toSoft $ Haskoin.listToPath rp of 45 | Nothing -> Left $ "Could not soften derivation path" 46 | Just p -> Right p 47 | where 48 | raw_path = sequence $ map toWord32 l 49 | 50 | publicKeyToDER :: Haskoin.XPubKey -> BS.ByteString 51 | publicKeyToDER k = BS.fromStrict $ Haskoin.exportPubKey False $ Haskoin.xPubKey k 52 | 53 | extractChainCode :: Haskoin.XPubKey -> BS.ByteString 54 | extractChainCode k = BS.fromStrict $ BSS.fromShort $ Haskoin.getHash256 $ Haskoin.xPubChain k 55 | 56 | toWord32 :: BS.ByteString -> Either String Word32 57 | toWord32 = convert Get.getWord32be 58 | 59 | toHash256 :: BS.ByteString -> Either String Haskoin.Hash256 60 | toHash256 = convert Get.get 61 | 62 | convert :: Get.Get a -> BS.ByteString -> Either String a 63 | convert get bs = case (Get.runGetOrFail get bs) of 64 | Left (_, _, err) -> Left err 65 | Right (un, n, v) -> if un == BS.empty 66 | then Right v 67 | else Left $ "Input ByteString too long: " ++ show un ++ " " ++ show n 68 | -------------------------------------------------------------------------------- /src/IC/Crypto/Secp256k1.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE BlockArguments #-} 4 | module IC.Crypto.Secp256k1 5 | ( init 6 | , SecretKey 7 | , createKey 8 | , toPublicKey 9 | , sign 10 | , verify 11 | ) where 12 | 13 | import qualified Data.Text as T 14 | import qualified Data.ByteString.Lazy as BS 15 | import Data.Serialize.Get 16 | import Data.Bifunctor 17 | import Control.Monad 18 | import Data.Hashable 19 | import Control.Monad.Except 20 | import qualified Crypto.PubKey.ECC.ECDSA as EC 21 | import qualified Crypto.PubKey.ECC.Generate as EC 22 | import qualified Crypto.PubKey.ECC.Types as EC 23 | import qualified Crypto.PubKey.ECC.Prim as EC 24 | import Crypto.Number.Serialize 25 | import Crypto.Hash.Algorithms (SHA256(..)) 26 | 27 | data SecretKey = SecretKey EC.PrivateKey EC.PublicKey 28 | deriving Show 29 | 30 | toPublicKey :: SecretKey -> BS.ByteString 31 | toPublicKey (SecretKey _ (EC.PublicKey _ (EC.Point x y))) = 32 | BS.singleton 0x04 <> BS.fromStrict (i2ospOf_ 32 x <> i2ospOf_ 32 y) 33 | toPublicKey (SecretKey _ (EC.PublicKey _ EC.PointO)) = error "toPublicKey: Point at infinity" 34 | 35 | curve :: EC.Curve 36 | curve = EC.getCurveByName EC.SEC_p256k1 37 | 38 | createKey :: BS.ByteString -> SecretKey 39 | createKey seed = 40 | SecretKey (EC.PrivateKey curve d) (EC.PublicKey curve q) 41 | where 42 | n = EC.ecc_n $ EC.common_curve curve 43 | d = fromIntegral (hash seed) `mod` (n-2) + 1 44 | q = EC.generateQ curve d 45 | 46 | sign :: SecretKey -> BS.ByteString -> IO BS.ByteString 47 | sign (SecretKey sk _) msg = do 48 | EC.Signature r s <- EC.sign sk SHA256 (BS.toStrict msg) 49 | return $ BS.fromStrict $ i2ospOf_ 32 r <> i2ospOf_ 32 s 50 | 51 | -- Parsing SEC keys. Unfortunately not supported directly in cryptonite 52 | -- https://github.com/haskell-crypto/cryptonite/issues/302 53 | parsePublicKey :: BS.ByteString -> Either T.Text EC.PublicKey 54 | parsePublicKey = first T.pack . runGetLazy do 55 | t <- getWord8 56 | when (t == 0x03) $ do 57 | fail "compressed secp256k1 public keys not supported" 58 | when (t /= 0x04) $ 59 | fail "unexpected public key byte t" 60 | x <- os2ip <$> getByteString 32 61 | y <- os2ip <$> getByteString 32 62 | let p = EC.Point x y 63 | unless (EC.isPointValid curve p) $ do 64 | fail "point not vaild" 65 | return $ EC.PublicKey curve p 66 | 67 | parseSig :: BS.ByteString -> Either T.Text EC.Signature 68 | parseSig = first T.pack . runGetLazy do 69 | r <- os2ip <$> getByteString 32 70 | s <- os2ip <$> getByteString 32 71 | return $ EC.Signature r s 72 | 73 | verify :: BS.ByteString -> BS.ByteString -> BS.ByteString -> Either T.Text () 74 | verify pk msg sig = do 75 | pk <- parsePublicKey pk 76 | sig <- parseSig sig 77 | unless (EC.verify SHA256 pk sig (BS.toStrict msg)) $ 78 | throwError "secp256k1 signature did not validate" 79 | -------------------------------------------------------------------------------- /src/IC/HTTP/GenR/Parse.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE ConstraintKinds #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | 7 | {- | 8 | Utilities to deconstruct a generic record. 9 | -} 10 | module IC.HTTP.GenR.Parse where 11 | 12 | import Numeric.Natural 13 | import qualified Data.Text as T 14 | import qualified Data.ByteString.Lazy as BS 15 | import Control.Monad.State 16 | import Control.Monad.Writer 17 | import Control.Monad.Except 18 | import qualified Data.HashMap.Lazy as HM 19 | import GHC.Stack 20 | 21 | import IC.HTTP.GenR 22 | 23 | -- A monad to parse a record 24 | -- (reading each field once, checking for left-over fields in the end) 25 | type RecordM m = StateT (HM.HashMap T.Text GenR) m 26 | type Field a = forall m. HasCallStack => Parse m => GenR -> m a 27 | class Monad m => Parse m where parseError :: HasCallStack => T.Text -> m a 28 | 29 | instance Parse (Either T.Text) where parseError = Left 30 | instance (Monoid a, Parse m) => Parse (WriterT a m) where parseError = lift . parseError 31 | instance Monad m => Parse (ExceptT T.Text m ) where parseError = throwError 32 | 33 | record :: HasCallStack => Parse m => RecordM m a -> GenR -> m a 34 | record m (GRec hm) = (`evalStateT` hm) $ do 35 | x <- m 36 | -- Check for left-over fields 37 | hm <- get 38 | unless (HM.null hm) $ lift $ 39 | parseError $ "Unexpected fields: " <> T.intercalate ", " (HM.keys hm) 40 | return x 41 | record _ _ = parseError "Expected CBOR record" 42 | 43 | field :: HasCallStack => Parse m => Field a -> T.Text -> RecordM m a 44 | field parse name = do 45 | hm <- get 46 | put (HM.delete name hm) 47 | lift $ case HM.lookup name hm of 48 | Nothing -> parseError $ "Missing expected field \"" <> name <> "\"" 49 | Just gr -> parse gr 50 | 51 | optionalField :: HasCallStack => Parse m => Field a -> T.Text -> RecordM m (Maybe a) 52 | optionalField parse name = do 53 | hm <- get 54 | put (HM.delete name hm) 55 | case HM.lookup name hm of 56 | Nothing -> return Nothing 57 | Just gr -> lift $ Just <$> parse gr 58 | 59 | swallowAllFields :: Monad m => RecordM m () 60 | swallowAllFields = put HM.empty 61 | 62 | anyType :: Field GenR 63 | anyType = return 64 | 65 | text :: Field T.Text 66 | text (GText t) = return t 67 | text _ = parseError "Expected text value" 68 | 69 | blob :: Field BS.ByteString 70 | blob (GBlob b) = return b 71 | blob _ = parseError "Expected blob" 72 | 73 | nat :: Field Natural 74 | nat (GNat n) = return n 75 | nat _ = parseError "Expected natural number" 76 | 77 | percentage :: Field Natural 78 | percentage gr = do 79 | n <- nat gr 80 | unless (0 <= n && n <= 100) $ 81 | parseError "Expected a percentage (0..100)" 82 | return n 83 | 84 | listOf :: Field a -> Field [a] 85 | listOf f (GList xs) = mapM f xs 86 | listOf _ _ = parseError "Expected a list" 87 | -------------------------------------------------------------------------------- /tests/unit-tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | module Main (main) where 4 | 5 | import Test.Tasty 6 | import Test.Tasty.HUnit 7 | 8 | import System.IO 9 | import System.IO.Temp 10 | import System.Directory 11 | import qualified Data.Map as M 12 | import qualified Data.Set as S 13 | 14 | import qualified IC.Crypto.BLS as BLS 15 | import IC.Id.Fresh(wordToId) 16 | import IC.Ref 17 | import IC.Types 18 | import IC.Serialise () 19 | import IC.StateFile 20 | import IC.Test.HashTree 21 | import IC.Test.BLS 22 | import IC.Test.WebAuthn 23 | import IC.Test.ECDSA 24 | import IC.Test.Secp256k1 25 | import IC.Test.StableMemory 26 | import IC.HTTP.GenR 27 | import IC.HTTP.RequestId 28 | import IC.Utils 29 | 30 | main :: IO () 31 | main = do 32 | BLS.init 33 | conf <- makeRefConfig [] 34 | defaultMain $ tests conf 35 | 36 | defaultSubnetConfig :: [SubnetConfig] 37 | defaultSubnetConfig = [SubnetConfig Application 1 "sk" [(0, 0)]] 38 | 39 | defaultEcid :: CanisterId 40 | defaultEcid = wordToId 0 41 | 42 | tests :: RefConfig -> TestTree 43 | tests conf = testGroup "ic-ref unit tests" 44 | [ testCase "Request id calculation from interface spec" $ 45 | let gr = GRec $ mconcat 46 | [ "request_type" =: GText "call" 47 | , "canister_id" =: GBlob "\x00\x00\x00\x00\x00\x00\x04\xD2" 48 | , "method_name" =: GText "hello" 49 | , "arg" =: GBlob "DIDL\x00\xFD*" 50 | ] 51 | in requestId gr @?= "\x87\x81\x29\x1c\x34\x7d\xb3\x2a\x9d\x8c\x10\xeb\x62\xb7\x10\xfc\xe5\xa9\x3b\xe6\x76\x47\x4c\x42\xba\xbc\x74\xc5\x18\x58\xf9\x4b" 52 | , hashTreeTests 53 | , blsTests 54 | , webAuthnTests 55 | , ecdsaTests 56 | , secp256k1Tests 57 | , stableMemoryTests 58 | , testGroup "State serialization" 59 | [ testCase "with file" $ 60 | withSystemTempFile "ic-ref-unit-test.state" $ \fn h -> do 61 | -- start with an empty file 62 | hClose h 63 | removeFile fn 64 | 65 | -- Create the state 66 | withStore (initialIC defaultSubnetConfig) (Just fn) $ \store -> do 67 | modifyStore store $ withRefConfig conf $ submitRequest "dummyrequestid" 68 | (CallRequest (EntityId mempty) (EntityId "yay") "provisional_create_canister_with_cycles" "DIDL\x01\x6c\0\1\0") defaultEcid 69 | 70 | -- now the file should exist 71 | doesFileExist fn >>= assertBool "File exists" 72 | 73 | withStore (initialIC defaultSubnetConfig) (Just fn) $ \store -> do 74 | ic <- peekStore store 75 | assertBool "No canisters yet expected" (null (canisters ic)) 76 | modifyStore store $ withRefConfig conf runToCompletion 77 | 78 | withStore (initialIC defaultSubnetConfig) (Just fn) $ \store -> do 79 | ic <- peekStore store 80 | case M.elems (canisters ic) of 81 | [] -> assertFailure "No canisters created" 82 | [CanState {controllers}] -> controllers @?= S.singleton (EntityId "yay") 83 | _ -> assertFailure "Too many canisters?" 84 | ] 85 | ] 86 | -------------------------------------------------------------------------------- /src/IC/Test/StableMemory.hs: -------------------------------------------------------------------------------- 1 | -- Unit tests for IC.Canister.StableMemory 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module IC.Test.StableMemory (stableMemoryTests) where 4 | 5 | import Test.Tasty 6 | import Test.Tasty.HUnit 7 | import Control.Monad.Except 8 | import Control.Monad.ST 9 | 10 | import qualified IC.Canister.StableMemory as Stable 11 | 12 | runHostM :: ExceptT String (ST RealWorld) a -> IO (Either String a) 13 | runHostM = stToIO . runExceptT 14 | 15 | mkMem :: Int -> ExceptT String (ST s) (Stable.Memory s) 16 | mkMem numPages = do 17 | mem <- Stable.new 18 | r <- Stable.grow mem (fromIntegral numPages) 19 | when (r < 0) $ 20 | throwError "grow failed" 21 | return mem 22 | 23 | stableMemoryTests :: TestTree 24 | stableMemoryTests = testGroup "Stable memory tests" 25 | [ testCase "grow" $ do 26 | res <- runHostM $ do mem <- Stable.new 27 | old <- Stable.grow mem 5 28 | new <- Stable.size mem 29 | return (old, new) 30 | res @?= Right (0, 5) 31 | , testCase "read across multiple writes" $ do 32 | res <- runHostM $ do mem <- mkMem 1 33 | Stable.write mem 0 "abc" 34 | Stable.write mem 6 "efg" 35 | Stable.read mem 0 9 36 | res @?= Right "abc\NUL\NUL\NULefg" 37 | , testCase "read part of a single write" $ do 38 | res <- runHostM $ do mem <- mkMem 1 39 | Stable.write mem 0 "abcdefghijk" 40 | Stable.read mem 3 3 41 | res @?= Right "def" 42 | , testCase "read overlapping writes" $ do 43 | res <- runHostM $ do mem <- mkMem 1 44 | Stable.write mem 0 "abcdef" 45 | Stable.write mem 3 "xyz123" 46 | Stable.read mem 3 3 47 | res @?= Right "xyz" 48 | , testCase "read several overlapping writes" $ do 49 | res <- runHostM $ do mem <- mkMem 1 50 | Stable.write mem 0 "abcdefghij" 51 | Stable.write mem 1 "zw" 52 | Stable.write mem 6 "xyz" 53 | Stable.read mem 0 11 54 | res @?= Right "azwdefxyzj\NUL" 55 | , testCase "export/import" $ do 56 | res <- runHostM $ do mem <- mkMem 2 57 | Stable.write mem 0 "ABCD" 58 | blob <- lift $ Stable.serialize <$> Stable.export mem 59 | mem2 <- Stable.new 60 | lift $ Stable.imp mem2 $ Stable.deserialize blob 61 | size2 <- Stable.size mem2 62 | data2 <- Stable.read mem2 0 6 63 | return (size2, data2) 64 | res @?= Right (2, "ABCD\NUL\NUL") 65 | , testCase "read out of bounds" $ do 66 | res <- runHostM $ do mem <- mkMem 1 67 | Stable.read mem 0 70000 68 | case res of 69 | Left _ -> return () 70 | Right _ -> assertFailure "reading out of bounds is an error" 71 | ] 72 | -------------------------------------------------------------------------------- /src/IC/Crypto/DER.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module IC.Crypto.DER (Suite(..), encode, decode) where 3 | 4 | import qualified Data.Text as T 5 | import qualified Data.ByteString.Lazy as BS 6 | import Data.ASN1.Types 7 | import Data.ASN1.Encoding 8 | import Data.ASN1.BinaryEncoding 9 | import Data.ASN1.BitArray 10 | 11 | import IC.Crypto.DER.Decode 12 | 13 | data Suite = Ed25519 | WebAuthn | ECDSA | Secp256k1 | BLS | CanisterSig deriving Show 14 | 15 | webAuthnOID :: OID 16 | webAuthnOID = [1,3,6,1,4,1,56387,1,1] 17 | 18 | canisterSigOID :: OID 19 | canisterSigOID = [1,3,6,1,4,1,56387,1,2] 20 | 21 | ed25519OID :: OID 22 | ed25519OID = [1,3,101,112] 23 | 24 | ecPublicKeyOID :: OID 25 | ecPublicKeyOID =[1,2,840,10045,2,1] 26 | 27 | secp256r1OID :: OID 28 | secp256r1OID = [1,2,840,10045,3,1,7] 29 | secp256k1OID :: OID 30 | secp256k1OID = [1,3,132,0,10] 31 | 32 | blsAlgoOID :: OID 33 | blsAlgoOID = [1,3,6,1,4,1,44668,5,3,1,2,1] 34 | blsCurveOID :: OID 35 | blsCurveOID = [1,3,6,1,4,1,44668,5,3,2,1] 36 | 37 | encode :: Suite -> BS.ByteString -> BS.ByteString 38 | encode Ed25519 = encodeDER [ed25519OID] 39 | encode WebAuthn = encodeDER [webAuthnOID] 40 | encode ECDSA = encodeDER [ecPublicKeyOID, secp256r1OID] 41 | encode Secp256k1 = encodeDER [ecPublicKeyOID, secp256k1OID] 42 | encode BLS = encodeDER [blsAlgoOID, blsCurveOID] 43 | encode CanisterSig = encodeDER [canisterSigOID] 44 | 45 | encodeDER :: [OID] -> BS.ByteString -> BS.ByteString 46 | encodeDER oids pk = encodeASN1 DER $ 47 | [ Start Sequence 48 | , Start Sequence 49 | ] ++ 50 | [ OID oid | oid <- oids ] ++ 51 | [ End Sequence 52 | , BitString (toBitArray (BS.toStrict pk) 0) 53 | , End Sequence 54 | ] 55 | 56 | decode :: BS.ByteString -> Either T.Text (Suite, BS.ByteString) 57 | decode bs = case safeDecode bs of 58 | Left err -> Left $ "Could not decode DER: " <> T.pack err 59 | Right asn -> case asn of 60 | [ Start Sequence 61 | , Start Sequence 62 | , OID algo 63 | , End Sequence 64 | , BitString ba 65 | , End Sequence 66 | ] 67 | | algo == webAuthnOID 68 | -> Right (WebAuthn, BS.fromStrict (bitArrayGetData ba)) 69 | | algo == ed25519OID 70 | -> Right (Ed25519, BS.fromStrict (bitArrayGetData ba)) 71 | | algo == canisterSigOID 72 | -> Right (CanisterSig, BS.fromStrict (bitArrayGetData ba)) 73 | | otherwise 74 | -> Left $ "Unexpected cipher: algo = " <> T.pack (show algo) 75 | [ Start Sequence 76 | , Start Sequence 77 | , OID algo 78 | , OID curve 79 | , End Sequence 80 | , BitString ba 81 | , End Sequence 82 | ] 83 | | algo == ecPublicKeyOID && curve == secp256r1OID 84 | -> Right (ECDSA, BS.fromStrict (bitArrayGetData ba)) 85 | | algo == ecPublicKeyOID && curve == secp256k1OID 86 | -> Right (Secp256k1, BS.fromStrict (bitArrayGetData ba)) 87 | | algo == blsAlgoOID && curve == blsCurveOID 88 | -> Right (BLS, BS.fromStrict (bitArrayGetData ba)) 89 | | otherwise 90 | -> Left $ "Unexpected cipher: algo = " <> T.pack (show algo) <> " curve = " <> T.pack (show curve) 91 | _ -> Left $ "Unexpected DER shape: " <> T.pack (show asn) 92 | -------------------------------------------------------------------------------- /cbits/x509.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2012-2020 MIRACL UK Ltd. 3 | * 4 | * This file is part of MIRACL Core 5 | * (see https://github.com/miracl/core). 6 | * 7 | * Licensed under the Apache License, Version 2.0 (the "License"); 8 | * you may not use this file except in compliance with the License. 9 | * You may obtain a copy of the License at 10 | * 11 | * http://www.apache.org/licenses/LICENSE-2.0 12 | * 13 | * Unless required by applicable law or agreed to in writing, software 14 | * distributed under the License is distributed on an "AS IS" BASIS, 15 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 16 | * See the License for the specific language governing permissions and 17 | * limitations under the License. 18 | */ 19 | 20 | /* CORE x509 header file */ 21 | 22 | /** 23 | * @file x509.h 24 | * @author Mike Scott 25 | * @brief X509 function Header File 26 | * 27 | */ 28 | 29 | #ifndef X509_H 30 | #define X509_H 31 | 32 | /** 33 | * @brief Public key type 34 | */ 35 | typedef struct 36 | { 37 | int type; /**< signature type (ECC or RSA) */ 38 | int hash; /**< hash type */ 39 | int curve; /**< elliptic curve used or RSA key length in bits */ 40 | } pktype; 41 | 42 | 43 | /* X.509 functions */ 44 | /** @brief Extract certificate signature 45 | * 46 | @param c an X.509 certificate 47 | @param s the extracted signature 48 | @return 0 on failure, or indicator of signature type (ECC or RSA) 49 | 50 | */ 51 | extern pktype X509_extract_cert_sig(octet *c, octet *s); 52 | /** @brief 53 | * 54 | @param sc a signed certificate 55 | @param c the extracted certificate 56 | @return 0 on failure 57 | */ 58 | extern int X509_extract_cert(octet *sc, octet *c); 59 | /** @brief 60 | * 61 | @param c an X.509 certificate 62 | @param k the extracted key 63 | @return 0 on failure, or indicator of public key type (ECC or RSA) 64 | */ 65 | extern pktype X509_extract_public_key(octet *c, octet *k); 66 | /** @brief 67 | * 68 | @param c an X.509 certificate 69 | @return 0 on failure, or pointer to issuer field in cert 70 | */ 71 | extern int X509_find_issuer(octet *c); 72 | /** @brief 73 | * 74 | @param c an X.509 certificate 75 | @return 0 on failure, or pointer to validity field in cert 76 | */ 77 | extern int X509_find_validity(octet *c); 78 | /** @brief 79 | * 80 | @param c an X.509 certificate 81 | @return 0 on failure, or pointer to subject field in cert 82 | */ 83 | extern int X509_find_subject(octet *c); 84 | /** @brief 85 | * 86 | @param c an X.509 certificate 87 | @param S is OID of property we are looking for 88 | @param s is a pointer to the section of interest in the cert 89 | @param f is pointer to the length of the property 90 | @return 0 on failure, or pointer to the property 91 | */ 92 | extern int X509_find_entity_property(octet *c, octet *S, int s, int *f); 93 | /** @brief 94 | * 95 | @param c an X.509 certificate 96 | @param s is a pointer to the start of the validity field 97 | @return 0 on failure, or pointer to the start date 98 | */ 99 | extern int X509_find_start_date(octet *c, int s); 100 | /** @brief 101 | * 102 | @param c an X.509 certificate 103 | @param s is a pointer to the start of the validity field 104 | @return 0 on failure, or pointer to the expiry date 105 | */ 106 | extern int X509_find_expiry_date(octet *c, int s); 107 | 108 | 109 | #endif 110 | -------------------------------------------------------------------------------- /universal-canister/src/lib.rs: -------------------------------------------------------------------------------- 1 | // Opcodes 2 | 3 | /// Operands used in encoding UC payloads. 4 | macro_rules! try_from_u8 { 5 | ($(#[$meta:meta])* $vis:vis enum $name:ident { 6 | $($(#[$vmeta:meta])* $vname:ident $(= $val:expr)?,)* 7 | }) => { 8 | $(#[$meta])* 9 | #[repr(u8)] 10 | $vis enum $name { 11 | $($(#[$vmeta])* $vname $(= $val)?,)* 12 | } 13 | 14 | impl std::convert::TryFrom for $name { 15 | type Error = (); 16 | 17 | fn try_from(v: u8) -> Result { 18 | match v { 19 | $(x if x == $name::$vname as u8 => Ok($name::$vname),)* 20 | _ => Err(()), 21 | } 22 | } 23 | } 24 | } 25 | } 26 | 27 | try_from_u8!( 28 | #[derive(Debug, Eq, PartialEq)] 29 | pub enum Ops { 30 | Noop = 0, 31 | Drop = 1, 32 | PushInt = 2, 33 | PushBytes = 3, 34 | ReplyDataAppend = 4, 35 | Reply = 5, 36 | Self_ = 6, 37 | Reject = 7, 38 | Caller = 8, 39 | InstructionCounterIsAtLeast = 9, 40 | RejectMessage = 10, 41 | RejectCode = 11, 42 | IntToBlob = 12, 43 | MessagePayload = 13, 44 | Concat = 14, 45 | StableSize = 15, 46 | StableGrow = 16, 47 | StableRead = 17, 48 | StableWrite = 18, 49 | DebugPrint = 19, 50 | Trap = 20, 51 | SetGlobal = 21, 52 | GetGlobal = 22, 53 | BadPrint = 23, 54 | SetPreUpgrade = 24, 55 | // = 25, 56 | Time = 26, 57 | CyclesAvailable = 27, 58 | CyclesBalance = 28, 59 | CyclesRefunded = 29, 60 | AcceptCycles = 30, 61 | PushInt64 = 31, 62 | CallNew = 32, 63 | CallDataAppend = 33, 64 | CallCyclesAdd = 34, 65 | CallPerform = 35, 66 | CertifiedDataSet = 36, 67 | DataCertificatePresent = 37, 68 | DataCertificate = 38, 69 | CanisterStatus = 39, 70 | SetHeartbeat = 40, 71 | AcceptMessage = 41, 72 | SetInspectMessage = 42, 73 | TrapIfEq = 43, 74 | CallOnCleanup = 44, 75 | StableFill = 45, 76 | StableSize64 = 46, 77 | StableGrow64 = 47, 78 | StableRead64 = 48, 79 | StableWrite64 = 49, 80 | Int64ToBlob = 50, 81 | CyclesAvailable128 = 51, 82 | CyclesBalance128 = 52, 83 | CyclesRefunded128 = 53, 84 | AcceptCycles128 = 54, 85 | CallCyclesAdd128 = 55, 86 | MsgArgDataSize = 56, 87 | MsgArgDataCopy = 57, 88 | MsgCallerSize = 58, 89 | MsgCallerCopy = 59, 90 | MsgRejectMsgSize = 60, 91 | MsgRejectMsgCopy = 61, 92 | SetGlobalTimerMethod = 62, 93 | ApiGlobalTimerSet = 63, 94 | IncGlobalCounter = 64, 95 | GetGlobalCounter = 65, 96 | GetPerformanceCounter = 66, 97 | MsgMethodName = 67, 98 | ParsePrincipal = 68, 99 | SetTransform = 69, 100 | GetHttpReplyWithBody = 70, 101 | GetHttpTransformContext = 71, 102 | StableFill64 = 72, 103 | CanisterVersion = 73, 104 | TrapIfNeq = 74, 105 | MintCycles = 75, 106 | OneWayCallNew = 76, 107 | IsController = 77, 108 | } 109 | ); 110 | -------------------------------------------------------------------------------- /src/IC/Crypto/CanisterSig.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE BlockArguments #-} 4 | module IC.Crypto.CanisterSig 5 | ( genPublicKey 6 | , genSig 7 | , verify 8 | ) where 9 | 10 | import qualified Data.Text as T 11 | import qualified Data.ByteString.Lazy as BS 12 | import qualified Data.ByteString.Builder as BS 13 | import Data.Serialize.Get 14 | import Data.Bifunctor 15 | import Control.Monad 16 | import Codec.CBOR.Term 17 | import Codec.CBOR.Write 18 | 19 | import IC.CBOR.Patterns 20 | import IC.CBOR.Parser 21 | import IC.Types 22 | import IC.Certificate 23 | import IC.Certificate.CBOR 24 | import IC.Certificate.Validate 25 | import IC.Hash 26 | import IC.HashTree 27 | import IC.HashTree.CBOR 28 | 29 | -- | Produces a public key, without the DER wrapping 30 | genPublicKey :: EntityId -> BS.ByteString -> BS.ByteString 31 | genPublicKey (EntityId cid) seed = BS.toLazyByteString $ 32 | BS.word8 (fromIntegral (BS.length cid)) <> 33 | BS.lazyByteString cid <> 34 | BS.lazyByteString seed 35 | 36 | -- | Parses the public key into a canister id and a seed 37 | parsePublicKey :: BS.ByteString -> Either T.Text (EntityId, BS.ByteString) 38 | parsePublicKey = first T.pack . runGetLazy do 39 | t <- getWord8 40 | id <- BS.fromStrict <$> getByteString (fromIntegral t) 41 | seed <- BS.fromStrict <$> (remaining >>= getByteString) 42 | return (EntityId id, seed) 43 | 44 | genSig :: Certificate -> HashTree -> BS.ByteString 45 | genSig cert tree = toLazyByteString $ encodeTerm $ TTagged 55799 $ TMap 46 | [ (TString "certificate", TBlob (encodeCert cert)) 47 | , (TString "tree", encodeHashTree tree) 48 | ] 49 | 50 | parseSig :: BS.ByteString -> Either T.Text (Certificate, HashTree) 51 | parseSig s = do 52 | kv <- decodeWithTag s >>= parseMap "canister signature" 53 | certificate <- parseField "certificate" kv >>= 54 | parseBlob "certificate" >>= decodeCert 55 | tree <- parseField "tree" kv >>= parseHashTree 56 | return (certificate, tree) 57 | 58 | verify :: BS.ByteString -> BS.ByteString -> BS.ByteString -> BS.ByteString -> Either T.Text () 59 | verify root_key pk msg sig = do 60 | (id, seed) <- parsePublicKey pk 61 | (certificate, tree) <- parseSig sig 62 | 63 | validateCertificate root_key certificate 64 | 65 | expected_tree_hash <- case lookupPath (cert_tree certificate) 66 | ["canister", rawEntityId id, "certified_data"] of 67 | Found h -> return h 68 | r -> Left $ "Did not find certified_data data for canister id " <> 69 | T.pack (prettyID id) <> " in certificate (got " <> T.pack (show r) <> ")\n" <> 70 | T.pack (show (cert_tree certificate)) 71 | 72 | let actual_tree_hash = reconstruct tree 73 | 74 | unless (expected_tree_hash == actual_tree_hash) $ do 75 | Left $ "Tree hashes did not match.\n" <> 76 | "Certified tree hash: " <> T.pack (prettyBlob expected_tree_hash) <> "\n" <> 77 | "Actual tree hash: " <> T.pack (prettyBlob actual_tree_hash) 78 | 79 | case lookupPath tree ["sig", sha256 seed, sha256 msg] of 80 | Found "" -> return () 81 | Found b -> Left $ "Signature found, but value not \"\", but " <> T.pack (prettyBlob b) 82 | _ -> Left $ "Did not find signature in tree\n" <> 83 | "Seed: " <> T.pack (prettyBlob seed) <> "\n" <> 84 | "Msg: " <> T.pack (prettyBlob msg) <> "\n" <> 85 | "Tree: " <> T.pack (show tree) 86 | 87 | -------------------------------------------------------------------------------- /cbits/rom_field_BLS12381.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2012-2020 MIRACL UK Ltd. 3 | * 4 | * This file is part of MIRACL Core 5 | * (see https://github.com/miracl/core). 6 | * 7 | * Licensed under the Apache License, Version 2.0 (the "License"); 8 | * you may not use this file except in compliance with the License. 9 | * You may obtain a copy of the License at 10 | * 11 | * http://www.apache.org/licenses/LICENSE-2.0 12 | * 13 | * Unless required by applicable law or agreed to in writing, software 14 | * distributed under the License is distributed on an "AS IS" BASIS, 15 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 16 | * See the License for the specific language governing permissions and 17 | * limitations under the License. 18 | */ 19 | #include "arch.h" 20 | #include "fp_BLS12381.h" 21 | 22 | /* Curve BLS12381 - Pairing friendly BLS curve */ 23 | 24 | #if CHUNK==16 25 | 26 | #error Not supported 27 | 28 | #endif 29 | 30 | #if CHUNK==32 31 | // Base Bits= 29 32 | const BIG_384_29 Modulus_BLS12381= {0x1FFFAAAB,0xFF7FFFF,0x14FFFFEE,0x17FFFD62,0xF6241EA,0x9507B58,0xAFD9CC3,0x109E70A2,0x1764774B,0x121A5D66,0x12C6E9ED,0x12FFCD34,0x111EA3,0xD}; 33 | const BIG_384_29 ROI_BLS12381= {0x1FFFAAAA,0xFF7FFFF,0x14FFFFEE,0x17FFFD62,0xF6241EA,0x9507B58,0xAFD9CC3,0x109E70A2,0x1764774B,0x121A5D66,0x12C6E9ED,0x12FFCD34,0x111EA3,0xD}; 34 | const BIG_384_29 R2modp_BLS12381= {0x15BEF7AE,0x1031CD0E,0x2DD93E8,0x9226323,0xE6E2CD2,0x11684DAA,0x1170E5DB,0x88E25B1,0x1B366399,0x1C536F47,0xD1F9CBC,0x278B67F,0x1EA66A2B,0xC}; 35 | const chunk MConst_BLS12381= 0x1FFCFFFD; 36 | const BIG_384_29 CRu_BLS12381= {0x1FFEFFFE,0x100FFFFF,0x280008B,0xFB026C4,0x9688DE1,0x149DF37C,0x1FAB76CE,0xED41EE,0x11BA69C6,0x1EFBB672,0x17C659CB,0x0,0x0,0x0}; 37 | const BIG_384_29 Fra_BLS12381= {0x12235FB8,0x83BAF6C,0x19E04F63,0x1D4A7AC7,0xB9C4F67,0x1EBC25D,0x1D3DEC91,0x1FA797AB,0x1F0FD603,0x1016068,0x108C6FAD,0x5760CCF,0x104D3BF0,0xC}; 38 | const BIG_384_29 Frb_BLS12381= {0xDDC4AF3,0x7BC5093,0x1B1FB08B,0x1AB5829A,0x3C5F282,0x764B8FB,0xDBFB032,0x10F6D8F6,0x1854A147,0x1118FCFD,0x23A7A40,0xD89C065,0xFC3E2B3,0x0}; 39 | const BIG_384_29 SQRTm3_BLS12381= {0x1AAAE,0xFD80000,0xFFFFED7,0x189FAFDA,0x1C912627,0x14945F,0xBA6AF26,0xEC3ECC4,0x13EFA3BF,0x1422F081,0x33A3655,0x12FFCD33,0x111EA3,0xD}; 40 | #endif 41 | 42 | #if CHUNK==64 43 | // Base Bits= 58 44 | const BIG_384_58 Modulus_BLS12381= {0x1FEFFFFFFFFAAABL,0x2FFFFAC54FFFFEEL,0x12A0F6B0F6241EAL,0x213CE144AFD9CC3L,0x2434BACD764774BL,0x25FF9A692C6E9EDL,0x1A0111EA3L}; 45 | const BIG_384_58 ROI_BLS12381= {0x1FEFFFFFFFFAAAAL,0x2FFFFAC54FFFFEEL,0x12A0F6B0F6241EAL,0x213CE144AFD9CC3L,0x2434BACD764774BL,0x25FF9A692C6E9EDL,0x1A0111EA3L}; 46 | const BIG_384_58 R2modp_BLS12381= {0x20639A1D5BEF7AEL,0x1244C6462DD93E8L,0x22D09B54E6E2CD2L,0x111C4B63170E5DBL,0x38A6DE8FB366399L,0x4F16CFED1F9CBCL,0x19EA66A2BL}; 47 | const chunk MConst_BLS12381= 0x1F3FFFCFFFCFFFDL; 48 | const BIG_384_58 CRu_BLS12381= {0x201FFFFFFFEFFFEL,0x1F604D88280008BL,0x293BE6F89688DE1L,0x1DA83DDFAB76CEL,0x3DF76CE51BA69C6L,0x17C659CBL,0x0L}; 49 | const BIG_384_58 Fra_BLS12381= {0x10775ED92235FB8L,0x3A94F58F9E04F63L,0x3D784BAB9C4F67L,0x3F4F2F57D3DEC91L,0x202C0D1F0FD603L,0xAEC199F08C6FADL,0x1904D3BF0L}; 50 | const BIG_384_58 Frb_BLS12381= {0xF78A126DDC4AF3L,0x356B0535B1FB08BL,0xEC971F63C5F282L,0x21EDB1ECDBFB032L,0x2231F9FB854A147L,0x1B1380CA23A7A40L,0xFC3E2B3L}; 51 | const BIG_384_58 SQRTm3_BLS12381= {0x1FB00000001AAAEL,0x313F5FB4FFFFED7L,0x2928BFC912627L,0x1D87D988BA6AF26L,0x2845E1033EFA3BFL,0x25FF9A6633A3655L,0x1A0111EA3L}; 52 | #endif 53 | -------------------------------------------------------------------------------- /nix/sources.json: -------------------------------------------------------------------------------- 1 | { 2 | "haskell-candid": { 3 | "branch": "master", 4 | "builtin": false, 5 | "description": "A candid library for Haskell", 6 | "homepage": null, 7 | "owner": "nomeata", 8 | "repo": "haskell-candid", 9 | "rev": "87a4f01eb9cb93c827a0a7f5f29af0ee19135308", 10 | "sha256": "0mcmj62x49k241k5rpc7j37yczjlcsgyssjwy1ncfs8ss0b8b03r", 11 | "type": "tarball", 12 | "url": "https://github.com/nomeata/haskell-candid/archive/87a4f01eb9cb93c827a0a7f5f29af0ee19135308.tar.gz", 13 | "url_template": "https://github.com///archive/.tar.gz" 14 | }, 15 | "http-client": { 16 | "branch": "mraszyk/nix", 17 | "sha256": "0jm9klh5a1gvzyxxinj0yylij2rgxqlprlgin6hfrby1xvwkdps7", 18 | "type": "tarball", 19 | "url": "https://github.com/mraszyk/http-client/raw/mraszyk/nix/http-client.tar.gz" 20 | }, 21 | "leb128-cereal": { 22 | "branch": "master", 23 | "builtin": false, 24 | "description": "LEB128 encoding for Haskell", 25 | "homepage": null, 26 | "owner": "nomeata", 27 | "repo": "haskell-leb128-cereal", 28 | "rev": "2c6646e8aea97e3b9a1e801188650ed2ede85d07", 29 | "sha256": "1xc3sj1ly3xx65l0h27bd8p367a7jqzx4nfhp4mbbdibys3fbh9n", 30 | "type": "tarball", 31 | "url": "https://github.com/nomeata/haskell-leb128-cereal/archive/2c6646e8aea97e3b9a1e801188650ed2ede85d07.tar.gz", 32 | "url_template": "https://github.com///archive/.tar.gz" 33 | }, 34 | "naersk": { 35 | "branch": "master", 36 | "builtin": false, 37 | "description": "Build rust crates in Nix. No configuration, no code generation, no IFD. Sandbox friendly.", 38 | "homepage": "", 39 | "owner": "nix-community", 40 | "repo": "naersk", 41 | "rev": "d998160d6a076cfe8f9741e56aeec7e267e3e114", 42 | "sha256": "sha256-ezQCsNgmpUHdZANDCILm3RvtO1xH8uujk/+EqNvzIOg=", 43 | "type": "tarball", 44 | "url": "https://github.com/nix-community/naersk/archive/d998160d6a076cfe8f9741e56aeec7e267e3e114.tar.gz", 45 | "url_template": "https://github.com///archive/.tar.gz" 46 | }, 47 | "nixpkgs": { 48 | "branch": "release-23.05", 49 | "builtin": true, 50 | "description": "Nixpkgs/NixOS branches that track the Nixpkgs/NixOS channels", 51 | "homepage": null, 52 | "owner": "NixOS", 53 | "repo": "nixpkgs", 54 | "rev": "652af6eb88e1bc633bc6dc44827519f6e7284dbb", 55 | "sha256": "0hi1a2yjkb2ljbq3jb35rqh5h3zdjmdx2vdg91g8fa5hxf7wzz70", 56 | "type": "tarball", 57 | "url": "https://github.com/NixOS/nixpkgs/archive/652af6eb88e1bc633bc6dc44827519f6e7284dbb.tar.gz", 58 | "url_template": "https://github.com///archive/.tar.gz" 59 | }, 60 | "winter": { 61 | "branch": "master", 62 | "builtin": false, 63 | "description": "Haskell port of the WebAssembly OCaml reference interpreter", 64 | "homepage": "https://github.com/dfinity-side-projects/winter", 65 | "owner": "dfinity-side-projects", 66 | "repo": "winter", 67 | "rev": "3b230c16397188290d12ccba07fbeac86260acf6", 68 | "sha256": "0jq1ac79nbzbm0b7s3b9b5rdhhxj2j5qrj378cd5skrqwg6595kz", 69 | "type": "tarball", 70 | "url": "https://github.com/dfinity-side-projects/winter/archive/3b230c16397188290d12ccba07fbeac86260acf6.tar.gz", 71 | "url_template": "https://github.com///archive/.tar.gz" 72 | } 73 | } 74 | -------------------------------------------------------------------------------- /nix/generated/ic-hs.nix: -------------------------------------------------------------------------------- 1 | # THIS IS AN AUTOMATICALLY GENERATED FILE. DO NOT EDIT MANUALLY! 2 | # See ./nix/generate.nix for instructions. 3 | 4 | { mkDerivation 5 | , pkgs 6 | , aeson 7 | , asn1-encoding 8 | , asn1-types 9 | , async 10 | , atomic-write 11 | , base 12 | , base32 13 | , base64-bytestring 14 | , binary 15 | , bytestring 16 | , candid 17 | , case-insensitive 18 | , cborg 19 | , cereal 20 | , connection 21 | , containers 22 | , crc 23 | , cryptonite 24 | , data-default-class 25 | , directory 26 | , ed25519 27 | , either 28 | , filepath 29 | , hashable 30 | , haskoin-core 31 | , hex-text 32 | , http-client 33 | , http-client-tls 34 | , http-types 35 | , leb128-cereal 36 | , lib 37 | , memory 38 | , MonadRandom 39 | , mtl 40 | , network-uri 41 | , optparse-applicative 42 | , parallel 43 | , prettyprinter 44 | , primitive 45 | , process 46 | , quickcheck-io 47 | , random 48 | , row-types 49 | , serialise 50 | , split 51 | , splitmix 52 | , tasty 53 | , tasty-ant-xml 54 | , tasty-html 55 | , tasty-hunit 56 | , tasty-quickcheck 57 | , tasty-rerun 58 | , template-haskell 59 | , temporary 60 | , text 61 | , time 62 | , tls 63 | , transformers 64 | , uglymemo 65 | , unordered-containers 66 | , utf8-string 67 | , vector 68 | , wai 69 | , wai-cors 70 | , wai-extra 71 | , warp 72 | , wide-word 73 | , winter 74 | , word8 75 | , x509 76 | , x509-store 77 | , x509-validation 78 | , zlib 79 | }: 80 | mkDerivation { 81 | pname = "ic-hs"; 82 | version = "0.0.1"; 83 | src = pkgs.lib.sourceByRegex (pkgs.subpath "/") [ "^src.*" "^bin.*" "^tests.*" "^ic-hs.cabal" "^cbits.*" "^LICENSE" "^ic.did" ]; 84 | isLibrary = true; 85 | isExecutable = true; 86 | libraryHaskellDepends = [ 87 | aeson 88 | asn1-encoding 89 | asn1-types 90 | async 91 | atomic-write 92 | base 93 | base32 94 | base64-bytestring 95 | binary 96 | bytestring 97 | candid 98 | case-insensitive 99 | cborg 100 | cereal 101 | connection 102 | containers 103 | crc 104 | cryptonite 105 | data-default-class 106 | directory 107 | ed25519 108 | either 109 | filepath 110 | hashable 111 | haskoin-core 112 | hex-text 113 | http-client 114 | http-client-tls 115 | http-types 116 | leb128-cereal 117 | memory 118 | MonadRandom 119 | mtl 120 | network-uri 121 | optparse-applicative 122 | parallel 123 | prettyprinter 124 | primitive 125 | process 126 | quickcheck-io 127 | random 128 | row-types 129 | serialise 130 | split 131 | splitmix 132 | tasty 133 | tasty-ant-xml 134 | tasty-html 135 | tasty-hunit 136 | tasty-quickcheck 137 | tasty-rerun 138 | template-haskell 139 | temporary 140 | text 141 | time 142 | tls 143 | transformers 144 | uglymemo 145 | unordered-containers 146 | utf8-string 147 | vector 148 | wai 149 | wai-cors 150 | wai-extra 151 | warp 152 | wide-word 153 | winter 154 | word8 155 | x509 156 | x509-store 157 | x509-validation 158 | zlib 159 | ]; 160 | executableHaskellDepends = [ 161 | async 162 | base 163 | bytestring 164 | candid 165 | containers 166 | hex-text 167 | MonadRandom 168 | mtl 169 | optparse-applicative 170 | prettyprinter 171 | row-types 172 | tasty 173 | tasty-ant-xml 174 | tasty-html 175 | tasty-rerun 176 | text 177 | time 178 | transformers 179 | unordered-containers 180 | wai-cors 181 | wai-extra 182 | warp 183 | x509-store 184 | ]; 185 | testHaskellDepends = [ 186 | base 187 | containers 188 | directory 189 | tasty 190 | tasty-hunit 191 | temporary 192 | ]; 193 | doCheck = false; 194 | license = "LicenseRef-IC-1.0"; 195 | } 196 | -------------------------------------------------------------------------------- /src/IC/Management.hs: -------------------------------------------------------------------------------- 1 | {- 2 | Plumbing related to Candid and the management canister. 3 | -} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE TypeApplications #-} 6 | {-# LANGUAGE DataKinds #-} 7 | {-# LANGUAGE OverloadedLabels #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | {-# LANGUAGE QuasiQuotes #-} 11 | {-# OPTIONS_GHC -Wno-orphans #-} 12 | module IC.Management where 13 | 14 | import Codec.Candid 15 | import IC.Types 16 | import qualified Data.Row.Internal as R 17 | import qualified Data.Row as R 18 | import qualified Data.Row.Variants as V 19 | import qualified Data.Vector as Vec 20 | import Data.Row ((.==), (.+)) 21 | 22 | -- This needs cleaning up 23 | principalToEntityId :: Principal -> EntityId 24 | principalToEntityId = EntityId . rawPrincipal 25 | 26 | entityIdToPrincipal :: EntityId -> Principal 27 | entityIdToPrincipal = Principal . rawEntityId 28 | 29 | type SenderCanisterVersion = [candidType| 30 | record { 31 | sender_canister_version : opt nat64; 32 | } 33 | |] 34 | 35 | type InstallMode = [candidType| 36 | variant {install : null; reinstall : null; upgrade : null} 37 | |] 38 | 39 | type RunState = [candidType| 40 | variant { running; stopping; stopped } 41 | |] 42 | 43 | type Settings = [candidType| 44 | record { 45 | controllers : opt vec principal; 46 | compute_allocation : opt nat; 47 | memory_allocation : opt nat; 48 | freezing_threshold : opt nat; 49 | } 50 | |] 51 | 52 | type HttpHeader = [candidType| 53 | record { name: text; value: text } 54 | |] 55 | 56 | type HttpResponse = [candidType| 57 | record { 58 | status: nat; 59 | headers: vec record { name : text; value : text }; 60 | body: blob; 61 | } 62 | |] 63 | 64 | type CandidChangeOrigin = [candidType| 65 | variant { 66 | from_user : record { 67 | user_id : principal; 68 | }; 69 | from_canister : record { 70 | canister_id : principal; 71 | canister_version : opt nat64; 72 | }; 73 | } 74 | |] 75 | 76 | mapChangeOrigin :: ChangeOrigin -> CandidChangeOrigin 77 | mapChangeOrigin (ChangeFromUser user_id) = V.IsJust #from_user $ R.empty 78 | .+ #user_id .== entityIdToPrincipal user_id 79 | mapChangeOrigin (ChangeFromCanister canister_id canister_version) = V.IsJust #from_canister $ R.empty 80 | .+ #canister_id .== entityIdToPrincipal canister_id 81 | .+ #canister_version .== canister_version 82 | 83 | type CandidChangeDetails = [candidType| 84 | variant { 85 | creation : record { 86 | controllers : vec principal; 87 | }; 88 | code_uninstall; 89 | code_deployment : record { 90 | mode : variant {install; reinstall; upgrade}; 91 | module_hash : blob; 92 | }; 93 | controllers_change : record { 94 | controllers : vec principal; 95 | }; 96 | } 97 | |] 98 | 99 | mapChangeDetails :: ChangeDetails -> CandidChangeDetails 100 | mapChangeDetails (Creation controllers) = V.IsJust #creation $ R.empty 101 | .+ #controllers .== Vec.fromList (map entityIdToPrincipal controllers) 102 | mapChangeDetails CodeUninstall = V.IsJust #code_uninstall () 103 | mapChangeDetails (CodeDeployment mode module_hash) = V.IsJust #code_deployment $ R.empty 104 | .+ #mode .== mapInstallMode mode 105 | .+ #module_hash .== module_hash 106 | where 107 | mapInstallMode Reinstall = V.IsJust #reinstall () 108 | mapInstallMode Install = V.IsJust #install () 109 | mapInstallMode Upgrade = V.IsJust #upgrade () 110 | mapChangeDetails (ControllersChange controllers) = V.IsJust #controllers_change $ R.empty 111 | .+ #controllers .== Vec.fromList (map entityIdToPrincipal controllers) 112 | 113 | type ICManagement m = [candidFile|ic.did|] 114 | 115 | managementMethods :: [String] 116 | managementMethods = R.labels @(ICManagement IO) @R.Unconstrained1 117 | -------------------------------------------------------------------------------- /src/IC/Crypto/BLS.hsc: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-unused-imports -Wno-unused-top-binds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | #include 4 | module IC.Crypto.BLS 5 | ( init 6 | , SecretKey 7 | , createKey 8 | , toPublicKey 9 | , sign 10 | , verify 11 | ) where 12 | 13 | import Prelude hiding (init) 14 | import qualified Data.ByteString.Lazy as BS 15 | import qualified Data.ByteString as BSS 16 | import Control.Monad 17 | import Foreign 18 | import Foreign.Ptr 19 | import Foreign.Marshal.Alloc 20 | import GHC.Generics (Generic) 21 | import System.IO.Unsafe 22 | import Foreign.C.String 23 | import Foreign.C.Types 24 | 25 | data C'octet = C'octet CInt CInt CString 26 | 27 | instance Storable C'octet where 28 | sizeOf _ = (#size octet) 29 | alignment _ = alignment (undefined :: CInt) 30 | peek ptr = do 31 | len <- (#peek octet, len) ptr 32 | max <- (#peek octet, max) ptr 33 | val <- (#peek octet, val) ptr 34 | return (C'octet len max val) 35 | poke ptr (C'octet len max val) = do 36 | (#poke octet, len) ptr len 37 | (#poke octet, max) ptr max 38 | (#poke octet, val) ptr val 39 | 40 | 41 | foreign import ccall unsafe "bls_BLS12381.h BLS_BLS12381_INIT" 42 | c'BLS_BLS12381_INIT :: IO CInt 43 | foreign import ccall unsafe "bls_BLS12381.h BLS_BLS12381_KEY_PAIR_GENERATE" 44 | c'BLS_BLS12381_KEY_PAIR_GENERATE :: Ptr C'octet -> Ptr C'octet -> Ptr C'octet -> IO CInt 45 | foreign import ccall unsafe "bls_BLS12381.h BLS_BLS12381_CORE_SIGN" 46 | c'BLS_BLS12381_CORE_SIGN :: Ptr C'octet -> Ptr C'octet -> Ptr C'octet -> IO CInt 47 | foreign import ccall unsafe "bls_BLS12381.h BLS_BLS12381_CORE_VERIFY" 48 | c'BLS_BLS12381_CORE_VERIFY :: Ptr C'octet -> Ptr C'octet -> Ptr C'octet -> IO CInt 49 | 50 | init :: IO () 51 | init = do 52 | r <- c'BLS_BLS12381_INIT 53 | unless (r == 0) $ fail "Could not initialize BLS" 54 | 55 | 56 | -- Cache the public key as well 57 | data SecretKey = SecretKey BS.ByteString BS.ByteString 58 | deriving (Show, Generic) 59 | 60 | toPublicKey :: SecretKey -> BS.ByteString 61 | toPublicKey (SecretKey _ pk) = pk 62 | 63 | useAsOctet :: BS.ByteString -> (Ptr C'octet -> IO a) -> IO a 64 | useAsOctet bs a = 65 | BSS.useAsCStringLen (BS.toStrict bs) $ \(cstr, len) -> 66 | alloca $ \oct_ptr -> do 67 | poke oct_ptr (C'octet (fromIntegral len) (fromIntegral len) cstr) 68 | a oct_ptr 69 | 70 | allocOctet :: Int -> (Ptr C'octet -> IO a) -> IO a 71 | allocOctet size a = 72 | allocaBytes size $ \cstr -> 73 | alloca $ \oct_ptr -> do 74 | poke oct_ptr (C'octet 0 (fromIntegral size) cstr) 75 | a oct_ptr 76 | 77 | packOctet :: Ptr C'octet -> IO BS.ByteString 78 | packOctet oct_ptr = do 79 | C'octet len _ cstr' <- peek oct_ptr 80 | bs <- BSS.packCStringLen (cstr', fromIntegral len) 81 | return (BS.fromStrict bs) 82 | 83 | createKey :: BS.ByteString -> SecretKey 84 | createKey seed = unsafePerformIO $ 85 | useAsOctet seed $ \seed_ptr -> 86 | allocOctet 48 $ \sk_ptr -> 87 | allocOctet (4*48+1) $ \pk_ptr -> do 88 | r <- c'BLS_BLS12381_KEY_PAIR_GENERATE seed_ptr sk_ptr pk_ptr 89 | unless (r == 0) $ fail "Could not create BLS keys" 90 | SecretKey <$> packOctet sk_ptr <*> packOctet pk_ptr 91 | 92 | sign :: SecretKey -> BS.ByteString -> BS.ByteString 93 | sign (SecretKey sk _) msg = unsafePerformIO $ 94 | useAsOctet sk $ \sk_ptr -> 95 | useAsOctet msg $ \msg_ptr -> 96 | allocOctet (48+1) $ \sig_ptr -> do 97 | r <- c'BLS_BLS12381_CORE_SIGN sig_ptr msg_ptr sk_ptr 98 | unless (r == 0) $ fail "Could not create BLS keys" 99 | packOctet sig_ptr 100 | 101 | verify :: BS.ByteString -> BS.ByteString -> BS.ByteString -> Bool 102 | verify pk msg sig = unsafePerformIO $ 103 | useAsOctet pk $ \pk_ptr -> 104 | useAsOctet sig $ \sig_ptr -> 105 | useAsOctet msg $ \msg_ptr -> do 106 | r <- c'BLS_BLS12381_CORE_VERIFY sig_ptr msg_ptr pk_ptr 107 | return (r == 0) 108 | -------------------------------------------------------------------------------- /nix/generate.nix: -------------------------------------------------------------------------------- 1 | # This file generates the contents of nix/generated/. Use 2 | # 3 | # nix-shell generate.nix 4 | # 5 | # to update 6 | 7 | { pkgs ? import ../nix {} }: 8 | 9 | let 10 | 11 | # `haskellSrc2nixWithDoc` is used to generate `default.nix` files for 12 | # Haskell packages which are intended to be stored in the repository. 13 | # 14 | # The function generates a directory containing a `default.nix` which 15 | # is the result of running `cabal2nix` with the `extraCabal2nixOptions` 16 | # on the provided `src`. 17 | # 18 | # A header is added to `default.nix` which contains instructions on 19 | # how to regenerate that file. 20 | # 21 | # Finally the `src` attribute in the `default.nix` will be defined as 22 | # `src_subst` such that it can be pointed to local or niv-managed 23 | # sources. 24 | haskellSrc2nixWithDoc = {name, src, src_subst, extraCabal2nixOptions ? ""}: 25 | let 26 | drv = pkgs.haskellPackages.haskellSrc2nix { 27 | inherit name extraCabal2nixOptions src; 28 | }; 29 | in drv.overrideAttrs (oldAttrs: { 30 | message = '' 31 | # THIS IS AN AUTOMATICALLY GENERATED FILE. DO NOT EDIT MANUALLY!\ 32 | # See ./nix/generate.nix for instructions.\ 33 | 34 | ''; 35 | src_subst = pkgs.lib.replaceStrings ["\n"] [" "] src_subst; 36 | buildCommand = (oldAttrs.buildCommand or "") + '' 37 | sed -i "1i$message;s|src = .*|src = $src_subst;|" $out/default.nix 38 | # Accept `pkgs` as an argument in case the `src_subst` depends on it. 39 | sed -i "s|{ mkDerivation|{ mkDerivation, pkgs|" $out/default.nix 40 | ''; 41 | }); 42 | 43 | packages = { 44 | ic-hs = haskellSrc2nixWithDoc { 45 | name = "ic-hs"; 46 | src = pkgs.subpath "/"; 47 | # since the haskell code now lives on the top-level, 48 | # exclude some more files to avoid rebuilds 49 | src_subst = '' 50 | pkgs.lib.sourceByRegex (pkgs.subpath "/") 51 | ["^src.*" "^bin.*" "^tests.*" "^ic-hs.cabal" "^cbits.*" "^LICENSE" "^ic.did"] 52 | ''; 53 | extraCabal2nixOptions = "--no-check"; 54 | }; 55 | 56 | winter = haskellSrc2nixWithDoc { 57 | name = "winter"; 58 | src = pkgs.sources.winter; 59 | src_subst = "pkgs.sources.winter"; 60 | extraCabal2nixOptions = "--no-check"; 61 | }; 62 | leb128-cereal = haskellSrc2nixWithDoc { 63 | name = "leb128-cereal"; 64 | src = pkgs.sources.leb128-cereal; 65 | src_subst = "pkgs.sources.leb128-cereal"; 66 | }; 67 | candid = haskellSrc2nixWithDoc { 68 | name = "candid"; 69 | src = pkgs.sources.haskell-candid; 70 | src_subst = "pkgs.sources.haskell-candid"; 71 | }; 72 | http-client = haskellSrc2nixWithDoc { 73 | name = "http-client"; 74 | src = pkgs.sources.http-client; 75 | src_subst = "pkgs.sources.http-client"; 76 | }; 77 | }; 78 | 79 | allGenerated = pkgs.runCommandNoCC "generated" { 80 | buildInputs = [ pkgs.nixpkgs-fmt ]; 81 | } ( 82 | '' 83 | mkdir -p $out 84 | echo 'self: super: {' >> $out/all.nix 85 | '' + builtins.concatStringsSep "" ( 86 | pkgs.lib.flip pkgs.lib.mapAttrsToList packages ( 87 | n: pkg: '' 88 | cp ${pkg}/default.nix $out/${n}.nix 89 | echo ' ${n} = super.callPackage ./${n}.nix { };' >> $out/all.nix 90 | '' 91 | ) 92 | ) + '' 93 | echo '}' >> $out/all.nix 94 | chmod u+w $out/*.nix 95 | nixpkgs-fmt $out/*.nix 96 | cat <<__END__ > $out/README.md 97 | The contents of this directory are automatically generated. 98 | To update, please run nix-shell generate.nix 99 | __END__ 100 | '' 101 | ); 102 | in 103 | allGenerated.overrideAttrs ( 104 | old: { 105 | shellHook = if pkgs.lib.inNixShell then 106 | '' 107 | dest=${toString ./generated} 108 | 109 | rm -f $dest/*.nix $dest/README.md 110 | cp -v -t $dest/ ${allGenerated}/* 111 | chmod u-w -R $dest/* 112 | 113 | exit 0 114 | '' else null; 115 | } 116 | ) 117 | -------------------------------------------------------------------------------- /ic.did: -------------------------------------------------------------------------------- 1 | type canister_id = principal; 2 | type wasm_module = blob; 3 | 4 | type canister_settings = record { 5 | controllers : opt vec principal; 6 | compute_allocation : opt nat; 7 | memory_allocation : opt nat; 8 | freezing_threshold : opt nat; 9 | }; 10 | 11 | type definite_canister_settings = record { 12 | controllers : vec principal; 13 | compute_allocation : nat; 14 | memory_allocation : nat; 15 | freezing_threshold : nat; 16 | }; 17 | 18 | type change_origin = variant { 19 | from_user : record { 20 | user_id : principal; 21 | }; 22 | from_canister : record { 23 | canister_id : principal; 24 | canister_version : opt nat64; 25 | }; 26 | }; 27 | 28 | type change_details = variant { 29 | creation : record { 30 | controllers : vec principal; 31 | }; 32 | code_uninstall; 33 | code_deployment : record { 34 | mode : variant {install; reinstall; upgrade}; 35 | module_hash : blob; 36 | }; 37 | controllers_change : record { 38 | controllers : vec principal; 39 | }; 40 | }; 41 | 42 | type change = record { 43 | timestamp_nanos : nat64; 44 | canister_version : nat64; 45 | origin : change_origin; 46 | details : change_details; 47 | }; 48 | 49 | type http_header = record { name: text; value: text }; 50 | 51 | type http_response = record { 52 | status: nat; 53 | headers: vec http_header; 54 | body: blob; 55 | }; 56 | 57 | type ecdsa_curve = variant { secp256k1; }; 58 | 59 | service ic : { 60 | create_canister : (record { 61 | settings : opt canister_settings; 62 | sender_canister_version : opt nat64; 63 | }) -> (record {canister_id : canister_id}); 64 | update_settings : (record { 65 | canister_id : principal; 66 | settings : canister_settings; 67 | sender_canister_version : opt nat64; 68 | }) -> (); 69 | install_code : (record { 70 | mode : variant {install; reinstall; upgrade}; 71 | canister_id : canister_id; 72 | wasm_module : wasm_module; 73 | arg : blob; 74 | sender_canister_version : opt nat64; 75 | }) -> (); 76 | uninstall_code : (record { 77 | canister_id : canister_id; 78 | sender_canister_version : opt nat64; 79 | }) -> (); 80 | start_canister : (record {canister_id : canister_id}) -> (); 81 | stop_canister : (record {canister_id : canister_id}) -> (); 82 | canister_status : (record {canister_id : canister_id}) -> (record { 83 | status : variant { running; stopping; stopped }; 84 | settings: definite_canister_settings; 85 | module_hash: opt blob; 86 | memory_size: nat; 87 | cycles: nat; 88 | idle_cycles_burned_per_day: nat; 89 | }); 90 | canister_info : (record { 91 | canister_id : canister_id; 92 | num_requested_changes : opt nat64; 93 | }) -> (record { 94 | total_num_changes : nat64; 95 | recent_changes : vec change; 96 | module_hash : opt blob; 97 | controllers : vec principal; 98 | }); 99 | delete_canister : (record {canister_id : canister_id}) -> (); 100 | deposit_cycles : (record {canister_id : canister_id}) -> (); 101 | raw_rand : () -> (blob); 102 | http_request : (record { 103 | url : text; 104 | max_response_bytes: opt nat64; 105 | method : variant { get; head; post }; 106 | headers: vec http_header; 107 | body : opt blob; 108 | transform : opt record { 109 | function : func (record {response : http_response; context : blob}) -> (http_response) query; 110 | context : blob 111 | }; 112 | }) -> (http_response); 113 | 114 | // Threshold ECDSA signature 115 | ecdsa_public_key : (record { 116 | canister_id : opt canister_id; 117 | derivation_path : vec blob; 118 | key_id : record { curve: ecdsa_curve; name: text }; 119 | }) -> (record { public_key : blob; chain_code : blob; }); 120 | sign_with_ecdsa : (record { 121 | message_hash : blob; 122 | derivation_path : vec blob; 123 | key_id : record { curve: ecdsa_curve; name: text }; 124 | }) -> (record { signature : blob }); 125 | 126 | // provisional interfaces for the pre-ledger world 127 | provisional_create_canister_with_cycles : (record { 128 | amount: opt nat; 129 | settings : opt canister_settings; 130 | specified_id: opt canister_id; 131 | sender_canister_version : opt nat64; 132 | }) -> (record {canister_id : canister_id}); 133 | provisional_top_up_canister : 134 | (record { canister_id: canister_id; amount: nat }) -> (); 135 | } 136 | -------------------------------------------------------------------------------- /cbits/hpke_BLS12381.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2012-2020 MIRACL UK Ltd. 3 | * 4 | * This file is part of MIRACL Core 5 | * (see https://github.com/miracl/core). 6 | * 7 | * Licensed under the Apache License, Version 2.0 (the "License"); 8 | * you may not use this file except in compliance with the License. 9 | * You may obtain a copy of the License at 10 | * 11 | * http://www.apache.org/licenses/LICENSE-2.0 12 | * 13 | * Unless required by applicable law or agreed to in writing, software 14 | * distributed under the License is distributed on an "AS IS" BASIS, 15 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 16 | * See the License for the specific language governing permissions and 17 | * limitations under the License. 18 | */ 19 | 20 | /** 21 | * @file hpke.h 22 | * @author Mike Scott 23 | * @date 2nd December 2019 24 | * @brief HPKE Header file 25 | * 26 | * declares functions 27 | * 28 | */ 29 | 30 | #ifndef HPKE_BLS12381_H 31 | #define HPKE_BLS12381_H 32 | 33 | #include "ecdh_BLS12381.h" 34 | 35 | //#define CONFIG_ID 0x2A // 01|01|010 = 1, 1, 2 36 | //#define KEM_ID 2 // Curve X25519 37 | //#define KEM_ID 3 // Curve X448 38 | //#define KDF_ID 1 // HKDF-SHA256 39 | //#define AEAD_ID 1 // AES-GCM-128 40 | 41 | #define HPKE_OK 0 /**< Function completed without error */ 42 | #define HPKE_INVALID_PUBLIC_KEY -2 /**< Public Key is Invalid */ 43 | #define HPKE_ERROR -3 /**< HPKE Internal Error */ 44 | 45 | /* HPKE DHKEM primitives */ 46 | 47 | /** @brief Derive a Key Pair from a seed 48 | * 49 | @param config_id is the configuration KEM/KDF/AEAD 50 | @param SK is the output secret key 51 | @param PK is the output public key 52 | @param SEED is the input random seed 53 | @return 1 if OK, 0 if failed 54 | */ 55 | extern int DeriveKeyPair_BLS12381(int config_id,octet *SK,octet *PK,octet *SEED); 56 | 57 | /** @brief Encapsulate function 58 | * 59 | @param config_id is the configuration KEM/KDF/AEAD 60 | @param SK is the input ephemeral secret 61 | @param Z is a pointer to a shared secret DH(skE,pkR) 62 | @param pkE the ephemeral public key, which is skE.G, where G is a fixed generator 63 | @param pkR the respondents public key 64 | */ 65 | extern void HPKE_BLS12381_Encap(int config_id,octet *SK,octet *Z,octet *pkE,octet *pkR); 66 | 67 | /** @brief Decapsulate function 68 | * 69 | @param config_id is the configuration KEM/KDF/AEAD 70 | @param skR the respondents private key 71 | @param Z is a pointer to a shared secret DH(skR,pkE) 72 | @param pkE the ephemeral public key 73 | @param pkR the respondents private key 74 | */ 75 | extern void HPKE_BLS12381_Decap(int config_id,octet *skR,octet *Z,octet *pkE,octet *pkR); 76 | 77 | /** @brief Encapsulate/Authenticate function 78 | * 79 | @param config_id is the configuration KEM/KDF/AEAD 80 | @param skE is the input ephemeral secret 81 | @param skS is the Initiators private key 82 | @param Z is a pointer to a shared secret DH(skE,pkR) 83 | @param pkE the ephemeral public key, which is skE.G, where G is a fixed generator 84 | @param pkR the Respondents public key 85 | @param pkS the Initiators public key 86 | */ 87 | extern void HPKE_BLS12381_AuthEncap(int config_id,octet *skE,octet *skS,octet *Z,octet *pkE,octet *pkR,octet *pkS); 88 | 89 | /** @brief Decapsulate function 90 | * 91 | @param config_id is the configuration KEM/KDF/AEAD 92 | @param skR is the Respondents private key 93 | @param Z is a pointer to a shared secret DH(skR,pkE) 94 | @param pkE the ephemeral public key 95 | @param pkR the Respondents public key 96 | @param pkS the Initiators public key 97 | */ 98 | extern void HPKE_BLS12381_AuthDecap(int config_id,octet *skR,octet *Z,octet *pkE,octet *pkR,octet *pkS); 99 | 100 | /** @brief KeyScheduler function 101 | * 102 | @param config_id is the configuration KEM/KDF/AEAD 103 | @param key the output key for aead encryption 104 | @param nonce the output nonce for aead encryption 105 | @param exp_secret the exporter secret 106 | @param mode the mode of operation 107 | @param Z the shared key 108 | @param info application dependent info 109 | @param psk pre-shared key 110 | @param pskID identifier for the psk 111 | */ 112 | extern void HPKE_BLS12381_KeySchedule(int config_id,octet *key,octet *nonce,octet *exp_secret,int mode,octet *Z,octet *info,octet *psk,octet *pskID); 113 | 114 | #endif 115 | -------------------------------------------------------------------------------- /nix/gitSource.nix: -------------------------------------------------------------------------------- 1 | # The function call 2 | # 3 | # gitSource ./toplevel subpath 4 | # 5 | # creates a Nix store path of ./toplevel/subpath that includes only those files 6 | # tracked by git. More precisely: mentioned in the git index (i.e. git add is enough 7 | # to get them to be included, you do not have to commit). 8 | # 9 | # This is a whitelist-based alternative to manually listing files or using 10 | # nix-gitignore. 11 | 12 | # Internally, it works by calling git ls-files at evaluation time. To 13 | # avoid copying all of `.git` to the git store, it only copies the least amount 14 | # of files necessary for `git ls-files` to work; this is a bit fragile, but 15 | # very fast. 16 | 17 | with builtins; 18 | 19 | # We read the git index once, before getting the subdir parameter, so that it 20 | # is shared among multiple invocations of gitSource: 21 | 22 | let 23 | filter_from_list = root: files: 24 | let 25 | all_paren_dirs = p: 26 | if p == "." || p == "/" 27 | then [] 28 | else [ p ] ++ all_paren_dirs (dirOf p); 29 | 30 | whitelist_set = listToAttrs ( 31 | concatMap (p: 32 | let full_path = toString (root + "/${p}"); in 33 | map (p': { name = p'; value = true; }) (all_paren_dirs full_path) 34 | ) files 35 | ); 36 | in 37 | p: t: hasAttr (toString p) whitelist_set; 38 | 39 | has_prefix = prefix: s: 40 | prefix == builtins.substring 0 (builtins.stringLength prefix) s; 41 | has_suffix = suffix: s: 42 | let x1 = builtins.stringLength suffix - builtins.stringLength s; in 43 | x1 >= 0 && suffix == builtins.substring x1 (builtins.stringLength s) s; 44 | remove_prefix = prefix: s: 45 | builtins.substring 46 | (builtins.stringLength prefix) 47 | (builtins.stringLength s - builtins.stringLength prefix) 48 | s; 49 | 50 | lines = s: filter (x : x != [] && x != "") (split "\n" s); 51 | 52 | # On hydra, checkouts are always clean, and we don't want to do IFD 53 | isHydra = (builtins.tryEval ).success; 54 | not_dot_git = p: t: !(has_suffix ".git" p); 55 | 56 | # Stable name even when subdir == / 57 | nameFor = subdir: if (subdir == "/") then "src" else baseNameOf (toString subdir); 58 | in 59 | 60 | # unfortunately this is not completely self-contained, 61 | # we needs pkgs this to get git and lib.cleanSourceWith 62 | let nixpkgs = import ./. {}; in 63 | 64 | if !isHydra && builtins.pathExists ../.git 65 | then 66 | let 67 | 68 | git_dir = 69 | if builtins.pathExists ../.git/index 70 | then ../.git 71 | else # likely a git worktree, so follow the indirection 72 | let 73 | git_content = lines (readFile ./../.git); 74 | first_line = head git_content; 75 | prefix = "gitdir: "; 76 | ok = length git_content == 1 && has_prefix prefix first_line; 77 | in 78 | if ok 79 | then /. + remove_prefix prefix first_line 80 | else abort "gitSource.nix: Cannot parse ${toString ./../.git}"; 81 | 82 | whitelist_file = 83 | nixpkgs.runCommand "git-ls-files" { 84 | envVariable = true; 85 | preferLocalBuild = true; 86 | allowSubstitutes = false; 87 | } '' 88 | cp ${git_dir + "/index"} index 89 | echo "ref: refs/heads/master" > HEAD 90 | mkdir objects refs 91 | ${nixpkgs.git}/bin/git --git-dir . ls-files > $out 92 | ''; 93 | 94 | whitelist = lines (readFile (whitelist_file.out)); 95 | 96 | filter = filter_from_list ../. whitelist; 97 | in 98 | subdir: nixpkgs.lib.cleanSourceWith { 99 | name = nameFor subdir; 100 | src = if isString subdir then (../. + "/${subdir}") else subdir; 101 | filter = filter; 102 | } 103 | 104 | else 105 | let warn_unless = b: m: x: if b then x else trace m x; in 106 | # No .git directory found, we should warn the user. 107 | # But when this repository is imported using something like 108 | # `builtins.fetchGit` then the source is extracted to /nix/store without a 109 | # .git directory, but in this case we know that it is clean, so do not warn 110 | warn_unless 111 | (isHydra || has_prefix "/nix/store" (toString ../.)) 112 | "gitSource.nix: ${toString ../.} does not seem to be a git repository,\nassuming it is a clean checkout." 113 | (subdir: nixpkgs.lib.cleanSourceWith { 114 | name = nameFor subdir; 115 | src = if isString subdir then (../. + "/${subdir}") else subdir; 116 | filter = not_dot_git; 117 | }) 118 | -------------------------------------------------------------------------------- /src/IC/Wasm/Winter/Persist.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExplicitForAll #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {- | 7 | This module provides a way to persist the state of a Winter Wasm instance, and 8 | to recover it. 9 | 10 | It is tailored to the use by ic-ref. For example it assumes that the 11 | table of a wasm instance is immutable. 12 | -} 13 | module IC.Wasm.Winter.Persist 14 | ( PInstance(..) 15 | , PModuleInst(..) 16 | , persistInstance 17 | , resumeInstance 18 | , persistMemory 19 | , resumeMemory 20 | ) 21 | where 22 | 23 | import Control.Monad 24 | import Control.Monad.ST 25 | import Data.Primitive.MutVar 26 | import qualified Data.IntMap as IM 27 | import qualified Data.Map.Lazy as M 28 | import qualified Data.Vector as V 29 | import Data.ByteString.Lazy (ByteString) 30 | import Data.Kind (Type) 31 | 32 | import qualified IC.Canister.StableMemory as Stable 33 | 34 | import qualified Wasm.Runtime.Global as W 35 | import qualified Wasm.Runtime.Instance as W 36 | import qualified Wasm.Runtime.Memory as W 37 | import qualified Wasm.Syntax.Values as W 38 | import qualified Wasm.Util.Source as W 39 | 40 | import IC.Wasm.Winter (Instance) 41 | 42 | -- | 43 | -- This stores data read from an instance. 44 | newtype PInstance = PInstance (Persisted (Instance ())) 45 | deriving Show 46 | 47 | persistInstance :: Instance s -> ST s PInstance 48 | persistInstance i = PInstance <$> persist i 49 | 50 | resumeInstance :: Instance s -> PInstance -> ST s () 51 | resumeInstance i (PInstance p) = resume i p 52 | 53 | persistMemory :: W.MemoryInst (ST s) -> ST s ByteString 54 | persistMemory i = persist i 55 | 56 | resumeMemory :: W.MemoryInst (ST s) -> ByteString -> ST s () 57 | resumeMemory i p = resume i p 58 | 59 | class Monad (M a) => Persistable a where 60 | type Persisted a :: Type 61 | type M a :: Type -> Type 62 | persist :: a -> M a (Persisted a) 63 | resume :: a -> Persisted a -> M a () 64 | 65 | instance Persistable (Stable.Memory s) where 66 | type Persisted (Stable.Memory s) = Stable.Repr 67 | type M (Stable.Memory s) = ST s 68 | persist = Stable.export 69 | resume = Stable.imp 70 | 71 | instance Persistable (W.MemoryInst (ST s)) where 72 | type Persisted (W.MemoryInst (ST s)) = ByteString 73 | type M (W.MemoryInst (ST s)) = ST s 74 | persist = W.exportMemory 75 | resume = W.importMemory 76 | 77 | instance Persistable (W.GlobalInst (ST s)) where 78 | type Persisted (W.GlobalInst (ST s)) = W.Value 79 | type M (W.GlobalInst (ST s)) = ST s 80 | persist m = readMutVar (W._giContent m) 81 | resume m = writeMutVar (W._giContent m) 82 | 83 | data PModuleInst = PModuleInst 84 | { memories :: V.Vector (Persisted (W.MemoryInst (ST ()))) 85 | , globals :: V.Vector (Persisted (W.GlobalInst (ST ()))) 86 | } 87 | deriving Show 88 | 89 | instance Persistable (W.ModuleInst W.Phrase (ST s)) where 90 | type Persisted (W.ModuleInst W.Phrase (ST s)) = PModuleInst 91 | type M (W.ModuleInst W.Phrase (ST s)) = ST s 92 | persist inst = PModuleInst 93 | <$> persist (W._miMemories inst) 94 | <*> persist (W._miGlobals inst) 95 | resume inst pinst = do 96 | resume (W._miMemories inst) (memories pinst) 97 | resume (W._miGlobals inst) (globals pinst) 98 | 99 | 100 | instance Persistable a => Persistable [a] where 101 | type Persisted [a] = [Persisted a] 102 | type M [a] = M a 103 | persist = mapM persist 104 | resume xs ys = do 105 | unless (length xs == length ys) $ error "Lengths don't match" 106 | zipWithM_ resume xs ys 107 | 108 | instance Persistable a => Persistable (V.Vector a) where 109 | type Persisted (V.Vector a) = V.Vector (Persisted a) 110 | type M (V.Vector a) = M a 111 | persist = mapM persist 112 | resume xs ys = do 113 | unless (V.length xs == V.length ys) $ error "Lengths don't match" 114 | V.zipWithM_ resume xs ys 115 | 116 | instance (Eq k, Persistable a) => Persistable (M.Map k a) where 117 | type Persisted (M.Map k a) = M.Map k (Persisted a) 118 | type M (M.Map k a) = M a 119 | persist = mapM persist 120 | resume xs ys = do 121 | unless (M.keys xs == M.keys ys) $ error "Map keys don't match" 122 | zipWithM_ resume (M.elems xs) (M.elems ys) 123 | 124 | instance Persistable a => Persistable (IM.IntMap a) where 125 | type Persisted (IM.IntMap a) = M.Map Int (Persisted a) 126 | type M (IM.IntMap a) = M a 127 | persist = mapM persist . M.fromList . IM.toList 128 | resume xs ys = do 129 | let ys' = IM.fromList (M.toList ys) 130 | unless (IM.keys xs == IM.keys ys') $ error "Map keys don't match" 131 | zipWithM_ resume (IM.elems xs) (IM.elems ys') 132 | 133 | instance Persistable a => Persistable (a, Int) where 134 | type Persisted (a, Int) = Persisted a 135 | type M (a, Int) = M a 136 | persist (a, _i) = persist a 137 | resume (a, _i) p = resume a p 138 | -------------------------------------------------------------------------------- /cbits/arch.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2012-2020 MIRACL UK Ltd. 3 | * 4 | * This file is part of MIRACL Core 5 | * (see https://github.com/miracl/core). 6 | * 7 | * Licensed under the Apache License, Version 2.0 (the "License"); 8 | * you may not use this file except in compliance with the License. 9 | * You may obtain a copy of the License at 10 | * 11 | * http://www.apache.org/licenses/LICENSE-2.0 12 | * 13 | * Unless required by applicable law or agreed to in writing, software 14 | * distributed under the License is distributed on an "AS IS" BASIS, 15 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 16 | * See the License for the specific language governing permissions and 17 | * limitations under the License. 18 | */ 19 | 20 | /* Architecture definition header file */ 21 | 22 | /** 23 | * @file arch.h 24 | * @author Mike Scott 25 | * @date 23rd February 2016 26 | * @brief Architecture Header File 27 | * 28 | * Specify Processor Architecture 29 | * 30 | */ 31 | 32 | /* NOTE: There is only one user configurable section in this header - see below */ 33 | 34 | #ifndef ARCH_H 35 | #define ARCH_H 36 | 37 | 38 | 39 | 40 | /*** START OF USER CONFIGURABLE SECTION - set architecture ***/ 41 | 42 | #ifdef CMAKE 43 | #define CHUNK @CORE_CHUNK@ /**< size of chunk in bits = wordlength of computer = 16, 32 or 64. Note not all curve options are supported on 16-bit processors - see rom.c */ 44 | #else 45 | #define CHUNK 64 /**< size of chunk in bits = wordlength of computer = 16, 32 or 64. Note not all curve options are supported on 16-bit processors - see rom.c */ 46 | #endif 47 | 48 | /*** END OF USER CONFIGURABLE SECTION ***/ 49 | 50 | /* Create Integer types */ 51 | /* Support for C99? Note for GCC need to explicitly include -std=c99 in command line */ 52 | 53 | #if __STDC_VERSION__ >= 199901L 54 | /* C99 code */ 55 | #define C99 56 | #else 57 | /* Not C99 code */ 58 | #endif 59 | 60 | #ifndef C99 /* You are on your own! These are for Microsoft C */ 61 | #define byte unsigned char /**< 8-bit unsigned integer */ 62 | #define sign32 __int32 /**< 32-bit signed integer */ 63 | #define sign8 signed char /**< 8-bit signed integer */ 64 | #define sign16 short int /**< 16-bit signed integer */ 65 | #define sign64 long long /**< 64-bit signed integer */ 66 | #define unsign32 unsigned __int32 /**< 32-bit unsigned integer */ 67 | #define unsign64 unsigned long long /**< 64-bit unsigned integer */ 68 | #else 69 | #include 70 | #define byte uint8_t /**< 8-bit unsigned integer */ 71 | #define sign8 int8_t /**< 8-bit signed integer */ 72 | #define sign16 int16_t /**< 16-bit signed integer */ 73 | #define sign32 int32_t /**< 32-bit signed integer */ 74 | #define sign64 int64_t /**< 64-bit signed integer */ 75 | #define unsign32 uint32_t /**< 32-bit unsigned integer */ 76 | #define unsign64 uint64_t /**< 64-bit unsigned integer */ 77 | #endif 78 | 79 | #define uchar unsigned char /**< Unsigned char */ 80 | 81 | /* Don't mess with anything below this line unless you know what you are doing */ 82 | /* This next is probably OK, but may need changing for non-C99-standard environments */ 83 | 84 | /* This next is probably OK, but may need changing for non-C99-standard environments */ 85 | 86 | #if CHUNK==16 87 | #ifndef C99 88 | #define chunk __int16 /**< C type corresponding to word length */ 89 | #define dchunk __int32 /**< Always define double length chunk type if available */ 90 | #else 91 | #define chunk int16_t /**< C type corresponding to word length */ 92 | #define dchunk int32_t /**< Always define double length chunk type if available */ 93 | #endif 94 | #endif 95 | 96 | #if CHUNK == 32 97 | #ifndef C99 98 | #define chunk __int32 /**< C type corresponding to word length */ 99 | #define dchunk __int64 /**< Always define double length chunk type if available */ 100 | #else 101 | #define chunk int32_t /**< C type corresponding to word length */ 102 | #define dchunk int64_t /**< Always define double length chunk type if available */ 103 | #endif 104 | #endif 105 | 106 | #if CHUNK == 64 107 | 108 | #ifndef C99 109 | #define chunk __int64 /**< C type corresponding to word length */ 110 | /**< Note - no 128-bit type available */ 111 | #else 112 | #define chunk int64_t /**< C type corresponding to word length */ 113 | //#ifdef __GNUC__ 114 | //#define dchunk __int128 /**< Always define double length chunk type if available - GCC supports 128 bit type ??? */ 115 | //#endif 116 | 117 | //#ifdef __clang__ 118 | //#define dchunk __int128 119 | #if defined(__SIZEOF_INT128__) && __SIZEOF_INT128__ == 16 120 | #define dchunk __int128 121 | #endif 122 | 123 | #endif 124 | #endif 125 | 126 | #ifdef dchunk 127 | #define COMBA /**< Use COMBA method for faster muls, sqrs and reductions */ 128 | #endif 129 | 130 | 131 | #endif 132 | -------------------------------------------------------------------------------- /src/IC/Serialise.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE StandaloneDeriving #-} 3 | {-# LANGUAGE ConstraintKinds #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE TypeSynonymInstances #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# OPTIONS_GHC -Wno-orphans #-} 8 | {- | 9 | This module defines Serialise instances of the IC state. 10 | 11 | We put them into their own module, despite the usual advise against orphan 12 | instances, to emphasize that these are not part of the `IC.Ref` module with its 13 | “reference implementation” status. 14 | 15 | Also, orphan instances are kinda ok in applications. 16 | 17 | -} 18 | 19 | module IC.Serialise () where 20 | 21 | import Codec.Serialise 22 | import GHC.Generics 23 | 24 | import qualified IC.Wasm.Winter as W 25 | import qualified IC.Canister.StableMemory as Stable 26 | import Control.Monad.Random.Lazy 27 | import System.Random.Internal (StdGen(..)) 28 | import System.Random.SplitMix 29 | 30 | import IC.Types 31 | import IC.Wasm.Winter.Persist 32 | import IC.Purify 33 | import IC.Canister.Snapshot 34 | import IC.Canister 35 | import IC.Ref.Types 36 | import IC.Crypto 37 | import qualified IC.Crypto.BLS as BLS 38 | 39 | instance Serialise W.Value 40 | 41 | deriving instance Generic Timestamp 42 | instance Serialise Timestamp where 43 | 44 | deriving instance Generic NeedsToRespond 45 | instance Serialise NeedsToRespond where 46 | 47 | deriving instance Generic RejectCode 48 | instance Serialise RejectCode where 49 | 50 | deriving instance Generic ErrorCode 51 | instance Serialise ErrorCode where 52 | 53 | deriving instance Generic Response 54 | instance Serialise Response where 55 | 56 | deriving instance Generic SubnetType 57 | instance Serialise SubnetType where 58 | 59 | deriving instance Generic WasmClosure 60 | instance Serialise WasmClosure where 61 | 62 | deriving instance Generic Callback 63 | instance Serialise Callback where 64 | 65 | deriving instance Generic MethodCall 66 | instance Serialise MethodCall where 67 | 68 | deriving instance Generic PInstance 69 | instance Serialise PInstance where 70 | 71 | deriving instance Generic PModuleInst 72 | instance Serialise PModuleInst where 73 | 74 | deriving instance Generic (Snapshot a) 75 | instance Serialise a => Serialise (Snapshot a) where 76 | 77 | deriving instance Generic IC 78 | instance Serialise IC where 79 | 80 | deriving instance Generic CallContext 81 | instance Serialise CallContext where 82 | 83 | deriving instance Generic Message 84 | instance Serialise Message where 85 | 86 | deriving instance Generic RequestStatus 87 | instance Serialise RequestStatus where 88 | 89 | deriving instance Generic CallResponse 90 | instance Serialise CallResponse where 91 | 92 | deriving instance Generic CallRequest 93 | instance Serialise CallRequest where 94 | 95 | deriving instance Generic RunStatus 96 | instance Serialise RunStatus where 97 | 98 | deriving instance Generic CanisterInstallMode 99 | instance Serialise CanisterInstallMode where 100 | 101 | deriving instance Generic ChangeOrigin 102 | instance Serialise ChangeOrigin where 103 | 104 | deriving instance Generic ChangeDetails 105 | instance Serialise ChangeDetails where 106 | 107 | deriving instance Generic Change 108 | instance Serialise Change where 109 | 110 | deriving instance Generic CanisterHistory 111 | instance Serialise CanisterHistory where 112 | 113 | deriving instance Generic CanState 114 | instance Serialise CanState where 115 | 116 | deriving instance Generic CallOrigin 117 | instance Serialise CallOrigin where 118 | 119 | deriving instance Generic EntryPoint 120 | instance Serialise EntryPoint where 121 | 122 | instance Serialise CanisterContent where 123 | encode cc = encode 124 | ( raw_wasm (can_mod cc) 125 | , wsInstances (wasm_state cc) 126 | , wsStableMem (wasm_state cc) 127 | ) 128 | decode = do 129 | (wasm, insts, sm) <- decode 130 | can_mod <- either fail pure $ parseCanister wasm 131 | -- There is some duplication here 132 | decodedModule <- either fail pure $ decodeModule wasm 133 | wasm_mod <- either fail pure $ W.parseModule decodedModule 134 | return $ CanisterContent 135 | { can_mod = can_mod 136 | , wasm_state = CanisterSnapshot 137 | { wsModule = wasm_mod 138 | , wsInstances = insts 139 | , wsStableMem = sm 140 | } 141 | } 142 | 143 | deriving instance Serialise EntityId 144 | 145 | deriving instance Serialise StdGen 146 | 147 | instance Serialise Stable.Repr where 148 | encode = encode . Stable.serialize 149 | decode = Stable.deserialize <$> decode 150 | 151 | instance Serialise SMGen where 152 | encode = encode . unseedSMGen 153 | decode = seedSMGen' <$> decode 154 | 155 | instance Serialise BLS.SecretKey 156 | instance Serialise SecretKey where 157 | encode (BLS sk) = encode sk 158 | encode _ = error "IC.Serialise SecretKey: Only BLS supported" 159 | decode = BLS <$> decode 160 | -------------------------------------------------------------------------------- /cbits/mpin_BLS12381.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2012-2020 MIRACL UK Ltd. 3 | * 4 | * This file is part of MIRACL Core 5 | * (see https://github.com/miracl/core). 6 | * 7 | * Licensed under the Apache License, Version 2.0 (the "License"); 8 | * you may not use this file except in compliance with the License. 9 | * You may obtain a copy of the License at 10 | * 11 | * http://www.apache.org/licenses/LICENSE-2.0 12 | * 13 | * Unless required by applicable law or agreed to in writing, software 14 | * distributed under the License is distributed on an "AS IS" BASIS, 15 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 16 | * See the License for the specific language governing permissions and 17 | * limitations under the License. 18 | */ 19 | 20 | /** 21 | * @file mpin.h 22 | * @author Mike Scott and Kealan McCusker 23 | * @date 2nd June 2015 24 | * @brief M-Pin Header file 25 | * 26 | * Allows some user configuration 27 | * defines structures 28 | * declares functions 29 | * 30 | */ 31 | 32 | #ifndef MPIN_BLS12381_H 33 | #define MPIN_BLS12381_H 34 | 35 | #include "pair_BLS12381.h" 36 | 37 | /* Field size is assumed to be greater than or equal to group size */ 38 | 39 | #define PGS_BLS12381 MODBYTES_384_58 /**< MPIN Group Size */ 40 | #define PFS_BLS12381 MODBYTES_384_58 /**< MPIN Field Size */ 41 | 42 | #define MPIN_OK 0 /**< Function completed without error */ 43 | #define MPIN_INVALID_POINT -14 /**< Point is NOT on the curve */ 44 | #define MPIN_BAD_PIN -19 /**< Bad PIN number entered */ 45 | 46 | #define MAXPIN 10000 /**< max PIN */ 47 | #define PBLEN 14 /**< max length of PIN in bits */ 48 | 49 | //#define PAS_BLS12381 16 /**< MPIN Symmetric Key Size 128 bits */ 50 | //#define HASH_TYPE_MPIN_BLS12381 SHA256 /**< Choose Hash function */ 51 | 52 | /* MPIN support functions */ 53 | 54 | /* MPIN primitives */ 55 | 56 | /** @brief Encode a string to a curve point (in constant time) 57 | * 58 | @param DST is the Domain Separation Tag 59 | @param ID is the input string 60 | @param HID is the output point in G1 61 | */ 62 | void MPIN_BLS12381_ENCODE_TO_CURVE(octet *DST,octet *ID,octet *HID); 63 | 64 | /** @brief Extract a PIN number from a client secret 65 | * 66 | @param HID is the hashed-to-curve input client identity 67 | @param pin is an input PIN number 68 | @param CS is the client secret from which the PIN is to be extracted 69 | @return 0 or an error code 70 | */ 71 | int MPIN_BLS12381_EXTRACT_PIN(octet *HID, int pin, octet *CS); 72 | 73 | /** @brief Perform first pass of the client side of the 3-pass version of the M-Pin protocol 74 | * 75 | @param HID is the hashed-to-curve input client identity 76 | @param R is a pointer to a cryptographically secure random number generator 77 | @param x an output internally randomly generated if R!=NULL, otherwise must be provided as an input 78 | @param pin is the input PIN number 79 | @param T is the input M-Pin token (the client secret with PIN portion removed) 80 | @param S is the reconstructed client secret 81 | @param U is output = x.H(ID) 82 | @return 0 or an error code 83 | */ 84 | int MPIN_BLS12381_CLIENT_1(octet *HID, csprng *R, octet *x, int pin, octet *T, octet *S, octet *U); 85 | /** @brief Generate a random group element 86 | * 87 | @param R is a pointer to a cryptographically secure random number generator 88 | @param S is the output random octet 89 | @return 0 or an error code 90 | */ 91 | int MPIN_BLS12381_RANDOM_GENERATE(csprng *R, octet *S); 92 | /** @brief Perform second pass of the client side of the 3-pass version of the M-Pin protocol 93 | * 94 | @param x an input, a locally generated random number 95 | @param y an input random challenge from the server 96 | @param V on output = -(x+y).V 97 | @return 0 or an error code 98 | */ 99 | int MPIN_BLS12381_CLIENT_2(octet *x, octet *y, octet *V); 100 | 101 | /** @brief Perform final pass on the server side of the M-Pin protocol 102 | 103 | @param HID is input H(ID), a hash of the client ID 104 | @param y is the input server's randomly generated challenge 105 | @param SS is the input server secret 106 | @param U is input from the client = x.H(ID) 107 | @param V is an input from the client 108 | @return 0 or an error code 109 | */ 110 | int MPIN_BLS12381_SERVER(octet *HID, octet *y, octet *SS, octet *U, octet *V); 111 | 112 | /** @brief Create a client secret in G1 from a master secret and the client ID 113 | * 114 | @param S is an input master secret 115 | @param HID is the input client identity hashed to curve 116 | @param CS is the full client secret = s.H(ID) 117 | @return 0 or an error code 118 | */ 119 | int MPIN_BLS12381_GET_CLIENT_SECRET(octet *S, octet *HID, octet *CS); 120 | 121 | /** @brief Create a server secret in G2 from a master secret 122 | * 123 | @param S is an input master secret 124 | @param SS is the server secret = s.Q where Q is a fixed generator of G2 125 | @return 0 or an error code 126 | */ 127 | int MPIN_BLS12381_GET_SERVER_SECRET(octet *S, octet *SS); 128 | 129 | #endif 130 | 131 | -------------------------------------------------------------------------------- /cbits/rand.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2012-2020 MIRACL UK Ltd. 3 | * 4 | * This file is part of MIRACL Core 5 | * (see https://github.com/miracl/core). 6 | * 7 | * Licensed under the Apache License, Version 2.0 (the "License"); 8 | * you may not use this file except in compliance with the License. 9 | * You may obtain a copy of the License at 10 | * 11 | * http://www.apache.org/licenses/LICENSE-2.0 12 | * 13 | * Unless required by applicable law or agreed to in writing, software 14 | * distributed under the License is distributed on an "AS IS" BASIS, 15 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 16 | * See the License for the specific language governing permissions and 17 | * limitations under the License. 18 | */ 19 | 20 | /* 21 | * Cryptographic strong random number generator 22 | * 23 | * Unguessable seed -> SHA -> PRNG internal state -> SHA -> random numbers 24 | * Slow - but secure 25 | * 26 | * See ftp://ftp.rsasecurity.com/pub/pdfs/bull-1.pdf for a justification 27 | */ 28 | /* SU=m, m is Stack Usage */ 29 | 30 | #include "core.h" 31 | 32 | /* SU= 20 */ 33 | static unsign32 sbrand(csprng *rng) 34 | { 35 | /* Marsaglia & Zaman random number generator */ 36 | int i, k; 37 | unsign32 pdiff, t; 38 | rng->rndptr++; 39 | if (rng->rndptr < NK) return rng->ira[rng->rndptr]; 40 | rng->rndptr = 0; 41 | for (i = 0, k = NK - NJ; i < NK; i++, k++) 42 | { 43 | /* calculate next NK values */ 44 | if (k == NK) k = 0; 45 | t = rng->ira[k]; 46 | pdiff = t - rng->ira[i] - rng->borrow; 47 | 48 | if (pdiff < t) rng->borrow = 0; 49 | if (pdiff > t) rng->borrow = 1; 50 | rng->ira[i] = pdiff; 51 | } 52 | return rng->ira[0]; 53 | } 54 | 55 | /* SU= 20 */ 56 | static void sirand(csprng* rng, unsign32 seed) 57 | { 58 | /* initialise random number system */ 59 | /* modified so that a subsequent call "stirs" in another seed value */ 60 | /* in this way as many seed bits as desired may be used */ 61 | int i, in; 62 | unsign32 t, m = 1; 63 | rng->borrow = 0L; 64 | rng->rndptr = 0; 65 | rng->ira[0] ^= seed; 66 | for (i = 1; i < NK; i++) 67 | { 68 | /* fill initialisation vector */ 69 | in = (NV * i) % NK; 70 | rng->ira[in] ^= m; /* note XOR */ 71 | t = m; 72 | m = seed - m; 73 | seed = t; 74 | } 75 | for (i = 0; i < 10000; i++) sbrand(rng ); /* "warm-up" & stir the generator */ 76 | } 77 | 78 | /* SU= 312 */ 79 | static void fill_pool(csprng *rng) 80 | { 81 | /* hash down output of RNG to re-fill the pool */ 82 | int i; 83 | hash256 sh; 84 | HASH256_init(&sh); 85 | for (i = 0; i < 128; i++) HASH256_process(&sh, sbrand(rng)); 86 | HASH256_hash(&sh, rng->pool); 87 | rng->pool_ptr = 0; 88 | } 89 | 90 | static unsign32 pack(const uchar *b) 91 | { 92 | /* pack bytes into a 32-bit Word */ 93 | return ((unsign32)b[3] << 24) | ((unsign32)b[2] << 16) | ((unsign32)b[1] << 8) | (unsign32)b[0]; 94 | } 95 | 96 | /* SU= 360 */ 97 | /* Initialize RNG with some real entropy from some external source */ 98 | void RAND_seed(csprng *rng, int rawlen, char *raw) 99 | { 100 | /* initialise from at least 128 byte string of raw * 101 | * random (keyboard?) input, and 32-bit time-of-day */ 102 | int i; 103 | char digest[32]; 104 | uchar b[4]; 105 | hash256 sh; 106 | rng->pool_ptr = 0; 107 | for (i = 0; i < NK; i++) rng->ira[i] = 0; 108 | if (rawlen > 0) 109 | { 110 | HASH256_init(&sh); 111 | for (i = 0; i < rawlen; i++) 112 | HASH256_process(&sh, raw[i]); 113 | HASH256_hash(&sh, digest); 114 | 115 | /* initialise PRNG from distilled randomness */ 116 | 117 | for (i = 0; i < 8; i++) 118 | { 119 | b[0] = digest[4 * i]; 120 | b[1] = digest[4 * i + 1]; 121 | b[2] = digest[4 * i + 2]; 122 | b[3] = digest[4 * i + 3]; 123 | // printf("%08x\n",pack(b)); 124 | sirand(rng, pack(b)); 125 | } 126 | } 127 | fill_pool(rng); 128 | } 129 | 130 | /* Terminate and clean up */ 131 | void RAND_clean(csprng *rng) 132 | { 133 | /* kill internal state */ 134 | int i; 135 | rng->pool_ptr = rng->rndptr = 0; 136 | for (i = 0; i < 32; i++) rng->pool[i] = 0; 137 | for (i = 0; i < NK; i++) rng->ira[i] = 0; 138 | rng->borrow = 0; 139 | } 140 | 141 | /* get random byte */ 142 | /* SU= 8 */ 143 | int RAND_byte(csprng *rng) 144 | { 145 | int r; 146 | r = rng->pool[rng->pool_ptr++]; 147 | if (rng->pool_ptr >= 32) fill_pool(rng); 148 | return (r & 0xff); 149 | } 150 | 151 | /* test main program */ 152 | /* 153 | #include 154 | #include 155 | 156 | void main() 157 | { 158 | int i; 159 | char raw[256]; 160 | csprng rng; 161 | 162 | RAND_clean(&rng); 163 | 164 | 165 | for (i=0;i<256;i++) raw[i]=(char)i; 166 | RAND_seed(&rng,256,raw); 167 | 168 | for (i=0;i<1000;i++) 169 | printf("%02x ",(unsigned char)RAND_byte(&rng)); 170 | } 171 | 172 | */ 173 | -------------------------------------------------------------------------------- /src/IC/Crypto.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Everything related to signature creation and checking 3 | -} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | module IC.Crypto 7 | ( SecretKey(..) 8 | , createSecretKeyEd25519 9 | , createSecretKeyWebAuthnECDSA 10 | , createSecretKeyWebAuthnRSA 11 | , createSecretKeyECDSA 12 | , createSecretKeySecp256k1 13 | , createSecretKeyBLS 14 | , toPublicKey 15 | , signPure 16 | , sign 17 | , verify 18 | ) 19 | where 20 | 21 | import qualified Data.Text as T 22 | import qualified Data.ByteString.Lazy as BS 23 | import qualified IC.Crypto.Ed25519 as Ed25519 24 | import qualified IC.Crypto.DER as DER 25 | import qualified IC.Crypto.WebAuthn as WebAuthn 26 | import qualified IC.Crypto.ECDSA as ECDSA 27 | import qualified IC.Crypto.Secp256k1 as Secp256k1 28 | import qualified IC.Crypto.BLS as BLS 29 | import qualified IC.Crypto.CanisterSig as CanisterSig 30 | import Data.Int 31 | import Control.Monad.Except 32 | 33 | data SecretKey 34 | = Ed25519 Ed25519.SecretKey 35 | | ECDSA ECDSA.SecretKey 36 | | Secp256k1 Secp256k1.SecretKey 37 | | WebAuthn WebAuthn.SecretKey 38 | | BLS BLS.SecretKey 39 | deriving (Show) 40 | 41 | createSecretKeyEd25519 :: BS.ByteString -> SecretKey 42 | createSecretKeyEd25519 = Ed25519 . Ed25519.createKey 43 | 44 | createSecretKeyWebAuthnECDSA :: BS.ByteString -> SecretKey 45 | createSecretKeyWebAuthnECDSA = WebAuthn . WebAuthn.createECDSAKey 46 | 47 | createSecretKeyWebAuthnRSA :: BS.ByteString -> SecretKey 48 | createSecretKeyWebAuthnRSA = WebAuthn . WebAuthn.createRSAKey 49 | 50 | createSecretKeyECDSA :: BS.ByteString -> SecretKey 51 | createSecretKeyECDSA = ECDSA . ECDSA.createKey 52 | 53 | createSecretKeySecp256k1 :: BS.ByteString -> SecretKey 54 | createSecretKeySecp256k1 = Secp256k1 . Secp256k1.createKey 55 | 56 | createSecretKeyBLS :: BS.ByteString -> SecretKey 57 | createSecretKeyBLS = BLS . BLS.createKey 58 | 59 | toPublicKey :: SecretKey -> BS.ByteString 60 | toPublicKey (Ed25519 sk) = DER.encode DER.Ed25519 $ Ed25519.toPublicKey sk 61 | toPublicKey (WebAuthn sk) = DER.encode DER.WebAuthn $ WebAuthn.toPublicKey sk 62 | toPublicKey (ECDSA sk) = DER.encode DER.ECDSA $ ECDSA.toPublicKey sk 63 | toPublicKey (Secp256k1 sk) = DER.encode DER.Secp256k1 $ Secp256k1.toPublicKey sk 64 | toPublicKey (BLS sk) = DER.encode DER.BLS $ BLS.toPublicKey sk 65 | 66 | signPure :: BS.ByteString -> SecretKey -> BS.ByteString -> BS.ByteString 67 | signPure domain_sep sk payload = case sk of 68 | Ed25519 sk -> Ed25519.sign sk msg 69 | WebAuthn _ -> error "WebAuthn not a pure signature" 70 | ECDSA _ -> error "ECDSA not a pure signature" 71 | Secp256k1 _ -> error "Secp256k1 is not a pure signature" 72 | BLS sk -> BLS.sign sk msg 73 | where 74 | msg | BS.null domain_sep = payload 75 | | otherwise = BS.singleton (fromIntegral (BS.length domain_sep)) <> domain_sep <> payload 76 | 77 | sign :: BS.ByteString -> SecretKey -> BS.ByteString -> IO BS.ByteString 78 | sign domain_sep sk payload = case sk of 79 | Ed25519 sk -> return $ Ed25519.sign sk msg 80 | WebAuthn sk -> WebAuthn.sign sk msg 81 | ECDSA sk -> ECDSA.sign sk msg 82 | Secp256k1 sk -> Secp256k1.sign sk msg 83 | BLS sk -> return $ BLS.sign sk msg 84 | where 85 | msg | BS.null domain_sep = payload 86 | | otherwise = BS.singleton (fromIntegral (BS.length domain_sep)) <> domain_sep <> payload 87 | 88 | verify :: BS.ByteString -> BS.ByteString -> BS.ByteString -> BS.ByteString -> BS.ByteString -> Either T.Text () 89 | verify root_key domain_sep der_pk payload sig = DER.decode der_pk >>= \case 90 | (DER.WebAuthn, pk) -> WebAuthn.verify pk msg sig 91 | 92 | (DER.Ed25519, pk) -> do 93 | assertLen "Ed25519 public key" 32 pk 94 | assertLen "Ed25519 signature" 64 sig 95 | 96 | unless (Ed25519.verify pk msg sig) $ do 97 | when (Ed25519.verify pk payload sig) $ 98 | throwError $ "domain separator " <> T.pack (show domain_sep) <> " missing" 99 | throwError "signature verification failed" 100 | 101 | (DER.ECDSA, pk) -> do 102 | unless (ECDSA.verify pk msg sig) $ do 103 | when (ECDSA.verify pk payload sig) $ 104 | throwError $ "domain separator " <> T.pack (show domain_sep) <> " missing" 105 | throwError "signature verification failed" 106 | 107 | (DER.Secp256k1, pk) -> Secp256k1.verify pk msg sig 108 | 109 | (DER.BLS, pk) -> do 110 | assertLen "BLS public key" 96 pk 111 | assertLen "BLS signature" 48 sig 112 | 113 | unless (BLS.verify pk msg sig) $ do 114 | when (BLS.verify pk payload sig) $ 115 | throwError $ "domain separator " <> T.pack (show domain_sep) <> " missing" 116 | throwError "signature verification failed" 117 | 118 | (DER.CanisterSig, pk) -> CanisterSig.verify root_key pk msg sig 119 | 120 | where 121 | msg = BS.singleton (fromIntegral (BS.length domain_sep)) <> domain_sep <> payload 122 | 123 | 124 | assertLen :: T.Text -> Int64 -> BS.ByteString -> Either T.Text () 125 | assertLen what len bs 126 | | BS.length bs == len = return () 127 | | otherwise = throwError $ what <> " has wrong length " <> T.pack (show (BS.length bs)) <> ", expected " <> T.pack (show len) 128 | -------------------------------------------------------------------------------- /src/IC/Canister/StableMemory.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-| 3 | This module provides a wrapper around primitive byte array, exposing just 4 | the bits needed for accessing the stable memory. 5 | -} 6 | module IC.Canister.StableMemory 7 | ( Memory 8 | , Repr 9 | , new 10 | , size 11 | , grow 12 | , read 13 | , write 14 | , export 15 | , imp 16 | , serialize 17 | , deserialize 18 | ) 19 | where 20 | 21 | import Prelude hiding (read) 22 | 23 | import Data.ByteString.Lazy (ByteString) 24 | import Data.Word 25 | import Data.STRef 26 | import Foreign.Ptr (plusPtr) 27 | import Foreign.ForeignPtr (withForeignPtr) 28 | import Control.Monad.Except 29 | import Control.Monad.ST 30 | 31 | import qualified Data.ByteString as BS 32 | import qualified Data.ByteString.Lazy as BL 33 | import qualified Data.ByteString.Internal as BI 34 | 35 | type Size = Word64 36 | type Address = Word64 37 | 38 | type HostM s = ExceptT String (ST s) 39 | type Memory s = STRef s Repr 40 | 41 | -- | Size of a WebAssembly page. 42 | pageSize :: Size 43 | pageSize = 65536 44 | 45 | -- NOTE: This stable memory representation is optimized for sparse writes and 46 | -- arbitrary resizes. 47 | -- 48 | -- Resizes and writes are very cheap, but the cost of reads is propotional to 49 | -- the size of the write history. This enables us to work with large memories 50 | -- without allocating gigabytes of storage. The main motivation for this 51 | -- representation was testing 64 bit stable memory API and its interaction with 52 | -- 32 bit API. 53 | -- 54 | -- See https://github.com/dfinity/ic-hs/issues/28 for more details. 55 | 56 | -- | Immutable representation of stable memory that can be used for snapshotting. 57 | data Repr 58 | = Repr 59 | { smSize :: Size 60 | , smWrites :: [(Address, BS.ByteString)] 61 | } deriving (Show) 62 | 63 | -- | Constructs a new empty memory. 64 | new :: HostM s (Memory s) 65 | new = lift $ (newSTRef $ Repr 0 []) 66 | 67 | memorySizeInBytes :: Memory s -> ST s Size 68 | memorySizeInBytes mem = (pageSize *) <$> memorySizeInPages mem 69 | 70 | memorySizeInPages :: Memory s -> ST s Size 71 | memorySizeInPages mem = smSize <$> readSTRef mem 72 | 73 | -- | Checks that range [offset, offset + len] lies within the memory. 74 | checkAccess :: Memory s -> Address -> Size -> HostM s () 75 | checkAccess mem offset len = do 76 | n <- lift $ memorySizeInBytes mem 77 | when ((fromIntegral offset :: Integer) + fromIntegral len > fromIntegral n) $ 78 | throwError "stable memory error: out of bounds" 79 | 80 | -- | Extracts a bytestring from stable memory representation. 81 | toByteString :: Repr -> Address -> Size -> ByteString 82 | toByteString repr offset len = BL.fromStrict $ BI.unsafeCreate (fromIntegral len) $ \dst -> do 83 | _ <- BI.memset dst 0 (fromIntegral len) 84 | forM_ (reverse $ smWrites repr) $ \(addr, blob) -> do 85 | let n = fromIntegral $ BS.length blob 86 | let copyStart = max offset addr 87 | let copyEnd = min (offset + len) (addr + n) 88 | when (copyStart < copyEnd) $ do 89 | let (fptr, blobOffset, _len) = BI.toForeignPtr blob 90 | withForeignPtr fptr $ \src -> 91 | BI.memcpy (plusPtr dst $ fromIntegral $ copyStart - offset) 92 | (plusPtr src $ blobOffset + (fromIntegral $ copyStart - addr)) 93 | (fromIntegral $ copyEnd - copyStart) 94 | 95 | -- | Returns the size of stable memory in WebAssembly pages. 96 | size :: Memory s -> HostM s Size 97 | size = lift . memorySizeInPages 98 | 99 | -- | Attempts to grow stable memory by @delta@ pages. 100 | grow :: Memory s -> Size -> HostM s Size 101 | grow mem delta = lift $ do 102 | repr <- readSTRef mem 103 | let oldSize = smSize repr 104 | writeSTRef mem (repr { smSize = oldSize + delta }) 105 | return oldSize 106 | 107 | -- | Reads a range of bytes from memory. 108 | read :: Memory s -> Address -> Size -> HostM s ByteString 109 | read mem ptr len = do 110 | checkAccess mem ptr len 111 | lift $ do 112 | repr <- readSTRef mem 113 | return $ toByteString repr ptr len 114 | 115 | -- | Writes a byte string at the specified offset. 116 | write :: Memory s -> Address -> ByteString -> HostM s () 117 | write mem ptr blob = do 118 | checkAccess mem ptr (fromIntegral $ BL.length blob) 119 | lift $ modifySTRef' mem (\repr -> repr { smWrites = (ptr, BL.toStrict blob) : smWrites repr }) 120 | 121 | -- | Exports immutable memory representation. 122 | export :: Memory s -> ST s Repr 123 | export = readSTRef 124 | 125 | -- | Sets the contents of memory to a previously exported value. 126 | imp :: Memory s -> Repr -> ST s () 127 | imp = writeSTRef 128 | 129 | -- | Converts internal memory representation into a bytestring. 130 | serialize :: Repr -> ByteString 131 | serialize repr = toByteString repr 0 (pageSize * smSize repr) 132 | 133 | -- | Constructs internal memory representation from a @blob@. 134 | -- Throws an exception if the length of the @blob@ is not a multiple of 64KiB. 135 | deserialize :: ByteString -> Repr 136 | deserialize blob = 137 | let n = fromIntegral $ BL.length blob 138 | in if (n `mod` pageSize) /= 0 139 | then error "StableMemory.deserialize: blob size is not a multiple of 64KiB" 140 | else Repr (n `quot` pageSize) [(0, BL.toStrict blob)] 141 | -------------------------------------------------------------------------------- /bin/ic-ref.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NumericUnderscores #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | import Options.Applicative 4 | import Data.Foldable 5 | import Data.Maybe(fromJust) 6 | import Data.Word as W 7 | import qualified Data.X509.CertificateStore as C 8 | import Control.Concurrent 9 | import Control.Monad (join, forever) 10 | import Network.Wai.Middleware.Cors 11 | import Network.Wai.Middleware.RequestLogger 12 | import Network.Wai.Handler.Warp 13 | import qualified Data.Text as T 14 | import IC.Constants 15 | import IC.HTTP 16 | import IC.Types 17 | import IC.Utils 18 | import IC.Version 19 | import qualified IC.Crypto.BLS as BLS 20 | 21 | defaultPort :: Port 22 | defaultPort = 8001 23 | 24 | 25 | work :: [(SubnetType, W.Word64, String, [(W.Word64, W.Word64)])] -> Maybe String -> Int -> Maybe Int -> Maybe FilePath -> Maybe FilePath -> Bool -> IO () 26 | work subnets maybe_cert_path systemTaskPeriod portToUse writePortTo backingFile log = do 27 | let subs = map (\(t, n, nonce, ranges) -> SubnetConfig t n nonce ranges) subnets 28 | putStrLn "Starting ic-ref..." 29 | BLS.init 30 | certs <- case maybe_cert_path of Nothing -> return [] 31 | Just ps -> C.listCertificates <$> fromJust <$> C.readCertificateStore ps 32 | conf <- makeRefConfig certs 33 | withRefConfig conf $ withApp subs (systemTaskPeriod * 1000000) backingFile $ \app -> do 34 | let app' = laxCorsSettings $ if log then logStdoutDev app else app 35 | case portToUse of 36 | Nothing -> 37 | withApplicationSettings settings (pure app') $ \port -> do 38 | greet port 39 | forever (threadDelay maxBound) 40 | Just port -> do 41 | greet port 42 | runSettings (setPort port settings) app' 43 | where 44 | greet port = do 45 | putStrLn $ "Running at http://127.0.0.1:" ++ show port ++ "/" 46 | for_ writePortTo $ \fn -> writeFile fn (show port) 47 | 48 | settings = setHost "127.0.0.1" defaultSettings 49 | 50 | -- Make sure that we reply succesfully to preflight checks. 51 | laxCorsSettings = cors $ \_ -> 52 | Just simpleCorsResourcePolicy 53 | { corsOrigins = Nothing, 54 | corsMethods = [ "GET" ], 55 | corsRequestHeaders = simpleHeaders ++ [ "X-Requested-With" ] 56 | } 57 | 58 | main :: IO () 59 | main = join . customExecParser (prefs showHelpOnError) $ 60 | info (helper <*> versions <*> parser) 61 | ( fullDesc 62 | <> header ("Internet Computer reference implementation " <> T.unpack implVersion) 63 | <> progDesc ( 64 | "A stand-alone local reference implementation of the Internet Computer. \ 65 | \By default, it listens on http://127.0.0.1:" ++ show defaultPort ++ "/. You \ 66 | \can change the port with --pick-port or --listen-port.") 67 | ) 68 | where 69 | versions :: Parser (a -> a) 70 | versions = 71 | infoOption (T.unpack implVersion) (long "version" <> help "show version number") 72 | <*> infoOption (T.unpack specVersion) (long "spec-version" <> help "show spec version number") 73 | defaultSubnetConfig :: [(SubnetType, W.Word64, String, [(W.Word64, W.Word64)])] 74 | defaultSubnetConfig = [(System, 1, "sk1", [nth_canister_range 0]), (Application, 1, "sk2", [nth_canister_range 1])] 75 | defaultSystemTaskPeriod :: Int 76 | defaultSystemTaskPeriod = 1 77 | parser :: Parser (IO ()) 78 | parser = work 79 | <$> 80 | ( 81 | ( 82 | option auto 83 | ( long "subnet-config" 84 | <> help ("choose initial subnet configuration consisting of subnet type, replication factor, nonce, and canister ranges for every subnet (default: " ++ show defaultSubnetConfig ++ ")") 85 | ) 86 | ) 87 | <|> pure defaultSubnetConfig 88 | ) 89 | <*> optional (strOption 90 | ( long "cert-path" 91 | <> help "path to certificate file or directory" 92 | ) 93 | ) 94 | <*> 95 | ( 96 | ( 97 | option auto 98 | ( long "system-task-period" 99 | <> help ("choose execution period (in integer seconds) for system tasks, i.e., heartbeats and global timers (default: " ++ show defaultSystemTaskPeriod ++ ")") 100 | ) 101 | ) 102 | <|> pure defaultSystemTaskPeriod 103 | ) 104 | <*> 105 | ( flag' Nothing 106 | ( long "pick-port" 107 | <> help ("pick a free port (instead of binding to 127.0.0.1:" ++ show defaultPort ++ ")") 108 | ) 109 | <|> 110 | (Just <$> 111 | option auto 112 | ( long "listen-port" 113 | <> help "specify the listen port" 114 | ) 115 | ) 116 | <|> pure (Just defaultPort) 117 | ) 118 | <*> optional (strOption 119 | ( long "write-port-to" 120 | <> help "write port to the given file" 121 | )) 122 | <*> optional (strOption 123 | ( long "state-file" 124 | <> metavar "FILE" 125 | <> help "file to persist IC state in" 126 | )) 127 | <*> switch 128 | ( long "http-log" 129 | <> help "print a HTTP log to stdout" 130 | ) 131 | -------------------------------------------------------------------------------- /src/IC/Test/Options.hs: -------------------------------------------------------------------------------- 1 | module IC.Test.Options where 2 | 3 | import qualified Data.ByteString.Lazy.UTF8 as BLU 4 | import qualified Data.Text as T 5 | import Data.Proxy 6 | import Data.List 7 | import qualified Data.Word as W 8 | import Test.Tasty.Options 9 | import Options.Applicative hiding (str) 10 | import Codec.Candid (Principal(..), parsePrincipal) 11 | import IC.Constants 12 | import IC.Crypto 13 | import IC.Id.Forms(mkSelfAuthenticatingId) 14 | import IC.Types 15 | 16 | -- Configuration: The URL of the endpoint to test 17 | 18 | newtype Endpoint = Endpoint String 19 | 20 | instance IsOption Endpoint where 21 | defaultValue = Endpoint "http://0.0.0.0:8001" 22 | parseValue s = Just $ Endpoint base 23 | where base | "/" `isSuffixOf` s = init s 24 | | otherwise = s 25 | optionName = return "endpoint" 26 | optionHelp = return "Internet Computer endpoint to connect to (default: http://0.0.0.0:8001)" 27 | optionCLParser = mkOptionCLParser (metavar "URL") 28 | 29 | endpointOption :: OptionDescription 30 | endpointOption = Option (Proxy :: Proxy Endpoint) 31 | 32 | -- Configuration: The URL of the httpbin endpoint for http_request tests 33 | 34 | newtype Httpbin = Httpbin String 35 | 36 | instance IsOption Httpbin where 37 | defaultValue = Httpbin "httpbin.org" 38 | parseValue = Just . Httpbin 39 | optionName = return "httpbin" 40 | optionHelp = return "httpbin endpoint (default: httpbin.org)" 41 | optionCLParser = mkOptionCLParser (metavar "URL") 42 | 43 | httpbinOption :: OptionDescription 44 | httpbinOption = Option (Proxy :: Proxy Httpbin) 45 | 46 | -- Configuration: Timeout for polling on the status of asynchronous requests 47 | 48 | newtype PollTimeout = PollTimeout Int 49 | 50 | instance IsOption PollTimeout where 51 | defaultValue = PollTimeout 300 52 | parseValue p = Just $ PollTimeout $ read p 53 | optionName = return "poll-timeout" 54 | optionHelp = return "Timeout for request polling in seconds (default: 300)" 55 | 56 | polltimeoutOption :: OptionDescription 57 | polltimeoutOption = Option (Proxy :: Proxy PollTimeout) 58 | 59 | -- Configuration: Allow self-signed certificates 60 | 61 | newtype AllowSelfSignedCerts = AllowSelfSignedCerts Bool 62 | 63 | instance IsOption AllowSelfSignedCerts where 64 | defaultValue = AllowSelfSignedCerts False 65 | parseValue p = Just $ AllowSelfSignedCerts $ read p 66 | optionName = return "allow-self-signed-certs" 67 | optionHelp = return $ "Allow self-signed certificates (default: " ++ show False ++ ")" 68 | 69 | allowSelfSignedCertsOption :: OptionDescription 70 | allowSelfSignedCertsOption = Option (Proxy :: Proxy AllowSelfSignedCerts) 71 | 72 | -- TestSubnetConfig: helper functions 73 | 74 | getSubnetIdFromNonce :: String -> EntityId 75 | getSubnetIdFromNonce nonce = EntityId $ mkSelfAuthenticatingId $ toPublicKey $ createSecretKeyBLS $ BLU.fromString nonce 76 | 77 | defaultSysTestSubnetConfig :: TestSubnetConfig 78 | defaultSysTestSubnetConfig = (getSubnetIdFromNonce "sk1", System, 1, [nth_canister_range 0], []) 79 | 80 | defaultAppTestSubnetConfig :: TestSubnetConfig 81 | defaultAppTestSubnetConfig = (getSubnetIdFromNonce "sk2", Application, 1, [nth_canister_range 1], []) 82 | 83 | readTestSubnetConfig :: Int -> ReadS TestSubnetConfig 84 | readTestSubnetConfig p x = do 85 | ((id, typ, size, ranges, ns), z) <- (readsPrec p x :: [((String, SubnetType, W.Word64, [(W.Word64, W.Word64)], [String]), String)]) 86 | Principal b <- case parsePrincipal (T.pack id) of Left err -> error err 87 | Right p -> return p 88 | return ((EntityId b, typ, size, ranges, ns), z) 89 | 90 | -- Configuration: Test subnet 91 | 92 | newtype TestSubnet = TestSubnet TestSubnetConfig 93 | 94 | instance Read TestSubnet where 95 | readsPrec p x = (\(y, z) -> (TestSubnet y, z)) <$> readTestSubnetConfig p x 96 | 97 | instance Show TestSubnet where 98 | show (TestSubnet (id, typ, size, ranges, ns)) = show (prettyID id, typ, size, ranges, ns) 99 | 100 | instance IsOption TestSubnet where 101 | defaultValue = TestSubnet defaultSysTestSubnetConfig 102 | parseValue = Just <$> read 103 | optionName = return "test-subnet-config" 104 | optionHelp = return $ "Test subnet configuration consisting of subnet ID, subnet type, replication factor, canister ranges, and node addresses; default: " ++ show (TestSubnet defaultSysTestSubnetConfig) 105 | 106 | testSubnetOption :: OptionDescription 107 | testSubnetOption = Option (Proxy :: Proxy TestSubnet) 108 | 109 | -- Configuration: Peer subnet 110 | 111 | newtype PeerSubnet = PeerSubnet TestSubnetConfig 112 | 113 | instance Read PeerSubnet where 114 | readsPrec p x = (\(y, z) -> (PeerSubnet y, z)) <$> readTestSubnetConfig p x 115 | 116 | instance Show PeerSubnet where 117 | show (PeerSubnet (id, typ, size, ranges, ns)) = show (prettyID id, typ, size, ranges, ns) 118 | 119 | instance IsOption PeerSubnet where 120 | defaultValue = PeerSubnet defaultAppTestSubnetConfig 121 | parseValue = Just <$> read 122 | optionName = return "peer-subnet-config" 123 | optionHelp = return $ "Peer subnet configuration consisting of subnet ID, subnet type, replication factor, canister ranges, and node addresses; default: " ++ show (PeerSubnet defaultAppTestSubnetConfig) 124 | 125 | peerSubnetOption :: OptionDescription 126 | peerSubnetOption = Option (Proxy :: Proxy PeerSubnet) 127 | -------------------------------------------------------------------------------- /src/IC/HashTree.hs: -------------------------------------------------------------------------------- 1 | -- | This module implements the (possible pruned) merkle trees used in the 2 | -- Internet Computer, in particular 3 | -- * Conversion from a labeled tree (with blobs) 4 | -- * Root hash reconstruction 5 | -- * Lookup 6 | -- * Pruning 7 | -- * Checking well-formedness 8 | 9 | {-# LANGUAGE TypeApplications #-} 10 | {-# LANGUAGE OverloadedStrings #-} 11 | module IC.HashTree where 12 | 13 | import qualified Data.Map.Lazy as M 14 | import qualified Data.Set as S 15 | import qualified Data.ByteString.Lazy as BS 16 | import Crypto.Hash (hashlazy, SHA256) 17 | import Data.ByteArray (convert) 18 | 19 | type Blob = BS.ByteString 20 | type Path = [Label] 21 | type Label = Blob 22 | type Value = Blob 23 | type Hash = Blob 24 | 25 | data LabeledTree 26 | = Value Value 27 | | SubTrees (M.Map Blob LabeledTree) 28 | deriving Show 29 | 30 | data HashTree 31 | = EmptyTree 32 | | Fork HashTree HashTree 33 | | Labeled Blob HashTree 34 | | Leaf Value 35 | | Pruned Hash 36 | deriving Show 37 | 38 | construct :: LabeledTree -> HashTree 39 | construct (Value v) = Leaf v 40 | construct (SubTrees m) = 41 | foldBinary EmptyTree Fork 42 | [ Labeled k (construct v) | (k,v) <- M.toAscList m ] 43 | 44 | foldBinary :: a -> (a -> a -> a) -> [a] -> a 45 | foldBinary e (⋔) = go 46 | where 47 | go [] = e 48 | go [x] = x 49 | go xs = go xs1 ⋔ go xs2 50 | where (xs1, xs2) = splitAt (length xs `div` 2) xs 51 | 52 | reconstruct :: HashTree -> Hash 53 | reconstruct = go 54 | where 55 | go EmptyTree = h $ domSep "ic-hashtree-empty" 56 | go (Fork t1 t2) = h $ domSep "ic-hashtree-fork" <> go t1 <> go t2 57 | go (Labeled l t) = h $ domSep "ic-hashtree-labeled" <> l <> go t 58 | go (Leaf v) = h $ domSep "ic-hashtree-leaf" <> v 59 | go (Pruned h) = h 60 | 61 | 62 | h :: BS.ByteString -> BS.ByteString 63 | h = BS.fromStrict . convert . hashlazy @SHA256 64 | 65 | domSep :: Blob -> Blob 66 | domSep s = BS.singleton (fromIntegral (BS.length s)) <> s 67 | 68 | data Res = Absent | Unknown | Error String | Found Value 69 | deriving (Eq, Show) 70 | 71 | -- See lookupL in IC.Test.HashTree for a high-level spec 72 | lookupPath :: HashTree -> Path -> Res 73 | lookupPath tree (l:ls) = find Absent (flatten tree) 74 | where 75 | find r [] = r 76 | find r (Labeled l' t : ts) | l < l' = r 77 | | l == l' = lookupPath t ls 78 | | otherwise = find Absent ts 79 | find _ (Pruned _ : ts) = find Unknown ts 80 | find _ (EmptyTree : _) = error "Empty in flattened list" 81 | find _ (Fork _ _ : _) = error "Fork in flattened list" 82 | find _ (Leaf _ : _) = Error "Found leaf when expecting subtree" 83 | 84 | lookupPath (Leaf v) [] = Found v 85 | lookupPath (Pruned _) [] = Unknown 86 | lookupPath (Labeled _ _) [] = Error "Found forest when expecting leaf" 87 | lookupPath (Fork _ _) [] = Error "Found forest when expecting leaf" 88 | lookupPath _ [] = Error "Found forest when expecting leaf" 89 | 90 | flatten :: HashTree -> [HashTree] 91 | flatten t = go t [] -- using difference lists 92 | where 93 | go EmptyTree = id 94 | go (Fork t1 t2) = go t1 . go t2 95 | go t = (t:) 96 | 97 | prune :: HashTree -> [Path] -> HashTree 98 | prune tree [] = Pruned (reconstruct tree) 99 | prune tree paths | [] `elem` paths = tree 100 | prune tree paths = go tree 101 | where 102 | -- These labels are availbale 103 | present :: S.Set Label 104 | present = S.fromList [ l | Labeled l _ <- flatten tree] 105 | 106 | -- We need all requested labels, and if not present, the immediate neighbors 107 | -- This maps labels to paths at that label that we need 108 | wanted :: M.Map Label (S.Set Path) 109 | wanted = M.fromListWith S.union $ concat 110 | [ if l `S.member` present 111 | then [ (l, S.singleton p) ] 112 | else 113 | [ (l', S.empty) | Just l' <- pure $ l `S.lookupLT` present ] ++ 114 | [ (l', S.empty) | Just l' <- pure $ l `S.lookupGT` present ] 115 | | l:p <- paths ] 116 | 117 | -- Smart constructor to avoid unnecessary forks 118 | fork t1 t2 119 | | prunedOrEmpty t1, prunedOrEmpty t2 = Pruned (reconstruct (Fork t1 t2)) 120 | | otherwise = Fork t1 t2 121 | where 122 | prunedOrEmpty (Pruned _) = True 123 | prunedOrEmpty EmptyTree = True 124 | prunedOrEmpty _ = False 125 | 126 | go EmptyTree = EmptyTree 127 | go (Labeled l subtree) 128 | | Just path_tails <- M.lookup l wanted = Labeled l (prune subtree (S.toList path_tails)) 129 | go (Fork t1 t2) = fork (go t1) (go t2) 130 | go tree = Pruned (reconstruct tree) 131 | 132 | 133 | wellFormed :: HashTree -> Either String () 134 | wellFormed (Leaf _) = return () 135 | wellFormed tree = wellFormedForest $ flatten tree 136 | 137 | wellFormedForest :: [HashTree] -> Either String () 138 | wellFormedForest trees = do 139 | isInOrder [ l | Labeled l _ <- trees ] 140 | sequence_ [ wellFormed t | Labeled _ t <- trees ] 141 | sequence_ [ Left "Value in forest" | Leaf _ <- trees ] 142 | 143 | isInOrder :: [Label] -> Either String () 144 | isInOrder [] = return () 145 | isInOrder [_] = return () 146 | isInOrder (x:y:zs) 147 | | x < y = isInOrder (y:zs) 148 | | otherwise = Left $ "Tree values out of order: " ++ show x ++ " " ++ show y 149 | -------------------------------------------------------------------------------- /src/IC/Test/Agent/UserCalls.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ImplicitParams #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | {-# LANGUAGE ConstraintKinds #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE BlockArguments #-} 9 | {-# LANGUAGE OverloadedLabels #-} 10 | {-# LANGUAGE TypeOperators #-} 11 | {-# LANGUAGE FlexibleContexts #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE NumericUnderscores #-} 14 | {-# LANGUAGE DataKinds #-} 15 | 16 | module IC.Test.Agent.UserCalls 17 | ( 18 | ic_canister_status'', 19 | ic_canister_info'', 20 | ic_delete_canister'', 21 | ic_deposit_cycles'', 22 | ic_ecdsa_public_key'', 23 | ic_http_get_request'', 24 | ic_install'', 25 | ic_raw_rand'', 26 | ic_set_controllers'', 27 | ic_sign_with_ecdsa'', 28 | ic_start_canister'', 29 | ic_stop_canister'', 30 | ic_top_up''', 31 | ic_uninstall'', 32 | ) where 33 | 34 | import qualified Data.Vector as Vec 35 | import qualified Data.Text as T 36 | import qualified Data.Word as W 37 | import Numeric.Natural 38 | import Test.Tasty.HUnit 39 | import Codec.Candid (Principal(..)) 40 | import Data.Row 41 | 42 | import IC.Management 43 | import IC.Id.Forms 44 | import IC.Test.Agent 45 | import IC.Test.Agent.Calls 46 | 47 | ic_install'' :: (HasCallStack, HasAgentConfig) => Blob -> InstallMode -> Blob -> Blob -> Blob -> IO (HTTPErrOr ReqResponse) 48 | ic_install'' user mode canister_id wasm_module arg = 49 | callIC'' user canister_id #install_code $ empty 50 | .+ #mode .== mode 51 | .+ #canister_id .== Principal canister_id 52 | .+ #wasm_module .== wasm_module 53 | .+ #arg .== arg 54 | .+ #sender_canister_version .== Nothing 55 | 56 | ic_uninstall'' :: HasAgentConfig => Blob -> Blob -> IO (HTTPErrOr ReqResponse) 57 | ic_uninstall'' user canister_id = 58 | callIC'' user canister_id #uninstall_code $ empty 59 | .+ #canister_id .== Principal canister_id 60 | .+ #sender_canister_version .== Nothing 61 | 62 | ic_set_controllers'' :: HasAgentConfig => Blob -> Blob -> [Blob] -> IO (HTTPErrOr ReqResponse) 63 | ic_set_controllers'' user canister_id new_controllers = do 64 | callIC'' user canister_id #update_settings $ empty 65 | .+ #canister_id .== Principal canister_id 66 | .+ #settings .== fromPartialSettings (#controllers .== Vec.fromList (map Principal new_controllers)) 67 | .+ #sender_canister_version .== Nothing 68 | 69 | ic_start_canister'' :: HasAgentConfig => Blob -> Blob -> IO (HTTPErrOr ReqResponse) 70 | ic_start_canister'' user canister_id = do 71 | callIC'' user canister_id #start_canister $ empty 72 | .+ #canister_id .== Principal canister_id 73 | 74 | ic_stop_canister'' :: HasAgentConfig => Blob -> Blob -> IO (HTTPErrOr ReqResponse) 75 | ic_stop_canister'' user canister_id = do 76 | callIC'' user canister_id #stop_canister $ empty 77 | .+ #canister_id .== Principal canister_id 78 | 79 | ic_canister_status'' :: HasAgentConfig => Blob -> Blob -> IO (HTTPErrOr ReqResponse) 80 | ic_canister_status'' user canister_id = do 81 | callIC'' user canister_id #canister_status $ empty 82 | .+ #canister_id .== Principal canister_id 83 | 84 | ic_canister_info'' :: HasAgentConfig => Blob -> Blob -> Maybe W.Word64 -> IO (HTTPErrOr ReqResponse) 85 | ic_canister_info'' user canister_id num_requested_changes = do 86 | callIC'' user canister_id #canister_info $ empty 87 | .+ #canister_id .== Principal canister_id 88 | .+ #num_requested_changes .== num_requested_changes 89 | 90 | ic_delete_canister'' :: HasAgentConfig => Blob -> Blob -> IO (HTTPErrOr ReqResponse) 91 | ic_delete_canister'' user canister_id = do 92 | callIC'' user canister_id #delete_canister $ empty 93 | .+ #canister_id .== Principal canister_id 94 | 95 | ic_deposit_cycles'' :: HasAgentConfig => Blob -> Blob -> IO (HTTPErrOr ReqResponse) 96 | ic_deposit_cycles'' user canister_id = do 97 | callIC'' user canister_id #deposit_cycles $ empty 98 | .+ #canister_id .== Principal canister_id 99 | 100 | ic_raw_rand'' :: HasAgentConfig => Blob -> Blob -> IO (HTTPErrOr ReqResponse) 101 | ic_raw_rand'' user ecid = do 102 | callIC'' user ecid #raw_rand () 103 | 104 | ic_http_get_request'' :: HasAgentConfig => Blob -> Blob -> IO (HTTPErrOr ReqResponse) 105 | ic_http_get_request'' user ecid = 106 | callIC'' user ecid #http_request $ empty 107 | .+ #url .== (T.pack $ "https://" ++ httpbin) 108 | .+ #max_response_bytes .== Nothing 109 | .+ #method .== enum #get 110 | .+ #headers .== Vec.empty 111 | .+ #body .== Nothing 112 | .+ #transform .== Nothing 113 | 114 | ic_ecdsa_public_key'' :: HasAgentConfig => Blob -> Blob -> IO (HTTPErrOr ReqResponse) 115 | ic_ecdsa_public_key'' user ecid = 116 | callIC'' user ecid #ecdsa_public_key $ empty 117 | .+ #derivation_path .== Vec.empty 118 | .+ #canister_id .== Nothing 119 | .+ #key_id .== (empty 120 | .+ #curve .== enum #secp256k1 121 | .+ #name .== (T.pack "0") 122 | ) 123 | 124 | ic_sign_with_ecdsa'' :: HasAgentConfig => Blob -> Blob -> Blob -> IO (HTTPErrOr ReqResponse) 125 | ic_sign_with_ecdsa'' user ecid msg = 126 | callIC'' user ecid #sign_with_ecdsa $ empty 127 | .+ #derivation_path .== Vec.empty 128 | .+ #message_hash .== msg 129 | .+ #key_id .== (empty 130 | .+ #curve .== enum #secp256k1 131 | .+ #name .== (T.pack "0") 132 | ) 133 | 134 | ic_top_up''' :: HasAgentConfig => IC00' -> Blob -> Natural -> IO (HTTPErrOr ReqResponse) 135 | ic_top_up''' ic00' canister_id amount = do 136 | callIC''' ic00' canister_id #provisional_top_up_canister $ empty 137 | .+ #canister_id .== Principal canister_id 138 | .+ #amount .== amount 139 | -------------------------------------------------------------------------------- /cbits/pair_BLS12381.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2012-2020 MIRACL UK Ltd. 3 | * 4 | * This file is part of MIRACL Core 5 | * (see https://github.com/miracl/core). 6 | * 7 | * Licensed under the Apache License, Version 2.0 (the "License"); 8 | * you may not use this file except in compliance with the License. 9 | * You may obtain a copy of the License at 10 | * 11 | * http://www.apache.org/licenses/LICENSE-2.0 12 | * 13 | * Unless required by applicable law or agreed to in writing, software 14 | * distributed under the License is distributed on an "AS IS" BASIS, 15 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 16 | * See the License for the specific language governing permissions and 17 | * limitations under the License. 18 | */ 19 | 20 | /** 21 | * @file pair.h 22 | * @author Mike Scott 23 | * @brief PAIR Header File 24 | * 25 | */ 26 | 27 | #ifndef PAIR_BLS12381_H 28 | #define PAIR_BLS12381_H 29 | 30 | #include "fp12_BLS12381.h" 31 | #include "ecp2_BLS12381.h" 32 | #include "ecp_BLS12381.h" 33 | 34 | /* Pairing constants */ 35 | 36 | extern const BIG_384_58 CURVE_Bnx_BLS12381; /**< BN curve x parameter */ 37 | extern const BIG_384_58 CURVE_Cru_BLS12381; /**< BN curve Cube Root of Unity */ 38 | 39 | extern const BIG_384_58 CURVE_W_BLS12381[2]; /**< BN curve constant for GLV decomposition */ 40 | extern const BIG_384_58 CURVE_SB_BLS12381[2][2]; /**< BN curve constant for GLV decomposition */ 41 | extern const BIG_384_58 CURVE_WB_BLS12381[4]; /**< BN curve constant for GS decomposition */ 42 | extern const BIG_384_58 CURVE_BB_BLS12381[4][4]; /**< BN curve constant for GS decomposition */ 43 | 44 | /* Pairing function prototypes */ 45 | 46 | /** @brief Precompute line functions details for fixed G2 value 47 | * 48 | @param T array of precomputed FP4 partial line functions 49 | @param GV a fixed ECP2 instance 50 | */ 51 | extern void PAIR_BLS12381_precomp(FP4_BLS12381 T[], ECP2_BLS12381* GV); 52 | 53 | 54 | 55 | /** @brief Precompute line functions for n-pairing 56 | * 57 | @param r array of precomputed FP12 products of line functions 58 | @param PV ECP2 instance, an element of G2 59 | @param QV ECP instance, an element of G1 60 | 61 | */ 62 | extern void PAIR_BLS12381_another(FP12_BLS12381 r[], ECP2_BLS12381* PV, ECP_BLS12381* QV); 63 | 64 | 65 | /** @brief Compute line functions for n-pairing, assuming precomputation on G2 66 | * 67 | @param r array of precomputed FP12 products of line functions 68 | @param T array contains precomputed partial line fucntions from G2 69 | @param QV ECP instance, an element of G1 70 | 71 | */ 72 | extern void PAIR_BLS12381_another_pc(FP12_BLS12381 r[], FP4_BLS12381 T[], ECP_BLS12381 *QV); 73 | 74 | 75 | /** @brief Calculate Miller loop for Optimal ATE pairing e(P,Q) 76 | * 77 | @param r FP12 result of the pairing calculation e(P,Q) 78 | @param P ECP2 instance, an element of G2 79 | @param Q ECP instance, an element of G1 80 | 81 | */ 82 | extern void PAIR_BLS12381_ate(FP12_BLS12381 *r, ECP2_BLS12381 *P, ECP_BLS12381 *Q); 83 | /** @brief Calculate Miller loop for Optimal ATE double-pairing e(P,Q).e(R,S) 84 | * 85 | Faster than calculating two separate pairings 86 | @param r FP12 result of the pairing calculation e(P,Q).e(R,S), an element of GT 87 | @param P ECP2 instance, an element of G2 88 | @param Q ECP instance, an element of G1 89 | @param R ECP2 instance, an element of G2 90 | @param S ECP instance, an element of G1 91 | */ 92 | extern void PAIR_BLS12381_double_ate(FP12_BLS12381 *r, ECP2_BLS12381 *P, ECP_BLS12381 *Q, ECP2_BLS12381 *R, ECP_BLS12381 *S); 93 | /** @brief Final exponentiation of pairing, converts output of Miller loop to element in GT 94 | * 95 | Here p is the internal modulus, and r is the group order 96 | @param x FP12, on exit = x^((p^12-1)/r) 97 | */ 98 | extern void PAIR_BLS12381_fexp(FP12_BLS12381 *x); 99 | /** @brief Fast point multiplication of a member of the group G1 by a BIG number 100 | * 101 | May exploit endomorphism for speed. 102 | @param Q ECP member of G1. 103 | @param b BIG multiplier 104 | 105 | */ 106 | extern void PAIR_BLS12381_G1mul(ECP_BLS12381 *Q, BIG_384_58 b); 107 | /** @brief Fast point multiplication of a member of the group G2 by a BIG number 108 | * 109 | May exploit endomorphism for speed. 110 | @param P ECP2 member of G1. 111 | @param b BIG multiplier 112 | 113 | */ 114 | extern void PAIR_BLS12381_G2mul(ECP2_BLS12381 *P, BIG_384_58 b); 115 | /** @brief Fast raising of a member of GT to a BIG power 116 | * 117 | May exploit endomorphism for speed. 118 | @param x FP12 member of GT. 119 | @param b BIG exponent 120 | 121 | */ 122 | extern void PAIR_BLS12381_GTpow(FP12_BLS12381 *x, BIG_384_58 b); 123 | 124 | /** @brief Tests ECP for membership of G1 125 | * 126 | @param P ECP member of G1 127 | @return true or false 128 | 129 | */ 130 | extern int PAIR_BLS12381_G1member(ECP_BLS12381 *P); 131 | 132 | /** @brief Tests ECP2 for membership of G2 133 | * 134 | @param P ECP2 member of G2 135 | @return true or false 136 | 137 | */ 138 | extern int PAIR_BLS12381_G2member(ECP2_BLS12381 *P); 139 | /** @brief Tests FP12 for membership of GT 140 | * 141 | @param x FP12 instance 142 | @return 1 if x is in GT, else return 0 143 | 144 | */ 145 | extern int PAIR_BLS12381_GTmember(FP12_BLS12381 *x); 146 | 147 | /** @brief Prepare Ate parameter 148 | * 149 | @param n BIG parameter 150 | @param n3 BIG paramter = 3*n 151 | @return number of nits in n3 152 | 153 | */ 154 | extern int PAIR_BLS12381_nbits(BIG_384_58 n3, BIG_384_58 n); 155 | 156 | /** @brief Initialise structure for multi-pairing 157 | * 158 | @param r FP12 array, to be initialised to 1 159 | 160 | */ 161 | extern void PAIR_BLS12381_initmp(FP12_BLS12381 r[]); 162 | 163 | 164 | /** @brief Miller loop 165 | * 166 | @param res FP12 result 167 | @param r FP12 precomputed array of accumulated line functions 168 | 169 | */ 170 | extern void PAIR_BLS12381_miller(FP12_BLS12381 *res, FP12_BLS12381 r[]); 171 | 172 | #endif 173 | -------------------------------------------------------------------------------- /src/IC/Test/HashTree.hs: -------------------------------------------------------------------------------- 1 | -- Unit/Prop tests for IC.HashTree 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# OPTIONS_GHC -Wno-orphans #-} 4 | module IC.Test.HashTree (hashTreeTests) where 5 | 6 | import Data.List 7 | import Test.Tasty 8 | import Test.Tasty.HUnit 9 | import Test.Tasty.QuickCheck 10 | import qualified Data.Map.Lazy as M 11 | import qualified Data.ByteString.Lazy as BS 12 | import qualified Text.Hex as T 13 | import Codec.CBOR.Term 14 | import Codec.CBOR.Write 15 | 16 | import IC.HashTree 17 | import IC.HashTree.CBOR 18 | import Data.Bifunctor 19 | 20 | hashTreeTests :: TestTree 21 | hashTreeTests = testGroup "Hash tree tests" 22 | [ testGroup "Examples in spec document" 23 | [ testCase "CBOR of full tree" $ 24 | asHex (toLazyByteString $ encodeTerm $ encodeHashTree exampleTree) 25 | @?= exampleTreeCBOR 26 | , testCase "root hash of full tree" $ 27 | asHex (reconstruct exampleTree) 28 | @?= "eb5c5b2195e62d996b84c9bcc8259d19a83786a2f59e0878cec84c811f669aa0" 29 | , testCase "CBOR of pruned tree" $ 30 | asHex (toLazyByteString $ encodeTerm $ encodeHashTree prunedTree) 31 | @?= prunedTreeCBOR 32 | , testCase "root hash of pruned tree" $ 33 | asHex (reconstruct exampleTree) 34 | @?= asHex (reconstruct prunedTree) 35 | , testCase "tree lokups" $ do 36 | lookupPath prunedTree ["a", "a"] @?= Unknown 37 | lookupPath prunedTree ["a", "y"] @?= Found "world" 38 | lookupPath prunedTree ["aa"] @?= Absent 39 | lookupPath prunedTree ["ax"] @?= Absent 40 | lookupPath prunedTree ["b"] @?= Unknown 41 | lookupPath prunedTree ["bb"] @?= Unknown 42 | lookupPath prunedTree ["d"] @?= Found "morning" 43 | lookupPath prunedTree ["e"] @?= Absent 44 | ] 45 | , testProperty "lookup succeeds" $ \lt (AsPath p)-> 46 | lookupPath (construct lt) p === lookupL lt p 47 | , testProperty "prune preserves hash" $ \lt (AsPaths ps) -> 48 | let ht = construct lt 49 | in reconstruct ht === reconstruct (prune ht ps) 50 | , testProperty "prune preserves lookups" $ \lt (AsPaths ps) (AsPath p) -> 51 | let ht = construct lt 52 | in notError (lookupPath ht p) ==> 53 | if any (`isPrefixOf` p) ps 54 | then lookupPath (prune ht ps) p === lookupPath ht p 55 | else lookupPath (prune ht ps) p `elemP` [Unknown, Absent] 56 | ] 57 | 58 | asHex :: BS.ByteString -> T.Text 59 | asHex = T.encodeHex . BS.toStrict 60 | 61 | exampleTree :: HashTree 62 | exampleTree = 63 | Fork 64 | (Fork 65 | (Labeled "a" 66 | (Fork 67 | (Fork 68 | (Labeled "x" (Leaf "hello")) 69 | EmptyTree 70 | ) 71 | (Labeled "y" (Leaf "world")) 72 | ) 73 | ) 74 | (Labeled "b" (Leaf "good")) 75 | ) 76 | (Fork 77 | (Labeled "c" EmptyTree) 78 | (Labeled "d" (Leaf "morning") 79 | ) 80 | ) 81 | 82 | prunedTree :: HashTree 83 | prunedTree = prune exampleTree [["a","y"], ["ax"], ["d"]] 84 | 85 | exampleTreeCBOR :: T.Text 86 | exampleTreeCBOR = "8301830183024161830183018302417882034568656c6c6f810083024179820345776f726c6483024162820344676f6f648301830241638100830241648203476d6f726e696e67" 87 | 88 | prunedTreeCBOR :: T.Text 89 | prunedTreeCBOR = "83018301830241618301820458201b4feff9bef8131788b0c9dc6dbad6e81e524249c879e9f10f71ce3749f5a63883024179820345776f726c6483024162820458207b32ac0c6ba8ce35ac82c255fc7906f7fc130dab2a090f80fe12f9c2cae83ba6830182045820ec8324b8a1f1ac16bd2e806edba78006479c9877fed4eb464a25485465af601d830241648203476d6f726e696e67" 90 | 91 | 92 | -- This is, in a way, the spec for lookupPath 93 | lookupL :: LabeledTree -> Path -> Res 94 | lookupL (Value _) (_:_) = Error "Found leaf when expecting subtree" 95 | lookupL (SubTrees sts) (l:ls) = case M.lookup l sts of 96 | Just st -> lookupL st ls 97 | Nothing -> Absent 98 | lookupL (Value v) [] = Found v 99 | lookupL (SubTrees _) [] = Error "Found forest when expecting leaf" 100 | 101 | notError :: Res -> Bool 102 | notError (Error _) = False 103 | notError _ = True 104 | 105 | -- Property based testing infrastructure 106 | -- (slightly more verbose because IC.HashTree is not very typed 107 | 108 | elemP :: (Eq a, Show a) => a -> [a] -> Property 109 | x `elemP` xs = disjoin $ map (x ===) xs 110 | 111 | genValue :: Gen Value 112 | genValue = BS.pack <$> arbitrary 113 | 114 | genLabel :: Gen Label 115 | genLabel = oneof [ pure "", pure "hello", pure "world", BS.pack <$> arbitrary ] 116 | 117 | 118 | newtype AsLabel = AsLabel { asLabel :: Label } 119 | instance Arbitrary AsLabel where arbitrary = AsLabel <$> genLabel 120 | instance Show AsLabel where show (AsLabel l) = show l 121 | 122 | newtype AsPath = AsPath { asPath :: Path } 123 | instance Arbitrary AsPath where 124 | arbitrary = AsPath . map asLabel <$> arbitrary 125 | shrink (AsPath ps) = map AsPath (init (inits ps)) 126 | instance Show AsPath where show (AsPath l) = show l 127 | 128 | newtype AsPaths = AsPaths { _asPaths :: [Path] } 129 | instance Arbitrary AsPaths where 130 | arbitrary = AsPaths . map asPath <$> arbitrary 131 | shrink (AsPaths ps) = AsPaths <$> 132 | [ as ++ bs | (as,_,bs) <- splits ] ++ 133 | [ as ++ [v'] ++ bs | (as,v,bs) <- splits, AsPath v' <- shrink (AsPath v) ] 134 | where 135 | splits = [(as,v,bs) | i <- [0..length ps-1], (as,v:bs) <- pure $ splitAt i ps ] 136 | instance Show AsPaths where show (AsPaths l) = show l 137 | 138 | instance Arbitrary LabeledTree where 139 | arbitrary = sized go 140 | where 141 | go 0 = Value <$> genValue 142 | go n = oneof 143 | [ Value <$> genValue 144 | , resize (n `div` 2) $ 145 | SubTrees . M.fromList . map (first asLabel) <$> arbitrary 146 | ] 147 | shrink (Value _) = [Value ""] 148 | shrink (SubTrees m) = SubTrees <$> 149 | [ M.delete k m | k <- M.keys m ] ++ 150 | [ M.insert k v' m | (k,v) <- M.toList m, v' <- shrink v ] 151 | 152 | 153 | -------------------------------------------------------------------------------- /cbits/bls_BLS12381.c: -------------------------------------------------------------------------------- 1 | /* 2 | * Copyright (c) 2012-2020 MIRACL UK Ltd. 3 | * 4 | * This file is part of MIRACL Core 5 | * (see https://github.com/miracl/core). 6 | * 7 | * Licensed under the Apache License, Version 2.0 (the "License"); 8 | * you may not use this file except in compliance with the License. 9 | * You may obtain a copy of the License at 10 | * 11 | * http://www.apache.org/licenses/LICENSE-2.0 12 | * 13 | * Unless required by applicable law or agreed to in writing, software 14 | * distributed under the License is distributed on an "AS IS" BASIS, 15 | * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 16 | * See the License for the specific language governing permissions and 17 | * limitations under the License. 18 | */ 19 | 20 | /* Boneh-Lynn-Shacham signature 128-bit API */ 21 | 22 | /* Loosely (for now) following https://datatracker.ietf.org/doc/html/draft-irtf-cfrg-bls-signature-02 */ 23 | 24 | // Minimal-signature-size variant 25 | 26 | #include 27 | #include 28 | #include 29 | #include "bls_BLS12381.h" 30 | 31 | 32 | static FP4_BLS12381 G2_TAB[G2_TABLE_BLS12381]; // space for precomputation on fixed G2 parameter 33 | 34 | #define CEIL(a,b) (((a)-1)/(b)+1) 35 | 36 | /* output u[i] \in F_p */ 37 | /* https://datatracker.ietf.org/doc/draft-irtf-cfrg-hash-to-curve/ */ 38 | static void hash_to_field(int hash,int hlen,FP_BLS12381 *u,octet *DST,octet *M, int ctr) 39 | { 40 | int i,j,L; 41 | BIG_384_58 q,w; 42 | DBIG_384_58 dx; 43 | char okm[256],fd[128]; 44 | octet OKM = {0,sizeof(okm),okm}; 45 | 46 | BIG_384_58_rcopy(q, Modulus_BLS12381); 47 | L=CEIL(BIG_384_58_nbits(q)+CURVE_SECURITY_BLS12381,8); 48 | 49 | XMD_Expand(hash,hlen,&OKM,L*ctr,DST,M); 50 | for (i=0;ival, s); 118 | S->len = MODBYTES_384_58; 119 | 120 | // SkToPk 121 | 122 | PAIR_BLS12381_G2mul(&G, s); 123 | //ECP2_BLS12381_toOctet(W, &G, true); 124 | ECP2_BLS12381_toOctet_ZCash(W, &G); 125 | return BLS_OK; 126 | } 127 | 128 | /* Sign message M using private key S to produce signature SIG */ 129 | int BLS_BLS12381_CORE_SIGN(octet *SIG, octet *M, octet *S) 130 | { 131 | BIG_384_58 s; 132 | ECP_BLS12381 D; 133 | BLS_HASH_TO_POINT(&D, M); 134 | BIG_384_58_fromBytes(s, S->val); 135 | PAIR_BLS12381_G1mul(&D, s); 136 | //ECP_BLS12381_toOctet(SIG, &D, true); /* compress output */ 137 | ECP_BLS12381_toOctet_ZCash(SIG, &D); /* compress output */ 138 | return BLS_OK; 139 | } 140 | 141 | /* Verify signature of message M, the signature SIG, and the public key W */ 142 | int BLS_BLS12381_CORE_VERIFY(octet *SIG, octet *M, octet *W) 143 | { 144 | FP12_BLS12381 v; 145 | ECP2_BLS12381 G, PK; 146 | ECP_BLS12381 D, HM; 147 | BLS_HASH_TO_POINT(&HM, M); 148 | 149 | //if (!ECP_BLS12381_fromOctet(&D, SIG)) return BLS_FAIL; 150 | if (!ECP_BLS12381_fromOctet_ZCash(&D, SIG)) return BLS_FAIL; 151 | if (!PAIR_BLS12381_G1member(&D)) return BLS_FAIL; 152 | ECP_BLS12381_neg(&D); 153 | 154 | //if (!ECP2_BLS12381_fromOctet(&PK, W)) return BLS_FAIL; 155 | if (!ECP2_BLS12381_fromOctet_ZCash(&PK, W)) return BLS_FAIL; 156 | if (!PAIR_BLS12381_G2member(&PK)) return BLS_FAIL; 157 | 158 | // Use new multi-pairing mechanism 159 | 160 | /* 161 | FP12_BLS12381 r[ATE_BITS_BLS12381]; 162 | PAIR_BLS12381_initmp(r); 163 | PAIR_BLS12381_another_pc(r, G2_TAB, &D); 164 | PAIR_BLS12381_another(r, &PK, &HM); 165 | PAIR_BLS12381_miller(&v, r); 166 | */ 167 | 168 | //.. or alternatively 169 | if (!ECP2_BLS12381_generator(&G)) return BLS_FAIL; 170 | PAIR_BLS12381_double_ate(&v,&G,&D,&PK,&HM); 171 | 172 | PAIR_BLS12381_fexp(&v); 173 | if (FP12_BLS12381_isunity(&v)) return BLS_OK; 174 | return BLS_FAIL; 175 | } 176 | 177 | --------------------------------------------------------------------------------